diff --git a/Blog/Blog b/Blog/Blog index 1d0aae2..0125bf1 100755 Binary files a/Blog/Blog and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 8756bc9..6cdd7e5 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -11,12 +11,13 @@ import Framework.Response import Framework.TEngine.TemplateUtil import Framework.Urls import Framework.Utils -import Framework.Forms +import Framework.Forms.Validation import Framework.Models import Framework.Pager import Config import Models +import Plugins messagecodes = [("1","Пост успешно добавлен."), ("2","Комментарий добавлен."), diff --git a/Blog/Makefile b/Blog/Makefile index 32a7f99..dee61a0 100644 --- a/Blog/Makefile +++ b/Blog/Makefile @@ -15,3 +15,114 @@ Blog: *.hs $(TEMPLATES) clean: rm *.hi *.o *.hcr +# DO NOT DELETE: Beginning of Haskell dependencies +../Framework/Types.o : ../Framework/Types.hs +../Framework/Utils.o : ../Framework/Utils.hs +../Framework/Utils.o : ../Framework/Types.hi +../Framework/Cache.o : ../Framework/Cache.hs +../Framework/Cache.o : ../Framework/Utils.hi +../Framework/Middlewares.o : ../Framework/Middlewares.hs +../Framework/Middlewares.o : ../Framework/Utils.hi +../Framework/Urls.o : ../Framework/Urls.hs +../Framework/Urls.o : ../Framework/Types.hi +../Framework/Urls.o : ../Framework/Utils.hi +../Framework/Response.o : ../Framework/Response.hs +../Framework/Response.o : ../Framework/Urls.hi +../Framework/Response.o : ../Framework/Utils.hi +../Framework/Response.o : ../Framework/Types.hi +../Framework/Cookies.o : ../Framework/Cookies.hs +../Framework/Cookies.o : ../Framework/Urls.hi +../Framework/Cookies.o : ../Framework/Utils.hi +../Framework/Cookies.o : ../Framework/Types.hi +../Framework/Sessions.o : ../Framework/Sessions.hs +../Framework/Sessions.o : ../Framework/Cookies.hi +../Framework/Sessions.o : ../Framework/Utils.hi +../Framework/Sessions.o : ../Framework/Types.hi +../Framework/TEngine/TemplateFuncs.o : ../Framework/TEngine/TemplateFuncs.hs +../Framework/TEngine/TemplateFuncs.o : ../Framework/Types.hi +../Framework/HTTPServer.o : ../Framework/HTTPServer.hs +../Framework/HTTPServer.o : ../Framework/Middlewares.hi +../Framework/HTTPServer.o : ../Framework/Response.hi +../Framework/HTTPServer.o : ../Framework/Utils.hi +../Framework/HTTPServer.o : ../Framework/Urls.hi +../Framework/HTTPServer.o : ../Framework/Types.hi +../Framework/Models.o : ../Framework/Models.hs +../Framework/Models.o : ../Framework/Types.hi +../Framework/Forms/Types.o : ../Framework/Forms/Types.hs +../Framework/Forms/Types.o : ../Framework/Models.hi +../Framework/Forms/Types.o : ../Framework/Types.hi +../Framework/Forms/HTML.o : ../Framework/Forms/HTML.hs +../Framework/Forms/HTML.o : ../Framework/Types.hi +../Framework/Forms/HTML.o : ../Framework/Utils.hi +../Framework/Forms/HTML.o : ../Framework/Urls.hi +../Framework/Forms/HTML.o : ../Framework/Forms/Types.hi +../Framework/SQL.o : ../Framework/SQL.hs +../Framework/SQL.o : ../Framework/Models.hi +../Framework/Storage.o : ../Framework/Storage.hs +../Framework/Storage.o : ../Framework/Models.hi +../Framework/Storage.o : ../Framework/Types.hi +../Framework/API.o : ../Framework/API.hs +../Framework/API.o : ../Framework/Response.hi +../Framework/API.o : ../Framework/Models.hi +../Framework/API.o : ../Framework/SQL.hi +../Framework/API.o : ../Framework/Cache.hi +../Framework/API.o : ../Framework/Urls.hi +../Framework/API.o : ../Framework/Storage.hi +../Framework/API.o : ../Framework/Sessions.hi +../Framework/API.o : ../Framework/Cookies.hi +../Framework/API.o : ../Framework/Utils.hi +../Framework/API.o : ../Framework/Types.hi +../Framework/Forms/Validation.o : ../Framework/Forms/Validation.hs +../Framework/Forms/Validation.o : ../Framework/Forms/HTML.hi +../Framework/Forms/Validation.o : ../Framework/Forms/Types.hi +../Framework/Forms/Validation.o : ../Framework/Response.hi +../Framework/Forms/Validation.o : ../Framework/Models.hi +../Framework/Forms/Validation.o : ../Framework/API.hi +../Framework/Forms/Validation.o : ../Framework/Urls.hi +../Framework/Forms/Validation.o : ../Framework/Utils.hi +../Framework/Forms/Validation.o : ../Framework/Types.hi +../Framework/Pager.o : ../Framework/Pager.hs +../Framework/Pager.o : ../Framework/Types.hi +../Framework/Pager.o : ../Framework/Urls.hi +../Framework/Pager.o : ../Framework/API.hi +../Framework/Pager.o : ../Framework/SQL.hi +../Framework/Pager.o : ../Framework/Models.hi +../Framework/Pager.o : ../Framework/Forms/HTML.hi +../Framework/Pager.o : ../Framework/Forms/Types.hi +Config.o : Config.hs +Config.o : ../Framework/Types.hi +../Framework/Markdown.o : ../Framework/Markdown.hs +Models.o : Models.hs +Models.o : ../Framework/Markdown.hi +Models.o : ../Framework/Models.hi +Models.o : ../Framework/Forms/Validation.hi +Models.o : ../Framework/Forms/HTML.hi +Models.o : ../Framework/Forms/Types.hi +Models.o : ../Framework/Storage.hi +Models.o : ../Framework/Types.hi +../Framework/TEngine/Templates.o : ../Framework/TEngine/Templates.hs +../Framework/TEngine/Templates.o : Models.hi +../Framework/TEngine/Templates.o : ../Framework/TEngine/TemplateFuncs.hi +../Framework/TEngine/Templates.o : ../Framework/Utils.hi +../Framework/TEngine/Templates.o : ../Framework/Types.hi +../Framework/TEngine/TemplateUtil.o : ../Framework/TEngine/TemplateUtil.hs +../Framework/TEngine/TemplateUtil.o : ../Framework/Cache.hi +../Framework/TEngine/TemplateUtil.o : ../Framework/API.hi +../Framework/TEngine/TemplateUtil.o : ../Framework/Types.hi +../Framework/TEngine/TemplateUtil.o : ../Framework/TEngine/Templates.hi +../Framework/TEngine/TemplateUtil.o : ../Framework/Response.hi +Blog.o : Blog.hs +Blog.o : Models.hi +Blog.o : Config.hi +Blog.o : ../Framework/Pager.hi +Blog.o : ../Framework/Models.hi +Blog.o : ../Framework/Forms/Validation.hi +Blog.o : ../Framework/Utils.hi +Blog.o : ../Framework/Urls.hi +Blog.o : ../Framework/TEngine/TemplateUtil.hi +Blog.o : ../Framework/Response.hi +Blog.o : ../Framework/HTTPServer.hi +Blog.o : ../Framework/SQL.hi +Blog.o : ../Framework/API.hi +Blog.o : ../Framework/Types.hi +# DO NOT DELETE: End of Haskell dependencies diff --git a/Blog/Models.hs b/Blog/Models.hs index 99497c5..9bee8c5 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -9,7 +9,9 @@ import Database.HDBC.ColTypes (SqlTypeId (..)) import Framework.Types import Framework.Storage -import Framework.Forms +import Framework.Forms.Types +import Framework.Forms.HTML +import Framework.Forms.Validation import Framework.Models import Framework.Markdown diff --git a/Blog/Plugins.hs b/Blog/Plugins.hs new file mode 100644 index 0000000..32a2363 --- /dev/null +++ b/Blog/Plugins.hs @@ -0,0 +1,6 @@ +module Plugins where + +import Framework.Forms.Types + +simple :: Form -> Form +simple = id diff --git a/Framework/Forms.hs b/Framework/Forms.hs deleted file mode 100644 index 1c30111..0000000 --- a/Framework/Forms.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} -module Framework.Forms - ( - Inputbox, Textarea, - inputbox, textarea, - HTMLTag (..), - tag, tagToHtml, toHtml, - createform, refillForm, - retryForm, retryEditForm, - returnInvalidForm, - Form (..), - FormField (..), - formVars, formVarsNames, formVarsValues, - notEmpty, noValidate, - defValidate, - getAnyForm, getForm, - FormsPlugins - ) where -- $doc - -import Debug.Trace - -import qualified Data.Map as M -import Data.Maybe - -import Network.Shed.Httpd (Request,Response) -import qualified Database.HDBC as D - -import Framework.Types -import Framework.Utils -import Framework.Urls -import Framework.API -import Framework.Models -import Framework.Response (redirectG) - -type FormsPlugins = [Form -> Form] - --- $doc --- HTML forms generation and validation. - --- | Types of this class represent HTML widgets -class Widget w where - -- | Type of widget content; not used at the moment. - type WContent w - -- | Generate HTML for widget - html :: w -- ^ A widget - -> String -- ^ Widget's html \"name\" attribute - -> String -- ^ Value of widget - -> HTMLTag - -- | Read widget's value from string. Not used yet. - wRead :: String -> WContent w - -type HTML = [HTMLTag] - -data HTMLTag = Tag { - tagName :: String, - tagAttrs :: [FormVar], - tagContent :: HTML, - mayCollapse :: Bool - } - | Text String - -data HTMLForm = HTMLForm { - visibleFields :: HTML, - hiddenFields :: HTML, - htmlFormName :: String, - formId :: String, - formAction :: String } - -tag :: String -> [FormVar] -> HTML -> HTMLTag -tag name attrs content = Tag name attrs content True - -tagE :: String -> [FormVar] -> HTML -> HTMLTag -tagE name attrs content = Tag name attrs content False - -toHtml :: HTML -> String -toHtml html = concat $ map tagToHtml html - -tagToHtml :: HTMLTag -> String -tagToHtml (Text text) = text -tagToHtml (Tag name attrs value coll) = "<"++name++(concat $ map htmlAttr attrs)++content++">" - where content | null value = if not coll - then "></"++name - else " /" - | otherwise = if coll - then ">\n"++(toHtml value)++"\n</"++name - else ">"++(toHtml value)++"</"++name - -hiddenField :: String -> String -> HTMLTag -hiddenField name value = tag "input" ["name" =: name, "value" =: value, "type" =: "hidden"] [] - -mangleName :: String -> String -> String -> String -mangleName formname fid name = formname++fid++"-"++name - --- -- | Generate <form> tag --- formTag :: String -> String -> String -> HTML -> String --- formTag name fid action content = tag "form" ["method" =: "POST","action" =: action] ([fidfield, namefield] ++ content) --- where fidfield = hiddenField "formid" fid --- namefield = hiddenField "formname" name - -formToHtml :: HTMLForm -> String -formToHtml form = tagToHtml $ tag "form" ["method" =: "POST","action" =: (formAction form), "id" =: tagid] $ - [tag "table" [] $ (visibleFields form) ++ (hiddenFields form) ++ [fidfield, namefield, submit]] - where fidfield = hiddenField "formid" (formId form) - namefield = hiddenField "formname" (htmlFormName form) - tagid = (htmlFormName form)++(formId form) - - --- | Generate form row (widget with label) -formrow :: String -- ^ Form name - -> String -- ^ Form ID - -> String -- ^ Default value for widget - -> String -- ^ `class` attribute for <tr> - -> FormField -- ^ Field - -> HTMLTag -formrow fname fid def cls (Field name label widget _) = tag "tr" attrs [tag "td" [] [Text itemlabel], - tag "td" [] [html widget itemname def]] - where attrs = if null cls - then [] - else ["class" =: cls] - itemlabel = if null label - then (capitalize name)++":" - else label - itemname = mangleName fname fid name - -submit :: HTMLTag -submit = tag "tr" [] [tag "td" [] [], - tag "td" [] [tag "input" ["type" =: "submit"] []]] - -createform :: Form - -> String - -> [(String,String)] - -> String - -> HTMLForm -createform form fid pairs action = HTMLForm vFields hFields name fid action - where vFields = map (formrow name fid "" "") (fFields form) - hFields = map ((uncurry hiddenField).mangle) pairs - name = formName form - mangle (n,v) = (mangleName name fid n, v) - --- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and --- fill with previous values -refillFormG :: (String -> String -> String -> String) -- ^ Mangle function - -> [String] -- ^ List of erroneus filled fields names - -> Form -- ^ A form to generate - -> String -- ^ Form ID - -> [(String,String)] -- ^ Hidden values - -> [(String,String)] -- ^ (name,value) pairs (already filled) - -> String -- ^ Form's target url - -> HTMLForm -refillFormG mfun errfields form fid hidden pairs action = HTMLForm vFields hFields name fid action - where vFields = zipWith3 (formrow name fid) vals clss (fFields form) - hFields = map ((uncurry hiddenField).mangle) hidden - vals = map (\n -> maybe "" id $ lookup (mfun name fid n) pairs) names - names = map fName (fFields form) - clss = map (\n -> if n `elem` errfields then "error" else "") names - name = formName form - mangle (n,v) = (mfun name fid n, v) - -refillForm = refillFormG mangleName -refillFormU = refillFormG (\x y z -> z) - --- | Generate a form, maybe filled with already-entered data -retryForm :: ActionConfig - -> Form -- ^ A form - -> String -- ^ Form ID - -> [(String,String)] -- ^ Hidden values - -> String -- ^ Target URL - -> IO (String, String) -- ^ (Form HTML, error message) -retryForm conf form fid pairs action = do - filled <- sessionLookup conf "filled" --- putStrLn $ "retryForm: Session read: "++(show filled) - let defvals = decodePairs filled --- putStrLn $ "retryForm: defvals: "++(show defvals) - let err = httpGetVar' (request conf) "invalid" "" - if null err - then return (formToHtml $ createform form fid pairs action, "") - else return (formToHtml $ refillForm (words err) form fid pairs defvals action, err) - -retryEditForm :: ActionConfig - -> Form -- ^ A form - -> String -- ^ Form ID - -> [(String,String)] -- ^ Default values - -> [(String,String)] -- ^ Hidden values - -> String -- ^ Target URL - -> IO (String, String) -- ^ (Form HTML, error message) -retryEditForm conf form fid defvals hidden action = do - filled <- sessionLookup conf "filled" - let filledVals = decodePairs filled - let err = httpGetVar' (request conf) "invalid" "" - if null err - then return (formToHtml $ refillFormU [] form fid hidden defvals action, "") - else return (formToHtml $ refillForm (words err) form fid hidden filledVals action, err) - -returnInvalidForm :: ActionConfig -> Form -> String -> [String] -> IO Response -returnInvalidForm conf form fid errs = - do sessionSet conf "filled" values - return $ redirectG (myUrl $ request conf) ["invalid" =: (unwords errs)] - where values = tail $ urlencode $ map packHeader vars - vars = formVars form fid (request conf) - -htmlAttr :: FormVar -> String -htmlAttr (name := value) | httpEmpty value = "" - | otherwise = " "++name++"='"++(httpShow value)++"'" - -emptyTags = ["textarea"] - -data Inputbox = Inputbox { ibWidth :: HttpBox } -inputbox = Inputbox (HB (Nothing::Maybe Int)) - -data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox } -textarea = Textarea (HB $ Just 60) (HB $ Just 15) - -instance Widget Inputbox where - type WContent Inputbox = String - html (Inputbox w) name value = tag "input" ["size" =: w, "name" =: name, "value" =: value] [] - wRead = id - -instance Widget Textarea where - type WContent Textarea = String - html (Textarea c r) name value = tagE "textarea" ["cols" =: c, "rows" =: r, "name" =: name] [Text value] - wRead = id - -type FormValidator = Request -> Either [String] Model -type FieldValidator = String -> Either String String - -data FormField = forall w. (Widget w) => Field { - fName :: String, - fLabel :: String, - fWidget :: w, - fValidate :: FieldValidator - } - -data Form = Form { - formName :: String, - formModel :: Model, - fFields :: [FormField] - } - -isRight :: Either t1 t -> Bool -isRight (Right _) = True -isRight _ = False - -isLeft :: Either t1 t -> Bool -isLeft = not.isRight - -fromRight :: Either t1 t -> t -fromRight (Right x) = x -fromRight _ = error "fromRight applicable only to Right arguments!" - -fromLeft :: Either t t1 -> t -fromLeft (Left x) = x -fromLeft _ = error "fromLeft applicable only to Left arguments!" - -defValidate :: Form -> String -> FormValidator -defValidate form fid rq = - if all isRight maybes - then Right $ record (formModel form) $ map D.toSql fields - else Left $ map fromLeft $ filter isLeft maybes - where fields = map fromRight maybes - maybes :: [Either String String] - maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) (fFields form)) vars - vars :: [String] - vars = formVarsValues form fid rq - -formVarsValues :: Form -> String -> Request -> [String] -formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) - -formVarsNames :: Form -> String -> [String] -formVarsNames form fid = map (mangleName (formName form) fid) $ map fName $ fFields form - -formVars :: Form -> String -> Request -> [(String,String)] -formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) - -notEmpty :: String -> FieldValidator -notEmpty msg s = if null s - then Left msg - else Right s - -noValidate :: FieldValidator -noValidate s = Right s - ----------------------------------------------------------------------------------------------------- - -getAnyForm :: M.Map String Form -> Request -> (Either [String] Model, String, String) -getAnyForm mm rq = case form of - Nothing -> (Left [], "","") - Just form' -> (defValidate form' fid rq, formname, fid) - where formname = httpPostVar' rq "formname" "" - form = M.lookup formname mm - fid = httpPostVar' rq "formid" "" - -getForm :: M.Map String Form -> Request -> String -> (Either [String] Model, String) -getForm mm rq name = if name==formname - then (e,fid) - else (Left [], "") - where (e,formname,fid) = getAnyForm mm rq diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs new file mode 100644 index 0000000..78316e8 --- /dev/null +++ b/Framework/Forms/HTML.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} +module Framework.Forms.HTML + (Inputbox, Textarea, + inputbox, textarea, + tag, tagToHtml, toHtml, + formrow, hiddenField, + mangleName, + formToHtml, createform + ) where + +import Framework.Forms.Types +import Framework.Urls +import Framework.Utils +import Framework.Types + +tag :: String -> [FormVar] -> HTML -> HTMLTag +tag name attrs content = Tag name attrs content True + +tagE :: String -> [FormVar] -> HTML -> HTMLTag +tagE name attrs content = Tag name attrs content False + +toHtml :: HTML -> String +toHtml html = concat $ map tagToHtml html + +tagToHtml :: HTMLTag -> String +tagToHtml (Text text) = text +tagToHtml (Tag name attrs value coll) = "<"++name++(concat $ map htmlAttr attrs)++content++">" + where content | null value = if not coll + then "></"++name + else " /" + | otherwise = if coll + then ">\n"++(toHtml value)++"\n</"++name + else ">"++(toHtml value)++"</"++name + +hiddenField :: String -> String -> HTMLTag +hiddenField name value = tag "input" ["name" =: name, "value" =: value, "type" =: "hidden"] [] + +mangleName :: String -> String -> String -> String +mangleName formname fid name = formname++fid++"-"++name + +formToHtml :: HTMLForm -> String +formToHtml form = tagToHtml $ tag "form" ["method" =: "POST","action" =: (formAction form), "id" =: tagid] $ + [tag "table" [] $ (visibleFields form) ++ (hiddenFields form) ++ [fidfield, namefield, submit]] + where fidfield = hiddenField "formid" (formId form) + namefield = hiddenField "formname" (htmlFormName form) + tagid = (htmlFormName form)++(formId form) + +-- | Generate form row (widget with label) +formrow :: String -- ^ Form name + -> String -- ^ Form ID + -> String -- ^ Default value for widget + -> String -- ^ `class` attribute for <tr> + -> FormField -- ^ Field + -> HTMLTag +formrow fname fid def cls (Field name label widget _) = tag "tr" attrs [tag "td" [] [Text itemlabel], + tag "td" [] [html widget itemname def]] + where attrs = if null cls + then [] + else ["class" =: cls] + itemlabel = if null label + then (capitalize name)++":" + else label + itemname = mangleName fname fid name + +submit :: HTMLTag +submit = tag "tr" [] [tag "td" [] [], + tag "td" [] [tag "input" ["type" =: "submit"] []]] + +htmlAttr :: FormVar -> String +htmlAttr (name := value) | httpEmpty value = "" + | otherwise = " "++name++"='"++(httpShow value)++"'" + +createform :: Form + -> String + -> [(String,String)] + -> String + -> HTMLForm +createform form fid pairs action = HTMLForm vFields hFields name fid action + where vFields = map (formrow name fid "" "") (fFields form) + hFields = map ((uncurry hiddenField).mangle) pairs + name = formName form + mangle (n,v) = (mangleName name fid n, v) + +emptyTags = ["textarea"] + +data Inputbox = Inputbox { ibWidth :: HttpBox } +inputbox = Inputbox (HB (Nothing::Maybe Int)) + +data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox } +textarea = Textarea (HB $ Just 60) (HB $ Just 15) + +instance Widget Inputbox where + type WContent Inputbox = String + html (Inputbox w) name value = tag "input" ["size" =: w, "name" =: name, "value" =: value] [] + wRead = id + +instance Widget Textarea where + type WContent Textarea = String + html (Textarea c r) name value = tagE "textarea" ["cols" =: c, "rows" =: r, "name" =: name] [Text value] + wRead = id + + diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs new file mode 100644 index 0000000..a012aa6 --- /dev/null +++ b/Framework/Forms/Types.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} +module Framework.Forms.Types + (Form (..), FormField (..), + HTMLForm (..), + HTMLTag (..), HTML, + Widget (..), + FormsPlugins, + FormValidator, FieldValidator + ) where + +import Network.Shed.Httpd (Request) + +import Framework.Types +import Framework.Models + +type FormsPlugins = [Form -> Form] + +-- $doc +-- HTML forms generation and validation. + +-- | Types of this class represent HTML widgets +class Widget w where + -- | Type of widget content; not used at the moment. + type WContent w + -- | Generate HTML for widget + html :: w -- ^ A widget + -> String -- ^ Widget's html \"name\" attribute + -> String -- ^ Value of widget + -> HTMLTag + -- | Read widget's value from string. Not used yet. + wRead :: String -> WContent w + +type HTML = [HTMLTag] + +data HTMLTag = Tag { + tagName :: String, + tagAttrs :: [FormVar], + tagContent :: HTML, + mayCollapse :: Bool + } + | Text String + +data HTMLForm = HTMLForm { + visibleFields :: HTML, + hiddenFields :: HTML, + htmlFormName :: String, + formId :: String, + formAction :: String } + +type FormValidator = Request -> Either [String] Model +type FieldValidator = String -> Either String String + +data FormField = forall w. (Widget w) => Field { + fName :: String, + fLabel :: String, + fWidget :: w, + fValidate :: FieldValidator + } + +data Form = Form { + formName :: String, + formModel :: Model, + fFields :: [FormField] + } diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs new file mode 100644 index 0000000..c7e50f6 --- /dev/null +++ b/Framework/Forms/Validation.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} +module Framework.Forms.Validation + (refillForm, + retryForm, retryEditForm, + returnInvalidForm, + formVars, formVarsNames, formVarsValues, + notEmpty, noValidate, + defValidate, + getAnyForm, getForm + ) where -- $doc + +import Debug.Trace + +import qualified Data.Map as M +import Data.Maybe + +import Network.Shed.Httpd (Request,Response) +import qualified Database.HDBC as D + +import Framework.Types +import Framework.Utils +import Framework.Urls +import Framework.API +import Framework.Models +import Framework.Response (redirectG) + +import Framework.Forms.Types +import Framework.Forms.HTML + +import Plugins + +-- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and +-- fill with previous values +refillFormG :: (String -> String -> String -> String) -- ^ Mangle function + -> [String] -- ^ List of erroneus filled fields names + -> Form -- ^ A form to generate + -> String -- ^ Form ID + -> [(String,String)] -- ^ Hidden values + -> [(String,String)] -- ^ (name,value) pairs (already filled) + -> String -- ^ Form's target url + -> HTMLForm +refillFormG mfun errfields form fid hidden pairs action = HTMLForm vFields hFields name fid action + where vFields = zipWith3 (formrow name fid) vals clss (fFields form) + hFields = map ((uncurry hiddenField).mangle) hidden + vals = map (\n -> maybe "" id $ lookup (mfun name fid n) pairs) names + names = map fName (fFields form) + clss = map (\n -> if n `elem` errfields then "error" else "") names + name = formName form + mangle (n,v) = (mfun name fid n, v) + +refillForm = refillFormG mangleName +refillFormU = refillFormG (\x y z -> z) + +-- | Generate a form, maybe filled with already-entered data +retryForm :: ActionConfig + -> Form -- ^ A form + -> String -- ^ Form ID + -> [(String,String)] -- ^ Hidden values + -> String -- ^ Target URL + -> IO (String, String) -- ^ (Form HTML, error message) +retryForm conf form fid pairs action = do + filled <- sessionLookup conf "filled" +-- putStrLn $ "retryForm: Session read: "++(show filled) + let defvals = decodePairs filled +-- putStrLn $ "retryForm: defvals: "++(show defvals) + let err = httpGetVar' (request conf) "invalid" "" + if null err + then return (formToHtml $ createform form fid pairs action, "") + else return (formToHtml $ refillForm (words err) form fid pairs defvals action, err) + +retryEditForm :: ActionConfig + -> Form -- ^ A form + -> String -- ^ Form ID + -> [(String,String)] -- ^ Default values + -> [(String,String)] -- ^ Hidden values + -> String -- ^ Target URL + -> IO (String, String) -- ^ (Form HTML, error message) +retryEditForm conf form fid defvals hidden action = do + filled <- sessionLookup conf "filled" + let filledVals = decodePairs filled + let err = httpGetVar' (request conf) "invalid" "" + if null err + then return (formToHtml $ refillFormU [] form fid hidden defvals action, "") + else return (formToHtml $ refillForm (words err) form fid hidden filledVals action, err) + +returnInvalidForm :: ActionConfig -> Form -> String -> [String] -> IO Response +returnInvalidForm conf form fid errs = + do sessionSet conf "filled" values + return $ redirectG (myUrl $ request conf) ["invalid" =: (unwords errs)] + where values = tail $ urlencode $ map packHeader vars + vars = formVars form fid (request conf) +isRight :: Either t1 t -> Bool +isRight (Right _) = True +isRight _ = False + +isLeft :: Either t1 t -> Bool +isLeft = not.isRight + +fromRight :: Either t1 t -> t +fromRight (Right x) = x +fromRight _ = error "fromRight applicable only to Right arguments!" + +fromLeft :: Either t t1 -> t +fromLeft (Left x) = x +fromLeft _ = error "fromLeft applicable only to Left arguments!" + +defValidate :: Form -> String -> FormValidator +defValidate form fid rq = + if all isRight maybes + then Right $ record (formModel form) $ map D.toSql fields + else Left $ map fromLeft $ filter isLeft maybes + where fields = map fromRight maybes + maybes :: [Either String String] + maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) (fFields form)) vars + vars :: [String] + vars = formVarsValues form fid rq + +formVarsValues :: Form -> String -> Request -> [String] +formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) + +formVarsNames :: Form -> String -> [String] +formVarsNames form fid = map (mangleName (formName form) fid) $ map fName $ fFields form + +formVars :: Form -> String -> Request -> [(String,String)] +formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) + +notEmpty :: String -> FieldValidator +notEmpty msg s = if null s + then Left msg + else Right s + +noValidate :: FieldValidator +noValidate s = Right s + +---------------------------------------------------------------------------------------------------- + +getAnyForm :: M.Map String Form -> Request -> (Either [String] Model, String, String) +getAnyForm mm rq = case form of + Nothing -> (Left [], "","") + Just form' -> (defValidate form' fid rq, formname, fid) + where formname = httpPostVar' rq "formname" "" + form = M.lookup formname mm + fid = httpPostVar' rq "formid" "" + +getForm :: M.Map String Form -> Request -> String -> (Either [String] Model, String) +getForm mm rq name = if name==formname + then (e,fid) + else (Left [], "") + where (e,formname,fid) = getAnyForm mm rq diff --git a/Framework/HTTPServer.hs b/Framework/HTTPServer.hs index 813887b..8e3b2ba 100644 --- a/Framework/HTTPServer.hs +++ b/Framework/HTTPServer.hs @@ -15,7 +15,7 @@ import Framework.Urls import Framework.Utils import Framework.Response import Framework.Middlewares -import Framework.Forms (Form,FormsPlugins) +-- import Framework.Forms (Form,FormsPlugins) sendfile :: String -> IO Response sendfile filename = do diff --git a/Framework/Pager.hs b/Framework/Pager.hs index e2068ff..5f80374 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -7,7 +7,8 @@ module Framework.Pager import Database.HDBC (SqlValue (..), fromSql) import Network.Shed.Httpd (Request) -import Framework.Forms +import Framework.Forms.Types +import Framework.Forms.HTML import Framework.Models import Framework.SQL import Framework.API diff --git a/Models.hs b/Models.hs deleted file mode 100644 index 1416572..0000000 --- a/Models.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE FlexibleInstances,NoMonomorphismRestriction, ExistentialQuantification #-} -module Models where - -import qualified Data.Map as M -import Database.HDBC (fromSql) - -import Framework.Types -import Framework.Storage -import Framework.Forms - -data User = User { - _userId :: Int, - _username :: String, - _password :: String } - -userId :: (TemplateOne a) => a -> Int -userId = transformInt 1 id -username :: (TemplateItem a) => a -> String -username = transformString 1 id -password :: (TemplateOne a) => a -> String -password = transformString 2 id - -instance Table User where - record [uId, uName, uPass] = User (fromSql uId) (fromSql uName) (fromSql uPass) - record [uName,uPass] = User 0 (fromSql uName) (fromSql uPass) - -instance TemplateOne User where - showO (User uId uName uPass) = "#"++(show uId)++". "++(show uName)++" -- "++(show uPass) - intField _ = _userId - stringField 1 = _username - stringField 2 = _password - boolField _ = error "undefined boolField for User" - -userForm = Form { - formName = "userform", - fFields = [ Field "name" "Username:" inputbox (notEmpty "name"), - Field "password" "" inputbox noValidate ] - } - -formsList :: [Form] -formsList = [userForm] - -allForms :: M.Map String Form -allForms = M.fromList [(formName form, form) | form <- formsList] diff --git a/rebuild b/rebuild deleted file mode 100755 index 7a0a577..0000000 --- a/rebuild +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash - -./TemplateGen -make clean -make - diff --git a/test.db b/test.db deleted file mode 100644 index 0b29d55..0000000 Binary files a/test.db and /dev/null differ diff --git a/test.hs b/test.hs deleted file mode 100644 index 5ff6432..0000000 --- a/test.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -import Prelude hiding (print,putStr) -import Debug.Trace - -import System.IO hiding (print) -import System.IO.UTF8 -import Network.Shed.Httpd -import qualified Data.Map as M -import Database.HDBC (SqlValue(..)) - -import Framework.Types -import Framework.Urls -import Framework.Utils -import Framework.HTTPServer -import Framework.TEngine.TemplateUtil -import Framework.Forms -import Framework.API -import Models - --- testing _ _ = return $ ok "Happy new year!" - -printyear :: StrAction -printyear _ _ s = let year = read s :: Int - in if year < 2010 - then Just $ return $ ok $ "<p>Blog posts for year "++s++":</p>" - else Just $ return $ ok $ "<h1>Year in the future</h1>" - -manyfun :: ManyStrAction -manyfun _ _ [y,m] = Just $ return $ ok $ "<p> Blog posts for "++y++"/"++m++": </p>" - -formfun :: HttpAction -formfun _ rq@(Request {reqMethod}) = - case reqMethod of - "GET" -> return $ renderToResponse "testform.html" [("title", C (title::String))] - "POST" -> do print (reqBody rq) - return $ redirectG "/form/" ["title" =: testval] - where title = httpGetVar' rq "title" "Nothing" - testval = httpPostVar' rq "title" "Empty" - -printUsers :: HttpActionParams -> Request -> IO Response -printUsers hp rq = withConfig hp rq $ \conf -> do - - (form, err) <- retryForm conf userForm "1" url - case reqMethod rq of - "GET" -> do - us <- queryR' conf "SELECT * FROM users" [] :: IO [User] - let key = (show $ length us)++(show err)++(show $ length form) - renderToResponseC conf key "first.html" [("users", C us), - ("title", C "Some title"), - ("list", C ["first","second","third"]), - ("include",C "inctest.html"), - ("form", C form), - ("invalid",C err)] - "POST" -> do - let (d,_) = getForm allForms rq "userform" - case d of - Right user -> let uname = _username user - upass = _password user - in do print uname - print upass - query conf "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass] - commit conf - return $ redirect url - Left e -> returnInvalidForm conf userForm "1" e - where url = myUrl rq - -urlconf :: URLConf -urlconf = "blog" // year ~/ month ~>> manyfun - <|> "blog" // year ~> printyear - <|> "users" --> printUsers - <|> "form" --> formfun - <|> Function serveStatic - -params :: HttpActionParams -params = HP { docdir = "www", - hLog = stdout, - dbDriver = "sqlite3", - dbPath = "test.db", - cacheDriver = "memcached", - cachePath = "localhost:11211", - sessionsDriver = "files", - sessionsPath = "tmp/sessions/" - } - -main :: IO () -main = serveHttp 8080 params urlconf -