diff --git a/Forms.hs b/Forms.hs index 3343f92..b509571 100644 --- a/Forms.hs +++ b/Forms.hs @@ -18,48 +18,56 @@ import Network.Shed.Httpd (Request) import qualified Database.HDBC as D import Types import Urls +import API class Widget w where type WContent w html :: w -> String -> String -> String wRead :: String -> WContent w -makeform :: (HttpValue a) => a -> String -> String -makeform action = tag "form" [("method", HB "POST"),("action", HB action)] +makeform :: (HttpValue a) => String -> String -> a -> String -> String +makeform name fid action content = tag "form" ["method" =: "POST","action" =: action] (fidfield++namefield++content) + where fidfield = tag "input" ["name" =: "formid", "type" =: "hidden", "value" =: fid] "" + namefield = tag "input" ["name" =: "formname", "type" =: "hidden", "value" =: name] "" -formrow :: (HttpValue [a]) => String -> [a] -> FormField -> String -formrow def cls (Field name "" widget f) = formrow def cls (Field name ((capitalize name)++":") widget f) -formrow def cls (Field name label widget _) = tag "tr" attrs $ (tag "td" [] label)++(tag "td" [] (html widget name def)) +formrow :: (HttpValue [a]) => String -> String -> String -> [a] -> FormField -> String +formrow fname fid def cls (Field name label widget _) = tag "tr" attrs $ (tag "td" [] itemlabel)++(tag "td" [] (html widget itemname def)) where attrs = if null cls then [] - else [("class", HB cls)] + else ["class" =: cls] + itemlabel = if null label + then (capitalize name)++":" + else label + itemname = fname++fid++"-"++name submit :: String submit = "<tr><td></td><td><input type='submit'/></td></tr>\n" -createform :: (HttpValue a) => Form -> a -> String -createform (Form {fFields}) action = makeform action content - where content = tag' "table" [] (concat $ map (formrow "" "") fFields)++submit +createform :: (HttpValue a) => Form -> String -> a -> String +createform form fid action = makeform name fid action content + where content = tag' "table" [] (concat $ map (formrow name fid "" "") (fFields form))++submit + name = formName form -editform :: (HttpValue a) => [String] -> Form -> [(String,String)] -> a -> String -editform errfields (Form {fFields}) pairs action = makeform action content - where content = tag' "table" [] (concat $ zipWith3 formrow vals clss fFields)++submit - vals = map (\n -> maybe "" id $ lookup n pairs) names - names = map fName fFields +editform :: (HttpValue a) => [String] -> Form -> String -> [(String,String)] -> a -> String +editform errfields form fid pairs action = makeform name fid action content + where content = tag' "table" [] (concat $ zipWith3 (formrow name fid) vals clss (fFields form))++submit + vals = map (\n -> maybe "" id $ lookup (name++fid++"-"++n) pairs) names + names = map fName (fFields form) clss = map (\n -> if n `elem` errfields then "error" else "") names + name = formName form -htmlAttr :: String -> HttpBox -> String -htmlAttr name value | httpEmpty value = "" - | otherwise = " "++name++"='"++(httpShow value)++"'" +htmlAttr :: FormVar -> String +htmlAttr (name := value) | httpEmpty value = "" + | otherwise = " "++name++"='"++(httpShow value)++"'" -tag :: String -> [(String,HttpBox)] -> String -> String -tag name attrs value = "<"++name++(concat $ map (uncurry htmlAttr) attrs)++content++">" +tag :: String -> [FormVar] -> String -> String +tag name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">" where content = if null value then " /" else ">"++value++"</"++name -tag' :: String -> [(String,HttpBox)] -> String -> String -tag' name attrs value = "<"++name++(concat $ map (uncurry htmlAttr) attrs)++content++">\n" +tag' :: String -> [FormVar] -> String -> String +tag' name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">\n" where content = if null value then " /" else ">\n"++value++"</"++name @@ -72,12 +80,12 @@ textarea = Textarea (HB (Nothing::Maybe Int)) (HB (Nothing::Maybe Int)) instance Widget Inputbox where type WContent Inputbox = String - html (Inputbox w) name value = tag "input" [("size", HB w), ("name", HB name), ("value", HB value)] "" + 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 = tag "textarea" [("cols", HB c), ("rows", HB r), ("name", HB name)] value + html (Textarea c r) name value = tag "textarea" ["cols" =: c, "rows" =: r, "name" =: name] value wRead = id type FormValidator a = Request -> Either [String] a @@ -91,6 +99,7 @@ data FormField = forall w. (Widget w) => Field { } data Form = Form { + formName :: String, fFields :: [FormField] } @@ -109,24 +118,24 @@ fromLeft :: Either t t1 -> t fromLeft (Left x) = x fromLeft _ = error "fromLeft applicable only to Left arguments!" -defValidate :: (Table a) => Form -> FormValidator a -defValidate form@(Form {fFields}) rq = +defValidate :: (Table a) => Form -> String -> FormValidator a +defValidate form fid rq = if all isRight maybes then Right $ record $ map (D.toSql . fromRight) maybes else Left $ map fromLeft $ filter isLeft maybes where maybes :: [Either String String] - maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) fFields) vars + maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) (fFields form)) vars vars :: [String] - vars = formVarsValues form rq + vars = formVarsValues form fid rq -formVarsValues :: Form -> Request -> [String] -formVarsValues form rq = map (\name -> httpPostVar' rq name "") (formVarsNames form) +formVarsValues :: Form -> String -> Request -> [String] +formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) -formVarsNames :: Form -> [String] -formVarsNames form = map fName $ fFields form +formVarsNames :: Form -> String -> [String] +formVarsNames form fid = map ((formName form)++) $ map (fid++) $ map ("-"++) $ map fName $ fFields form -formVars :: Form -> Request -> [(String,String)] -formVars form rq = zip (formVarsNames form) (formVarsValues form rq) +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 @@ -135,3 +144,7 @@ notEmpty msg s = if null s noValidate :: FieldValidator noValidate s = Right s + +---------------------------------------------------------------------------------------------------- + + diff --git a/Models.hs b/Models.hs index baa5fce..73658b1 100644 --- a/Models.hs +++ b/Models.hs @@ -28,6 +28,7 @@ instance TemplateOne User where boolField _ = error "undefined boolField for User" userForm = Form { + formName = "userform", fFields = [ Field "name" "Username:" inputbox (notEmpty "name"), Field "password" "" inputbox noValidate ] } diff --git a/Types.hs b/Types.hs index 4ac9567..70b0503 100644 --- a/Types.hs +++ b/Types.hs @@ -83,6 +83,7 @@ instance HttpValue HttpBox where data HttpHeader = String := HttpBox type UrlParam = HttpHeader +type FormVar = HttpHeader (=:) :: (HttpValue v) => String -> v -> HttpHeader name =: value = name := (HB value) diff --git a/test.hs b/test.hs index b259278..72815ff 100644 --- a/test.hs +++ b/test.hs @@ -39,8 +39,8 @@ printUsers hp rq@(Request {reqMethod}) = withConfig hp rq $ \conf -> do let defvals = decodePairs filled let form = if null err - then createform userForm url - else editform (words err) userForm defvals url + then createform userForm "1" url + else editform (words err) userForm "1" defvals url case reqMethod of "GET" -> do @@ -52,7 +52,7 @@ printUsers hp rq@(Request {reqMethod}) = withConfig hp rq $ \conf -> do ("form", C form), ("invalid",C err)] "POST" -> do - case defValidate userForm rq of + case defValidate userForm "1" rq of Right user -> let uname = _username user upass = _password user in do query conf "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass] @@ -64,7 +64,7 @@ printUsers hp rq@(Request {reqMethod}) = withConfig hp rq $ \conf -> do where url = myUrl rq err = httpGetVar' rq "invalid" "" values = tail $ urlencode $ map packHeader vars - vars = formVars userForm rq + vars = formVars userForm "1" rq urlconf = "blog" // year ~/ month ~>> manyfun