diff --git a/Forms.hs b/Forms.hs new file mode 100644 index 0000000..5439b22 --- /dev/null +++ b/Forms.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns #-} +module Forms + (Inputbox, Textarea, + inputbox, textarea, + tag, + createform, + Form (..), + FormField (..), + notEmpty, noValidate, + defValidate + ) where + +import Types +import Utils +import Data.Maybe +import Network.Shed.Httpd (Request) +import qualified Database.HDBC as D +import Types +import Urls + +class Widget w where + html :: w -> String -> String + +data Inputbox = Inputbox { ibWidth :: HttpBox, ibValue :: String } +inputbox = Inputbox (HB (Nothing::Maybe Int)) + +data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox, tbValue :: String } +textarea = Textarea (HB (Nothing::Maybe Int)) (HB (Nothing::Maybe Int)) + +createform (Form {fFields}) action = tag "form" [("method", HB "POST"),("action", HB action)] content + where formrow (Field name "" widget f) = formrow (Field name ((capitalize name)++":") widget f) + formrow (Field name label widget _) = "<tr><td>"++label++"</td><td>"++(html widget name)++"</td>\n" + submit = "<tr><td></td><td><input type='submit'/></td></tr>\n" + content = "<table>\n"++(concat $ map formrow fFields)++submit++"</table>\n" + +htmlAttr :: String -> HttpBox -> 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++">" + where content = if null value + then " /" + else ">"++value++"</"++name + +instance Widget Inputbox where + html (Inputbox w v) name = tag "input" [("size", HB w), ("name", HB name)] v + +instance Widget Textarea where + html (Textarea c r v) name = tag "textarea" [("cols", HB c), ("rows", HB r), ("name", HB name)] v + +data FormField = forall w. (Widget w) => Field { + fName :: String, + fLabel :: String, + fWidget :: w, + fValidate :: String -> Either String String + } + +data (Table a) => Form a = Form { + fFields :: [FormField] + } + +isRight (Right _) = True +isRight _ = False + +isLeft = not.isRight + +fromRight (Right x) = x +fromRight _ = error "fromRight applicable only to Right arguments!" + +fromLeft (Left x) = x +fromLeft _ = error "fromLeft applicable only to Left arguments!" + +defValidate :: (Table a) => Form a -> Request -> Either String a +defValidate (Form {fFields}) rq = + if all isRight maybes + then Right $ record $ map (D.toSql . fromRight) maybes + else Left $ unwords $ map fromLeft $ filter isLeft maybes + where maybes :: [Either String String] + maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) fFields) vars + vars :: [String] + vars = map (\name -> httpPostVar' rq name "") $ map fName fFields + +notEmpty msg s = if null s + then Left msg + else Right s + +noValidate s = Right s diff --git a/HtmlGen.hs b/HtmlGen.hs deleted file mode 100644 index 86c7c0e..0000000 --- a/HtmlGen.hs +++ /dev/null @@ -1,40 +0,0 @@ -module HtmlGen - (Inputbox, Textarea, - inputbox, textarea, - tag, - createform - ) where - -import Types -import Utils - -class Widget w where - html :: w -> String -> String - -data Inputbox = Inputbox { ibWidth :: HttpBox, ibValue :: String } -inputbox = Inputbox (HB (Nothing::Maybe Int)) - -data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox, tbValue :: String } -textarea = Textarea (HB (Nothing::Maybe Int)) (HB (Nothing::Maybe Int)) - -createform list action = tag "form" [("method", HB "POST"),("action", HB action)] content - where formrow (name,"",widget) = formrow (name,(capitalize name)++":",widget) - formrow (name,label,widget) = "<tr><td>"++label++"</td><td>"++(html widget name)++"</td>\n" - submit = "<tr><td></td><td><input type='submit'/></td></tr>\n" - content = "<table>\n"++(concat $ map formrow list)++submit++"</table>\n" - -htmlAttr :: String -> HttpBox -> 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++">" - where content = if null value - then " /" - else ">"++value++"</"++name - -instance Widget Inputbox where - html (Inputbox w v) name = tag "input" [("size", HB w), ("name", HB name)] v - -instance Widget Textarea where - html (Textarea c r v) name = tag "textarea" [("cols", HB c), ("rows", HB r), ("name", HB name)] v diff --git a/Models.hs b/Models.hs index 6f1743b..40d590d 100644 --- a/Models.hs +++ b/Models.hs @@ -1,20 +1,33 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances,NoMonomorphismRestriction, ExistentialQuantification #-} module Models where import Types import Storage import Database.HDBC (fromSql) +import Forms data User = User { - userId :: Int, - username :: String, - password :: String } + _userId :: Int, + _username :: String, + _password :: String } + +userId = transformInt 1 id +username :: forall a. (TemplateItem a) => a -> String +username = transformString 1 id +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 Stringable User where - showT (User uId uName uPass) = "#"++(show uId)++". "++(show uName)++" -- "++(show 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" -models :: [String] -models = ["User"] +userForm = Form { + fFields = [ Field "name" "Username:" (inputbox "") (notEmpty "name"), + Field "password" "" (inputbox "") noValidate ] + } diff --git a/Storage.hs b/Storage.hs index bb27955..98c4f44 100644 --- a/Storage.hs +++ b/Storage.hs @@ -16,9 +16,6 @@ import Database.HDBC (SqlValue(..)) import Types -class Table t where - record :: [D.SqlValue] -> t - data DBConnection = forall c. D.IConnection c => DBC c connect :: String -> String -> IO DBConnection diff --git a/TemplateFuncs.hs b/TemplateFuncs.hs new file mode 100644 index 0000000..e941187 --- /dev/null +++ b/TemplateFuncs.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module TemplateFuncs + (bold, + uppercase,lowercase, + evenP,oddP, + list + ) where + +import Data.Char +import Data.List + +import Types + +_bold s = "<strong>"++s++"</strong>" +bold = transformString 1 _bold + +uppercase = transformString 1 $ map toUpper +lowercase = transformString 1 $ map toLower + +evenP = transformInt 1 even +oddP = transformInt 1 odd + +list :: String -> (String -> String) -> SFunction +list sep f lst = concat $ intersperse sep $ map (transform f) (mkList lst) + where transform f = \(C x) -> f (stringField 1 x) + +separateWith :: String -> SFunction +separateWith s = list s id diff --git a/TemplateGen.hs b/TemplateGen.hs index b0ece20..681e379 100644 --- a/TemplateGen.hs +++ b/TemplateGen.hs @@ -8,7 +8,6 @@ import Control.Monad import qualified Data.Map as M import Utils -import Models (models) import TemplateParser -------------------------------------------------------------------------------------------------- @@ -20,9 +19,9 @@ import TemplateParser -------------------------------------------------------------------------------------------------- quote s = "\""++s++"\"" -getvar v = "maybe \"\" showT (M.lookup "++quote v++" pairs)" +getvar v = "maybe \"\" showC (M.lookup "++quote v++" pairs)" -getlist t n = "maybe (T"++t++"List []) id (M.lookup "++quote n++" pairs)" +getlist n = "maybe (C ([]::[Int])) id (M.lookup "++quote n++" pairs)" hash t = sum $ map hashF t hash' = show.hash @@ -48,7 +47,9 @@ joinMap f lst = (concat $ intersperse ", \n" $ (fst m), snd m) where m = mapS M.empty f lst genTemplate :: String -> Template -> String -genTemplate name tpl = "render \""++name++"\" pairs = concat [\n" ++ (fst j) ++ "]" ++ nl ++ renderSubs ++ nl +genTemplate name tpl = if name=="0" + then "" + else "render \""++name++"\" pairs = concat [\n" ++ (fst j) ++ "]" ++ nl ++ renderSubs ++ nl where j = joinMap genFormat tpl renderSubs = case M.assocs $ snd j of [] -> "" @@ -57,87 +58,53 @@ genTemplate name tpl = "render \""++name++"\" pairs = concat [\n" ++ (fst j) ++ joinList lst = concat $ intersperse ",\n" $ map (" "++) $ map quote lst quoteLines s = joinList $ map (replace "\"" "\\\"") $ lines s -undollars lst = concat $ intersperse " $ " lst +undollars = unwords -genquote fm xs = if null fs - then getvar x - else (undollars fs)++" `"++fm++t++"` (M.lookup "++(quote x)++" pairs)" - where - fs = init $ init xs - x = last $ init xs - t = last xs +genquote xs = + if null fs + then getvar x + else "("++(undollars fs)++") `tmap` (M.lookup "++(quote x)++" pairs)" + where + fs = init xs + x = last xs + +genquoteB xs = + if null fs + then "isTrue `bmap` (M.lookup "++(quote x)++" pairs)" + else "("++(undollars fs)++") `bmap` (M.lookup "++(quote x)++" pairs)" + where + fs = init xs + x = last xs genFormat m (Verbatim s) = (quoteLines s, m) -genFormat m (Quote v) = (" "++genquote "fmap" v, m) -genFormat m (ForTag [v,lst,t] tpl) = (" mapF "++(quote v)++" (render \""++ h ++"\") pairs $ "++(getlist t lst), M.insert h tpl m) +genFormat m (Quote v) = (" "++genquote v, m) +genFormat m (ForTag [v,lst] tpl) = (" mapF "++(quote v)++" (render \""++ h ++"\") pairs $ "++(getlist lst), M.insert h tpl m) where h = hash' tpl -genFormat m (IfTag v tpl1 tpl2) = (" render (if "++(genquote "bmap" v')++" then "++(quote h1)++" else "++(quote h2)++") pairs", +genFormat m (IfTag v tpl1 tpl2) = (" render (if "++(genquoteB v)++" then "++(quote h1)++" else "++(quote h2)++") pairs", M.insert h1 tpl1 $ M.insert h2 tpl2 m) where h1 = hash' tpl1 h2 = hash' tpl2 - v' = (init v)++[init (tail (last v))] genFormat m (Include s) = (" render "++(quote s)++" pairs", m) genFormat m (IncludeVar v) = (" render ("++(getvar v)++") pairs", m) -contTypes = ["Int"]++models -genContainer = "data TContainer = TString !String | TStringList ![String] | "++(concat $ intersperse " | " (map genCons contTypes)) - where genCons tp = "T"++tp++" !"++tp++" | T"++tp++"List !["++tp++"]" - -tmap tp = unlines [ - "tmap"++tp++" :: Stringable b => ("++tp++" -> b) -> TContainer -> String", - "tmap"++tp++" f (T"++tp++" x) = showT (f x)", - "tmap"++tp++"List :: Stringable b => ("++tp++" -> b) -> TContainer -> String", - "tmap"++tp++"List f (T"++tp++"List x) = concat $ intersperse \", \" (map (showT.f) x)", - - "tmapb"++tp++" :: ("++tp++" -> Bool) -> TContainer -> Bool", - "tmapb"++tp++" f (T"++tp++" x) = f x", - "tmapb"++tp++"List :: ("++tp++" -> Bool) -> TContainer -> Bool", - "tmapb"++tp++"List f (T"++tp++"List x) = all f x", - - "fmap"++tp++" :: Stringable b => ("++tp++" -> b) -> Maybe TContainer -> String", - "fmap"++tp++" f x = maybe \"\" id ((tmap"++tp++" f) `fmap` x)", - "fmap"++tp++"List :: Stringable b => ("++tp++" -> b) -> Maybe TContainer -> String", - "fmap"++tp++"List f x = maybe \"\" id ((tmap"++tp++"List f) `fmap` x)", - - "bmap"++tp++" :: ("++tp++" -> Bool) -> Maybe TContainer -> Bool", - "bmap"++tp++" f x = maybe False id ((tmapb"++tp++" f) `fmap` x)", - "bmap"++tp++"List :: ("++tp++" -> Bool) -> Maybe TContainer -> Bool", - "bmap"++tp++"List f x = maybe False id ((tmapb"++tp++"List f) `fmap` x)"] - -genShowT tp = unlines [ - " showT (T"++tp++" x) = showT x", - " showT (T"++tp++"List x) = concat $ intersperse \", \" (map showT x)"] - -genMapF tp = "mapF k f s (T"++tp++"List lst) = concat $ map f $ [M.insert \"it\" (TInt it) $ M.insert k (T"++tp++" v) s | (it,v) <- zip [1..] lst]" - -typesI h = do - hPutStrLn h "module TypesI where" - hPutStrLn h "import Models" - hPutStrLn h "import Types" - hPutStrLn h "import Data.List" - hPutStrLn h "import qualified Data.Map as M" - hPutStrLn h genContainer - hPutStrLn h "instance Stringable TContainer where" - hPutStrLn h " showT (TString s) = s" - hPutStrLn h " showT (TStringList l) = concat $ intersperse \", \" (map showT l)" - hPutStrLn h (unlines $ map genShowT contTypes) - hPutStrLn h (tmap "String") - hPutStrLn h (unlines $ map tmap contTypes) - hPutStrLn h "mapF :: String -> (M.Map String TContainer -> String) -> M.Map String TContainer -> TContainer -> String" - hPutStrLn h (unlines $ map genMapF contTypes) - preamble h = do - hPutStrLn h "{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, OverlappingInstances #-}" +-- hPutStrLn h "{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, OverlappingInstances #-}" hPutStrLn h "module Templates where" hPutStrLn h "import qualified Data.Map as M" hPutStrLn h "import Data.List" hPutStrLn h "import Types" - hPutStrLn h "import TypesI" hPutStrLn h "import Models" hPutStrLn h "import Utils" + hPutStrLn h "import TemplateFuncs" hPutStrLn h "" hPutStrLn h "render :: String -> M.Map String TContainer -> String" +endrender h = do + hPutStrLn h "render \"0\" _ = \"\"" + hPutStrLn h "render _ _ = \"<h1>No such template!</h1>\"" + +------------------------------------------------------------------------------------------------------------------------------------ +-- searchTemplates dir f = do names <- getDirectoryContents dir let properNames = filter (`notElem` [".", ".."]) names @@ -152,14 +119,14 @@ workTemplate h path name = do hPutStrLn stderr $ "Parsing "++name++"..." contents <- readFile path let res = parseTemplate name contents + case res of Left e -> hPutStrLn stderr (show e) - Right tpl -> hPutStr h $ genTemplate name tpl + Right tpl -> do hPutStrLn stderr $ show res + hPutStr h $ genTemplate name tpl -main = do tps <- openFile "TypesI.hs" WriteMode - typesI tps - hClose tps - tpls <- openFile "Templates.hs" WriteMode +main = do tpls <- openFile "Templates.hs" WriteMode preamble tpls searchTemplates "templates" (workTemplate tpls) + endrender tpls hClose tpls diff --git a/TemplateParser.hs b/TemplateParser.hs index d66dd37..85935b8 100644 --- a/TemplateParser.hs +++ b/TemplateParser.hs @@ -36,11 +36,11 @@ symbol = P.symbol lexer parseTemplate = parse pTemplate pTemplate :: GenParser Char st Template -pTemplate = many1 (pVerbatim <|> pQuote <|> (try pForTag) <|> (try pIfTag) <|> (try pIncludeVar) <|> (try pInclude)) +pTemplate = many1 (pVerbatim <|> (try pForTag) <|> (try pIfTag) <|> (try pIncludeVar) <|> (try pInclude) <|> (try pQuote)) pVerbatim :: GenParser Char st Format pVerbatim = do - s <- many1 (noneOf "[]{}%") + s <- many1 (noneOf "{}%") return $ Verbatim s pQuote :: GenParser Char st Format @@ -48,50 +48,57 @@ pQuote = do string "{{" name <- many1 (noneOf "}") string "}}" - return $ Quote (words' name) + return $ Quote (words name) pForTag :: GenParser Char st Format pForTag = do - symbol "[%for" - s <- many1 (noneOf ":") - symbol ":" + symbol "{%for" + s <- many1 (noneOf "%") + symbol "%}" tpl <- pTemplate let ws = words s - if ((ws!!1)/="in") || (not (((head (ws!!3))=='(') && ((last (ws!!3))==')'))) - then fail "incorrect `for` syntax!" - else do symbol "%]" -- <?> "tag 'for' end" - return $ ForTag [(ws!!0),(ws!!2), init (tail (ws!!3))] tpl +-- if (ws!!1)/="in" +-- then fail "incorrect `for` syntax!" +-- else do symbol "{%endfor%}" -- <?> "tag 'for' end" +-- return $ ForTag [(ws!!0),(ws!!2)] tpl + symbol "{%endfor%}" -- <?> "tag 'for' end" + return $ ForTag [(ws!!0),(ws!!2)] tpl pIfTag :: GenParser Char st Format pIfTag = do - symbol "[%if" - s <- many1 (noneOf ":") - symbol ":" + s <- between (symbol "{%if") (symbol "%}") $ many1 (noneOf "%") let ws = words s - if ((length s)<2) || (not (((head (last ws))=='(') && ((last (last ws))==')'))) - then fail "incorrect `if` syntax!" - else do tpl <- pTemplate - els <- option [] pElsePart - symbol "%]" - return $ IfTag (words s) tpl els + (try (pIf1 ws)) <|> (pIf2 ws []) + +pIf1 :: [String] -> GenParser Char st Format +pIf1 ws = do + t <- between (return []) (symbol "{%else%}") pTemplate + pIf2 ws t + +pIf2 :: [String] -> Template -> GenParser Char st Format +pIf2 ws t = do + e <- between (return []) (symbol "{%endif%}") pTemplate + if null t + then return $ IfTag ws e [] + else return $ IfTag ws t e pElsePart :: GenParser Char st Template pElsePart = do - symbol "[%else%]" + symbol "{%else%}" pTemplate pInclude :: GenParser Char st Format pInclude = do - symbol "[%include" + symbol "{%include" s <- many1 (noneOf " %") - symbol "%]" + symbol "%}" return $ Include (trim s) pIncludeVar :: GenParser Char st Format pIncludeVar = do - symbol "[%includevar" + symbol "{%includevar" v <- many1 (noneOf " %") - symbol "%]" + symbol "%}" return $ IncludeVar (trim v) ----------------------------------------------------------------------------------- diff --git a/TemplateUtil.hs b/TemplateUtil.hs index 478a08c..3fa9dbe 100644 --- a/TemplateUtil.hs +++ b/TemplateUtil.hs @@ -8,7 +8,7 @@ import Network.Shed.Httpd import HTTPServer (ok) import Templates (render) -import TypesI +import Types renderToResponse :: String -> [(String,TContainer)] -> Response renderToResponse name pairs = ok $! render name (M.fromList pairs) diff --git a/Types.hs b/Types.hs index f5ce3bf..8aeade9 100644 --- a/Types.hs +++ b/Types.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, RankNTypes, ImpredicativeTypes #-} module Types where import System.IO import Network.Shed.Httpd import Data.List +import qualified Data.Map as M +import qualified Database.HDBC as D ---------------------------------------------------------------- --Types @@ -75,26 +77,97 @@ instance HttpValue HttpBox where httpEmpty (HB x) = httpEmpty x httpShow (HB x) = httpShow x -class Stringable a where - showT :: a -> String - -instance Stringable String where - showT = id - -instance Stringable Int where - showT = show - -instance Stringable Bool where - showT = show - -instance (Stringable a) => Stringable [a] where - showT l = concat $ intersperse ", " (map showT l) - -class Checkable a where +class Table t where + record :: [D.SqlValue] -> t + +class TemplateOne a where + showO :: a -> String + intField :: Int -> a -> Int + stringField :: Int -> a -> String + boolField :: Int -> a -> Bool + +class (TemplateOne a) => TemplateItem a where + showT :: a -> String + intFields :: Int -> a -> [Int] + stringFields :: Int -> a -> [String] + boolFields :: Int -> a -> [Bool] + mkList :: a -> [TContainer] isTrue :: a -> Bool -instance Checkable [a] where - isTrue = not.null - -instance Checkable Int where - isTrue = (/=0) +showC :: TContainer -> String +showC (C x) = showT x + +instance TemplateOne String where + showO = id + intField _ = read + stringField _ = id + boolField _ = not.null + +instance TemplateOne Int where + showO = show + intField _ = id + stringField _ = show + boolField _ = (/=0) + +instance TemplateOne Bool where + showO = show + intField _ x = if x then 1 else 0 + stringField _ = show + boolField _ = id + +instance (TemplateOne a) => TemplateOne [a] where + showO l = concat $ intersperse ", " (map showO l) + intField _ = length + stringField _ x = showO x + boolField _ = not.null + +instance (TemplateOne a) => TemplateItem a where + showT = showO + intFields n x = [intField n x] + stringFields n x = [stringField n x] + boolFields n x = [boolField n x] + mkList = error "undefined mkList for a" + isTrue = error "undefined isTrue for a" + +instance (TemplateOne a) => TemplateItem [a] where + showT l = concat $ intersperse ", " (map showO l) + intFields n = map (intField n) + stringFields n = map (stringField n) + boolFields n = map (boolField n) + mkList x = map C x + isTrue = not.null + +instance TemplateItem String where + showT s = s + intFields _ s = [read s] + stringFields _ s = [s] + boolFields _ s = [not $ null s] + mkList = error "undefined mkList for String" + isTrue = not.null + +data TContainer = forall a. (TemplateItem a) => C a +type SFunction = forall a. (TemplateItem a) => a -> String +type BFunction = forall a. (TemplateItem a) => a -> Bool + +mapF :: String -> (M.Map String TContainer -> String) -> M.Map String TContainer -> TContainer -> String +mapF k f s (C lst) = concat $ map f [M.insert "it" (C it) $ M.insert k v s | (it,v) <- zip ([1..]::[Int]) (mkList lst)] + +tmap' :: SFunction -> TContainer -> String +tmap' f (C x) = f x + +tmap :: SFunction -> Maybe TContainer -> String +tmap f x = maybe "" id $ (tmap' f) `fmap` x + +bmap' :: BFunction -> TContainer -> Bool +bmap' f (C x) = f x + +bmap :: BFunction -> Maybe TContainer -> Bool +bmap f x = maybe False id $ (bmap' f) `fmap` x + +transformInts n f = \x -> f `map` (intFields n x) +transformStrings n f = \x -> f `map` (stringFields n x) +transformBools n f = \x -> f `map` (boolFields n x) + +transformInt n f = \x -> f (intField n x) +transformString n f = \x -> f (stringField n x) +transformBool n f = \x -> f (boolField n x) diff --git a/Utils.hs b/Utils.hs index 9f92c12..f15654f 100644 --- a/Utils.hs +++ b/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} module Utils where import Network.Shed.Httpd @@ -48,13 +49,9 @@ month = "[0-9]{2}" day = month ------------------------------ -uppercase = map toUpper -lowercase = map toLower capitalize "" = "" capitalize (x:xs) = (toUpper x):xs commas :: [String] -> String commas lst = concat $ intersperse ", " lst - -bold s = "<strong>"++s++"</strong>" diff --git a/templates/first.html b/templates/first.html index 1303f70..e619ad9 100644 --- a/templates/first.html +++ b/templates/first.html @@ -1,25 +1,29 @@ <html> <head> - <title>{{title:String}}</title> + <title>{{title}}</title> <meta name='author' content='Portnov'> </head> <body> - <h1>{{uppercase title:String}}</h1> - [%include gohome.html%] - [%includevar include%] + <h1>{{uppercase title}}</h1> + {%include gohome.html%} + {%includevar include%} + + {%if errormsg%} + <p>Error: {{errormsg}}</p> + {%endif%} <table> - [%for user in users (User): - <tr><td>{{it:Int}}. </td><td>[%if even it (Int):+[%else%]-%]</td> - <td>{{username user:User}}</td><td>{{password user:User}}</td> + {%for user in users%} + <tr><td>{{it}}. </td><td>{%if evenP it%}+{%else%}-{%endif%}</td> + <td>{{username user}}</td><td>{{password user}}</td> </tr> - %] + {%endfor%} </table> - <p>{{bold list:StringList}}</p> + <p>{{list ";" bold list}}</p> - {{form:String}} + {{form}} </body> </html> diff --git a/templates/inctest.html b/templates/inctest.html index 2340fdf..efdf404 100644 --- a/templates/inctest.html +++ b/templates/inctest.html @@ -1,2 +1,2 @@ -<p><small>This text is included into "{{title:String}}" page</small></p> +<p><small>This text is included into "{{title}}" page</small></p> diff --git a/templates/testform.html b/templates/testform.html index 0aa92f0..11a7369 100644 --- a/templates/testform.html +++ b/templates/testform.html @@ -6,8 +6,8 @@ </head> <body> - <h1>Form: {{title:String}}</h1> - [%include gohome.html%] + <h1>Form: {{title}}</h1> + {%include gohome.html%} <form method='POST' action='/form/'> <input name='title'/> diff --git a/test.db b/test.db index 1cd068a..c9bb6bb 100644 Binary files a/test.db and b/test.db differ diff --git a/test.hs b/test.hs index 206015a..97031b6 100644 --- a/test.hs +++ b/test.hs @@ -3,14 +3,13 @@ import System.IO import Network.Shed.Httpd import Types -import TypesI import Urls import Utils import HTTPServer import TemplateUtil import Storage --- import Models -import HtmlGen +import Models +import Forms -- testing _ _ = return $ ok "Happy new year!" @@ -23,7 +22,7 @@ manyfun _ _ [y,m] = Just $ return $ ok $ "<p> Blog posts for "++y++"/"++m++": </ formfun _ rq@(Request {reqMethod}) = case reqMethod of - "GET" -> return $ renderToResponse "testform.html" [("title", TString title)] + "GET" -> return $ renderToResponse "testform.html" [("title", C (title::String))] "POST" -> do print (reqBody rq) return $ redirectG "/form/" [("title", HB testval)] where title = httpGetVar' rq "title" "Nothing" @@ -33,28 +32,28 @@ printUsers hp rq@(Request {reqMethod}) = case reqMethod of "GET" -> do conn <- connect' hp - us <- queryR' conn "SELECT * FROM users" [] + us <- queryR' conn "SELECT * FROM users" [] :: IO [User] disconnect conn - return $ renderToResponse "first.html" [("users", TUserList us), - ("title", TString "Some title"), - ("list", TStringList ["first","second","third"]), - ("include",TString "inctest.html"), - ("form", TString form)] + return $ renderToResponse "first.html" [("users", C us), + ("title", C "Some title"), + ("list", C ["first","second","third"]), + ("include",C "inctest.html"), + ("form", C form), + ("errormsg", C err)] "POST" -> do - conn <- connect' hp - case uname of - Nothing -> exit - Just uname' -> do print $ reqBody rq - query conn "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname', SqlString upass] - commit conn - disconnect conn - exit + case defValidate userForm rq of + Right user -> let uname = _username user + upass = _password user + in do conn <- connect' hp + query conn "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass] + commit conn + disconnect conn + return $ redirect url + Left e -> return $ redirectG url [("errormsg", HB ("This fields should be filled: "++e))] - where uname = httpPostVar rq "name" - upass = httpPostVar' rq "password" "" - exit = return $ redirect "/users/" - form = createform [("name", "", inputbox ""), - ("password", "", inputbox "")] "/users/" + where form = createform userForm url + url = "/users/" + err = httpGetVar' rq "errormsg" "" urlconf = "blog" // year ~/ month ~>> manyfun <|> "blog" // year ~> printyear