diff --git a/.gitignore b/.gitignore index cc8eab5..280b0bd 100644 --- a/.gitignore +++ b/.gitignore @@ -12,4 +12,4 @@ tmp/* html html/* tags - +*.hcr diff --git a/Blog/Blog b/Blog/Blog new file mode 100755 index 0000000..bd9931a Binary files /dev/null and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs new file mode 100644 index 0000000..e3219ab --- /dev/null +++ b/Blog/Blog.hs @@ -0,0 +1,86 @@ + +import System.IO +import Network.Shed.Httpd +import Database.HDBC (SqlValue(..)) + +import Framework.Types +import Framework.API +import Framework.SQL +import Framework.HTTPServer +import Framework.TEngine.TemplateUtil +import Framework.Urls +import Framework.Utils +import Framework.Forms +import Framework.Models +import Framework.Pager + +import Config +import Models + +messagecodes = [("1","Пост успешно добавлен."), + ("2","Комментарий добавлен.")] + +urlconf = "blog" // "new" --> newpost + <|> "blog" // "post" // number ~> onepost + <|> "blog" --> allposts + +allposts :: HttpAction +allposts hp rq = withConfig hp rq $ \conf -> do + (posts,pagerHtml) <- pager conf 5 (table "posts") [] postModel +-- print posts + let code = httpGetVar' rq "code" "" + let message = maybe "" id $ lookup code messagecodes + return $ renderToResponse "blogposts.html" [("posts", C posts), + ("message", C message), + ("pager", C pagerHtml)] + +newpost :: HttpAction +newpost hp rq = withConfig hp rq $ \conf -> do + (form,err) <- retryForm conf postForm "1" url + case reqMethod rq of + "GET" -> return $ renderToResponse "newpost.html" [("form", C form), + ("invalid", C err)] + "POST" -> do + let (d,_) = getForm allForms rq "postform" + case d of + Right post -> let ptitle = post -:> "title" + pbody = post -:> "body" + in do queryListSQL conf + ((table "posts") `onlyFields` ["dt","title","body"] `insertQ` ["current_timestamp","?","?"]) + [ptitle, pbody] + commit conf + return $ redirectG "/blog/" ["code" =: "1"] + Left e -> returnInvalidForm conf postForm "1" e + where url = myUrl rq + +onepost :: StrAction +onepost hp rq sid = Just $ withConfig hp rq $ \conf -> do + (form,err) <- retryForm conf commentForm "1" url + case reqMethod rq of + "GET" -> do + post <- querySQL' conf ((table "posts") `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel + comments <- querySQL' conf ((table "comments") `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 pid] commentModel + let code = httpGetVar' rq "code" "" + let message = maybe "" id $ lookup code messagecodes + return $ renderToResponse "onepost.html" [("post", C (head post)), + ("comments", C comments), + ("message", C message), + ("form", C form)] + "POST" -> do + let (d,_) = getForm allForms rq "comment" + case d of + Right comment -> + do print $ mFields comment + let cAuthor = comment -:> "author" + let cBody = comment -:> "body" + queryListSQL conf + ((table "comments") `onlyFields` ["pid","dt","author","body"] `insertQ` ["?","current_timestamp","?","?"]) + [SqlInt32 pid, cAuthor, cBody] + commit conf + return $ redirectG url ["code" =: "2"] + Left e -> returnInvalidForm conf commentForm "1" e + where url = myUrl rq + pid = read sid + + +main = serveHttp 8080 params urlconf diff --git a/Blog/Config.hs b/Blog/Config.hs new file mode 100644 index 0000000..8c8b11d --- /dev/null +++ b/Blog/Config.hs @@ -0,0 +1,15 @@ +module Config where + +import System.IO +import Framework.Types + +params = HP { docdir = "", + hLog = stdout, + dbDriver = "sqlite3", + dbPath = "blog.db", + cacheDriver = "filesystem", + cachePath = "tmp/", + sessionsDriver = "files", + sessionsPath = "tmp/sessions/" + } + diff --git a/Blog/Makefile b/Blog/Makefile new file mode 100644 index 0000000..95f91e0 --- /dev/null +++ b/Blog/Makefile @@ -0,0 +1,14 @@ +GHC=ghc --make -O2 -i. -i../ +TEMPLATES=../Framework/TEngine/Templates.hs + +all: Templates Blog + +Templates: + ../Framework/TGenerator/TemplateGen templates/ $(TEMPLATES) + +Blog: *.hs $(TEMPLATES) + $(GHC) Blog.hs + +clean: + rm *.hi *.o *.hcr + diff --git a/Blog/Models.hs b/Blog/Models.hs new file mode 100644 index 0000000..41cfe1e --- /dev/null +++ b/Blog/Models.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Models where + +import qualified Data.Map as M +import Database.HDBC (fromSql) +import Database.HDBC.ColTypes (SqlTypeId (..)) + +import Framework.Types +import Framework.Storage +import Framework.Forms +import Framework.Models + +postModel = Model { + mName = "post", + mFields = ["id" ::: IntegerColumn, + "dt" ::: CurrentDateColumn, + "title" ::: StringColumn, + "body" ::: StringColumn], + mCached = ["ncomments" ::: IntegerColumn] + } + +postid = show.(transformInt 1 id) +nComments = show.(transformInt 2 id) +postDate = transformString 1 id +title = transformString 2 id +postbody = transformString 3 id + +postForm = Form { + formName = "postform", + formModel = postModel, + fFields = [ Field "title" "" inputbox noValidate, + Field "post" "" textarea (notEmpty "post")] + } + +addNComments post n = setCached postModel "ncomments" IntegerColumn n + +------------------------------------------------------------------------------- + +commentModel = Model { + mName = "comment", + mFields = ["id" ::: IntegerColumn, + "pid" ::: IntegerColumn, + "dt" ::: CurrentDateColumn, + "author" ::: StringColumn, + "body" ::: StringColumn ], + mCached = [] + } + +commentId = show.(transformInt 1 id) +commendPID = show.(transformInt 2 id) +commentDate = transformString 1 id +author = transformString 2 id +commentBody = transformString 3 id + +commentForm = Form { + formName = "comment", + formModel = commentModel, + fFields = [ Field "author" "" inputbox noValidate, + Field "comment" "" textarea (notEmpty "comment")] + } + +------------------------------------------------------------------------------- + +formsList = [postForm, commentForm] +allForms = M.fromList [(formName form, form) | form <- formsList] diff --git a/Blog/blog.db b/Blog/blog.db new file mode 100644 index 0000000..2442823 Binary files /dev/null and b/Blog/blog.db differ diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html new file mode 100644 index 0000000..2942262 --- /dev/null +++ b/Blog/templates/blogposts.html @@ -0,0 +1,23 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>Blog posts</title> + <meta name='author' content='Portnov'> + </head> + <body> + <h1>Blog posts</h1> + {%if message%} + <p>{{message}}</p> + {%endif%} + + {%for post in posts%} + <h2><a href='/blog/post/{{postid post}}'>{{title post}}</a></h2> + <p><small>at {{postDate post}}</small></p> + <p>{{postbody post}}</p> + <hr> + {%endfor%} + + {{pager}} + + </body> +</html> diff --git a/Blog/templates/newpost.html b/Blog/templates/newpost.html new file mode 100644 index 0000000..258ae9f --- /dev/null +++ b/Blog/templates/newpost.html @@ -0,0 +1,16 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>New blog post</title> + <meta name='author' content='Portnov'> + </head> + <body> + <h1>New post</h1> + {%if invalid%} + <p>Напишите пост.</p> + {%endif%} + + {{form}} + + </body> +</html> diff --git a/Blog/templates/onepost.html b/Blog/templates/onepost.html new file mode 100644 index 0000000..88835a7 --- /dev/null +++ b/Blog/templates/onepost.html @@ -0,0 +1,29 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>{{title post}}</title> + <meta name='author' content='Portnov'> + </head> + <body> + {%if message%} + <p>{{message}}</p> + {%endif%} + <h1>{{title post}}</h1> + <p><small>at {{postDate post}}</small></p> + <p>{{postbody post}}</p> + + {%if comments%} + <h2>Комментарии</h2> + {%for comment in comments%} + <p><strong>{{author comment}}</strong> пишет:</p> + <p>{{commentBody comment}}</p> + {%endfor%} + {%else%} + <p>Комментариев пока нет.</p> + {%endif%} + + <h3>Добавить комментарий</h3> + {{form}} + + </body> +</html> diff --git a/Framework/API.hs b/Framework/API.hs index 8c64203..840ed9d 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -14,6 +14,8 @@ import qualified Framework.Sessions as Sessions import qualified Framework.Storage as Storage import qualified Framework.Urls as Urls import qualified Framework.Cache as Cache +import qualified Framework.SQL as SQL +import Framework.Models (Model) import Framework.HTTPServer ((<+>)) data ActionConfig = ActionConfig { @@ -28,7 +30,7 @@ data ActionConfig = ActionConfig { } ---------------------------------------------------------------------------------------------------------- --- Sessions API +-- * Sessions API sessionLookup :: ActionConfig -> String -> IO String sessionLookup (ActionConfig {sessionMap}) name = return $ maybe "" id $ M.lookup name sessionMap @@ -39,25 +41,40 @@ sessionSet (ActionConfig {sessionsBackend,sessionID,sessionMap}) name value = where mm = M.insert name value sessionMap ---------------------------------------------------------------------------------------------------------- --- Storage API +-- * Storage API -query :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] -query ac sql params = Storage.query (dbconnection ac) sql params +queryList :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] +queryList ac sql params = Storage.query (dbconnection ac) sql params -query' :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] -query' ac sql params = Storage.query' (dbconnection ac) sql params +queryList' :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] +queryList' ac sql params = Storage.query' (dbconnection ac) sql params -queryR :: forall t. (Table t) => ActionConfig -> String -> [HDBC.SqlValue] -> IO [t] -queryR ac sql params = Storage.queryR (dbconnection ac) sql params +query :: ActionConfig -> String -> [HDBC.SqlValue] -> Model -> IO [Model] +query ac sql params model = Storage.queryR (dbconnection ac) sql params model -queryR' :: forall t. (Table t) => ActionConfig -> String -> [HDBC.SqlValue] -> IO [t] -queryR' ac sql params = Storage.queryR' (dbconnection ac) sql params +query' :: ActionConfig -> String -> [HDBC.SqlValue] -> Model -> IO [Model] +query' ac sql params model = Storage.queryR' (dbconnection ac) sql params model commit :: ActionConfig -> IO () commit ac = Storage.commit (dbconnection ac) ---------------------------------------------------------------------------------------------------------- --- Cookies API +-- * Storage/SQL API + +queryListSQL :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] +queryListSQL ac q params = Storage.query (dbconnection ac) (SQL.sql q) params + +queryListSQL' :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] +queryListSQL' ac q params = Storage.query' (dbconnection ac) (SQL.sql q) params + +querySQL :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> Model -> IO [Model] +querySQL ac q params model = Storage.queryR (dbconnection ac) (SQL.sql q) params model + +querySQL' :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> Model -> IO [Model] +querySQL' ac q params model = Storage.queryR' (dbconnection ac) (SQL.sql q) params model + +---------------------------------------------------------------------------------------------------------- +-- * Cookies API getcookie :: ActionConfig -> String -> String getcookie ac name = Cookies.getcookie (request ac) name @@ -67,17 +84,15 @@ setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value ---------------------------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------------------------- - withConfig :: HttpActionParams -> Httpd.Request -> (ActionConfig -> IO Httpd.Response) -> IO Httpd.Response withConfig hp rq f = do ed <- Cookies.expirationDate conn <- Storage.connect' hp sb <- Sessions.initSessions (sessionsDriver hp) (sessionsPath hp) sess <- Sessions.session sb rq - let (sid,mm) = case sess of - Sessions.NewSession sid' -> (sid',M.empty) - Sessions.ExistingSession sid' mm' -> (sid',mm') + let (sid,mm,addSession) = case sess of + Sessions.NewSession sid' -> (sid', M.empty, True) + Sessions.ExistingSession sid' mm' -> (sid', mm', False) cc <- Cache.initCache (cacheDriver hp) (cachePath hp) let conf = ActionConfig { request = rq, @@ -93,5 +108,7 @@ withConfig hp rq f = do Storage.disconnect conn Cache.cFree cc Sessions.sFree sb - return $ resp <+> Sessions.sessionCookie ed sid + if addSession + then return $ resp <+> Sessions.sessionCookie ed sid + else return resp diff --git a/Framework/Cookies.hs b/Framework/Cookies.hs index 29d9ecc..d36ced8 100644 --- a/Framework/Cookies.hs +++ b/Framework/Cookies.hs @@ -16,7 +16,7 @@ setcookie :: String -> String -> String -> HttpHeader setcookie exp name value = "Set-Cookie" =: ((esc (name++"="++value))++"; expires="++exp) getcookie :: Request -> String -> String -getcookie rq name = maybe "" id $ lookup name (trace (show cc) cc) +getcookie rq name = maybe "" id $ lookup name cc where cc = allcookies rq allcookies :: Request -> [(String,String)] diff --git a/Framework/Forms.hs b/Framework/Forms.hs index 837a403..a5f49e5 100644 --- a/Framework/Forms.hs +++ b/Framework/Forms.hs @@ -14,6 +14,8 @@ module Framework.Forms getAnyForm, getForm ) where +import Debug.Trace + import qualified Data.Map as M import Data.Maybe @@ -24,7 +26,8 @@ import Framework.Types import Framework.Utils import Framework.Urls import Framework.API -import Framework.HTTPServer (redirectG, packHeader) +import Framework.Models +import Framework.HTTPServer (redirectG) -- $doc -- HTML forms generation and validation. @@ -109,16 +112,22 @@ htmlAttr :: FormVar -> String htmlAttr (name := value) | httpEmpty value = "" | otherwise = " "++name++"='"++(httpShow value)++"'" +emptyTags = ["textarea"] + tag :: String -> [FormVar] -> String -> String tag name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">" where content = if null value - then " /" + then if name `elem` emptyTags + then "></"++name + else " /" else ">"++value++"</"++name tag' :: String -> [FormVar] -> String -> String tag' name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">\n" where content = if null value - then " /" + then if name `elem` emptyTags + then "></"++name + else " /" else ">\n"++value++"</"++name data Inputbox = Inputbox { ibWidth :: HttpBox } @@ -137,7 +146,7 @@ instance Widget Textarea where html (Textarea c r) name value = tag "textarea" ["cols" =: c, "rows" =: r, "name" =: name] value wRead = id -type FormValidator a = Request -> Either [String] a +type FormValidator = Request -> Either [String] Model type FieldValidator = String -> Either String String data FormField = forall w. (Widget w) => Field { @@ -149,6 +158,7 @@ data FormField = forall w. (Widget w) => Field { data Form = Form { formName :: String, + formModel :: Model, fFields :: [FormField] } @@ -167,12 +177,13 @@ fromLeft :: Either t t1 -> t fromLeft (Left x) = x fromLeft _ = error "fromLeft applicable only to Left arguments!" -defValidate :: (Table a) => Form -> String -> FormValidator a +defValidate :: Form -> String -> FormValidator defValidate form fid rq = if all isRight maybes - then Right $ record $ map (D.toSql . fromRight) maybes + then Right $ record (formModel form) $ map D.toSql fields else Left $ map fromLeft $ filter isLeft maybes - where maybes :: [Either String String] + 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 @@ -196,7 +207,7 @@ noValidate s = Right s ---------------------------------------------------------------------------------------------------- -getAnyForm :: (Table a) => M.Map String Form -> Request -> (Either [String] a, String, String) +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) @@ -204,7 +215,7 @@ getAnyForm mm rq = case form of form = M.lookup formname mm fid = httpPostVar' rq "formid" "" -getForm :: (Table a) => M.Map String Form -> Request -> String -> (Either [String] a, String) +getForm :: M.Map String Form -> Request -> String -> (Either [String] Model, String) getForm mm rq name = if name==formname then (e,fid) else (Left [], "") diff --git a/Framework/HTTPServer.hs b/Framework/HTTPServer.hs index ef767b2..fcd983d 100644 --- a/Framework/HTTPServer.hs +++ b/Framework/HTTPServer.hs @@ -1,8 +1,10 @@ {-# LANGUAGE NamedFieldPuns #-} module Framework.HTTPServer where -import Prelude hiding (catch) -import System.IO +import Prelude hiding (catch,print,putStr,putStrLn,readFile) +import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn) +import System.IO.UTF8 +import Codec.Binary.UTF8.String import System.Directory import Control.Exception import Network.Shed.Httpd @@ -11,12 +13,7 @@ import Network.URI import Framework.Types import Framework.Urls import Framework.Utils - -repackHeader :: HttpHeader -> (String,String) -repackHeader (n := v) = (n, httpShow v) - -packHeader :: (String,String) -> HttpHeader -packHeader (n,v) = (n =: v) +import Framework.Middlewares response :: Int -> [HttpHeader] -> String -> Response response code pairs body = Response code (map repackHeader $ filter notEmptyHeader pairs) body @@ -75,9 +72,12 @@ serveStatic' (HP {docdir,hLog}) (Request {reqMethod}) resource = httpWorker :: HttpActionParams -> URLConf -> Request -> IO Response httpWorker hap conf req@(Request {reqURI = URI {uriPath}}) = do --- putStrLn $ "Request: "++show req + let s = unEscapeString $ reqBody req +-- putStrLn $ "Request body: "++show s +-- putStrLn $ "deUTF:"++(decodeString s) -- putStrLn $ "Serving "++uriPath - runURLConf hap req (tail uriPath) conf + resp <- runURLConf hap req (tail uriPath) conf + responseMiddlewares resp defaultURLConf :: URLConf defaultURLConf = Function serveStatic diff --git a/Framework/Middlewares.hs b/Framework/Middlewares.hs index a000ebf..8fbc4c2 100644 --- a/Framework/Middlewares.hs +++ b/Framework/Middlewares.hs @@ -1,6 +1,17 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} module Framework.Middlewares where -import Network.Shed.Httpd (Request,Response) +import Network.Shed.Httpd -- (Request,Response) +import Framework.Utils type RequestMiddleware = Request -> IO Request type ResponseMiddleware = Response -> IO Response + +ctype = "Content-Type" + +addEncoding enc (Response c hdrs b) = + case lookup ctype hdrs of + Nothing -> Response c ((ctype ,"text/html; charset="++enc):hdrs) b + Just s -> Response c (update ctype (s++"; charset="++enc) hdrs) b + +responseMiddlewares = return . (addEncoding "UTF-8") diff --git a/Framework/Models.hs b/Framework/Models.hs index 3acdf72..769f942 100644 --- a/Framework/Models.hs +++ b/Framework/Models.hs @@ -1,44 +1,83 @@ -{-# LANGUAGE FlexibleInstances,NoMonomorphismRestriction, ExistentialQuantification #-} +{-# LANGUAGE TypeSynonymInstances #-} module Framework.Models where -import qualified Data.Map as M -import Database.HDBC (fromSql) +import Data.List +import qualified Data.Convertible.Base as CD +import Database.HDBC (SqlValue(..), 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 ] + +data ColumnType = IntegerColumn + | StringColumn + | BoolColumn + | CurrentDateColumn + deriving (Show,Eq) + +defaultValue :: ColumnType -> SqlValue +defaultValue IntegerColumn = SqlInt32 0 +defaultValue StringColumn = SqlString "" +defaultValue BoolColumn = SqlBool False +defaultValue CurrentDateColumn = SqlString "current_timestamp" + +data Model = Model { + mName :: String, + mFields :: [ModelField], + mCached :: [ModelField] } + deriving (Show) + +data ModelField = String ::: ColumnType + | FilledField String ColumnType SqlValue + deriving (Show) + +model -:> fieldname = lookupField ((mFields model)++(mCached model)) fieldname + +lookupField [] _ = error "field name not found by lookupField!" +lookupField (f:fs) name | (fieldName f)==name = fieldValue f + | otherwise = lookupField fs name + +updateField [] name tp value = [FilledField name tp value] +updateField (f:fs) name tp value | (fieldName f)==name = (FilledField name tp value):fs + | otherwise = f:(updateField fs name tp value) + +setCached model name tp value = model { mCached = updateField (mCached model) name tp value } + +record :: Model -> [SqlValue] -> Model +record m lst = m { mFields = filledFields } + where + filledFields = combine (mFields m) lst + combine _ [] = [] + combine [] _ = [] + combine flds@((name:::tp):fs) vals@(x:xs) = + if ("id" `isSuffixOf` name) || (tp==CurrentDateColumn) + then (FilledField name tp (defaultValue tp)):(combine fs vals) + else (FilledField name tp x):(combine fs xs) + +record' :: Model -> [SqlValue] -> Model +record' m lst = m { mFields = filledFields } + where + filledFields = combine (mFields m) lst + combine _ [] = [] + combine [] _ = [] + combine ((name:::tp):fs) lst@(x:xs) = (FilledField name tp x):(combine fs xs) + +fieldName (n:::_) = n +fieldName (FilledField n _ _) = n + +fieldType (_:::tp) = tp +fieldType (FilledField _ tp _) = tp + +fieldValue (_:::tp) = defaultValue tp +fieldValue (FilledField _ _ v) = v + +fieldValue' f = fromSql $ fieldValue f + +isTypeOf tps field = (fieldType field) `elem` tps -formsList :: [Form] -formsList = [userForm] +nthTypeField tps x n = (filter (isTypeOf tps) ((mFields x)++(mCached x)))!!(n-1) -allForms :: M.Map String Form -allForms = M.fromList [(formName form, form) | form <- formsList] +instance TemplateOne Model where + showO = show + intField n x = fieldValue' $ nthTypeField [IntegerColumn] x n + stringField n x = fieldValue' $ nthTypeField [StringColumn,CurrentDateColumn] x n + boolField n x = fieldValue' $ nthTypeField [BoolColumn] x n diff --git a/Framework/Pager.hs b/Framework/Pager.hs new file mode 100644 index 0000000..88fbab1 --- /dev/null +++ b/Framework/Pager.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Framework.Pager where + +import Database.HDBC (SqlValue (..), fromSql) +import Network.Shed.Httpd (Request) + +import Framework.Forms +import Framework.Models +import Framework.SQL +import Framework.API +import Framework.Urls +import Framework.Types + +type Pager = Request -> Int -> Int -> String + +pager = genericPager genpager + +genericPager :: Pager -> ActionConfig -> Int -> Query -> [SqlValue] -> Model -> IO ([Model], String) +genericPager pg conf perpage q params model = do + countRes <- queryListSQL' conf (count q) params + let itemCount :: Int + itemCount = fromSql $ head (head countRes) + rq = request conf + if itemCount < perpage + then do items <- querySQL' conf q params model + return (items, "") + else do + let page = read $ httpGetVar' rq "page" "1" + let first = (page-1)*perpage + let pages = (itemCount `div` perpage)+1 + items <- querySQL' conf (q `limit` (first,perpage)) params model + return (items, pg rq pages page) + +genpager :: Pager +genpager rq pages page = tag "p" ["class" =: "pager"] (firstlink++prevlink++(concat $ map onepage pagelist)++nextlink++lastlink) + where + pagelist = [1..pages] + onepage n | n==page = tag "span" [] (show n) + | otherwise = tag "a" ["href" =: (pagelink n)] (show n) + pagelink m = httpAddGetVar rq "page" (show m) + prevlink | page==1 = "" + | otherwise = tag "a" ["href" =: (pagelink $ page-1)] "<" + nextlink | page==pages = "" + | otherwise = tag "a" ["href" =: (pagelink $ page+1)] ">" + firstlink | page==1 = "" + | otherwise = tag "a" ["href" =: (pagelink 1)] "<<" + lastlink | page==pages = "" + | otherwise = tag "a" ["href" =: (pagelink pages)] ">>" diff --git a/Framework/SQL.hs b/Framework/SQL.hs new file mode 100644 index 0000000..0c74683 --- /dev/null +++ b/Framework/SQL.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleContexts,NoMonomorphismRestriction, TypeSynonymInstances, PatternGuards #-} +module Framework.SQL + (sql, + Query, + Selector, + SQLOrder (..), + SQLCondition (..), + table, select, onlyFields, + sgroup, order, + restrict, + limit, + insertQ, + aggregate, count + ) where + +import Data.List +import Database.HDBC +import qualified Data.Convertible.Base as CD + +data Query = Query { + qFields :: [SQLField], + qTables :: [SQLTable], + qWhere :: SQLCondition, + qOrder :: [SQLOrder], + qGroup :: [String], + qLimits :: Maybe (Int,Int) } + | InsertQuery { + iTable :: String, + iFields :: [String], + iValues :: [String] } + deriving (Eq,Show) + +data SQLField = QField String + | QFn String String String + | AsF String String + deriving (Eq,Show) + +fieldname (QField n) = n +fieldname (QFn _ _ n) = n +fieldname (AsF _ n) = n + +data SQLTable = QTable String + | AsT String String + deriving (Eq,Show) + +tablename (QTable n) = n +tablename (AsT _ n) = n + +data SQLCondition = + NoCondition + | Selector :==: Selector + | Selector :/=: Selector + | Selector :>: Selector + | Selector :<: Selector + | SQLCondition :&: SQLCondition + | SQLCondition :|: SQLCondition + deriving (Eq,Show) + +-- TODO: support ... WHERE x.field... +type Selector = String + +data SQLOrder = Asceding String | Desceding String + deriving (Eq,Show) + +class SQLFragment s where + sqlFragment :: s -> String + +instance SQLFragment SQLCondition where + sqlFragment NoCondition = "" + sqlFragment (x :==: y) = sqlFPair "=" x y + sqlFragment (x :/=: y) = sqlFPair "!=" x y + sqlFragment (x :>: y) = sqlFPair ">" x y + sqlFragment (x :<: y) = sqlFPair "<" x y + sqlFragment (x :&: y) = "("++(sqlFPair " AND " x y)++")" + sqlFragment (x :|: y) = "("++(sqlFPair " OR " x y)++")" + +sqlFPair :: (SQLFragment f) => String -> f -> f -> String +sqlFPair op x y = (sqlFragment x)++op++(sqlFragment y) + +instance SQLFragment SQLField where + sqlFragment (QField n) = n + sqlFragment (QFn a fn f) = fn++"("++f++") AS "++a + sqlFragment (AsF a n) = n++" AS "++a + +instance SQLFragment SQLTable where + sqlFragment (QTable n) = n + sqlFragment (AsT a n) = n++" "++a + +instance SQLFragment Selector where + sqlFragment s = s + +instance SQLFragment SQLOrder where + sqlFragment (Asceding o) = o++" ASC" + sqlFragment (Desceding o) = o++" DESC" + + +sql :: Query -> String +sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" FROM "++(sqlList tables)++other + where other = wpart++opart++gpart++lpart + wpart = if whre==NoCondition then "" else " WHERE "++(sqlFragment whre) + opart = if null order then "" else " ORDER BY "++(sqlList order) + gpart = if null group then "" else " GROUP BY "++(commas group) + lpart | Just (x,y) <- ls = " LIMIT "++(show x)++", "++(show y) + | otherwise = "" +sql (InsertQuery table fields values) = "INSERT INTO "++table++" ("++(commas fields)++") VALUES ("++(commas values)++")" + +commas = concat . intersperse ", " +sqlList = commas.map sqlFragment + +aggregate q fn = q {qFields=(map (liftF fn) (qFields q))} + +liftF fn (QField name) = QFn (fname++fn) fn name + where fname | name=="*" = "all" + | otherwise = name +liftF fn (AsF a name) = QFn a fn name +liftF fn (QFn a _ name) = QFn a fn name + +count = flip aggregate "count" + +allFields = [QField "*"] + +table t = Query allFields [QTable t] NoCondition [] [] Nothing +tables ts = Query allFields (map QTable ts) NoCondition [] [] Nothing + +select q fs = q {qFields= (map QField fs)} +onlyFields = select +selectF q fs = q{qFields=fs} + +restrict q@(Query {qWhere=NoCondition}) cond = q {qWhere=cond} +restrict q cond = q {qWhere = (qWhere q) :&: cond} + +order q ord = q {qOrder = (qOrder q)++[ord]} + +sgroup q grp = q {qGroup = (qGroup q)++[grp]} + +limit q pair = q {qLimits = Just pair} + +insertQ (Query fields tables _ _ _ _) values = InsertQuery (tablename $ head tables) (map fieldname fields) values + +-- myquery = (table "users") `select` ["name","passwd"] `order` (Asceding "name") + +-- main = print $ sql myquery diff --git a/Framework/Sessions.hs b/Framework/Sessions.hs index e903b7c..15d6ff5 100644 --- a/Framework/Sessions.hs +++ b/Framework/Sessions.hs @@ -80,7 +80,7 @@ sFree (SConnection b) = sfree b session :: SessionsConnection -> Request -> IO Session session (SConnection b) rq = - if null (trace sid sid) + if null sid then do n <- getStdRandom (randomR (100,maxBound::Int)) return $ NewSession (show n) else do mm <- sfetch b sid diff --git a/Framework/Storage.hs b/Framework/Storage.hs index 7f8e89e..f2d8ed4 100644 --- a/Framework/Storage.hs +++ b/Framework/Storage.hs @@ -1,18 +1,19 @@ {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, EmptyDataDecls, TypeFamilies, NoMonomorphismRestriction, NamedFieldPuns #-} module Framework.Storage - (DBConnection, Table (..), + (DBConnection, connect, connect', commit, disconnect, - query, query', queryR, queryR', - getTable + query, query', queryR, queryR' ) where + import qualified Database.HDBC.Sqlite3 as Sqlite3 import qualified Database.HDBC as D import Framework.Types +import Framework.Models data DBConnection = forall c. D.IConnection c => DBC c @@ -34,18 +35,20 @@ query' (DBC conn) sql params = D.quickQuery' conn sql params commit :: DBConnection -> IO () commit (DBC conn) = D.commit conn -getTable :: forall t. (Table t) => DBConnection -> String -> IO [t] -getTable (DBC conn) name = do - res <- D.quickQuery conn ("SELECT * FROM "++name) [] - return (map record res :: [t]) - -queryR :: forall t. (Table t) => DBConnection -> String -> [D.SqlValue] -> IO [t] -queryR (DBC conn) sql params = do +queryR :: DBConnection + -> String + -> [D.SqlValue] + -> Model + -> IO [Model] +queryR (DBC conn) sql params model = do res <- D.quickQuery conn sql params - return (map record res :: [t]) + return (map (record' model) res) -queryR' :: forall t. (Table t) => DBConnection -> String -> [D.SqlValue] -> IO [t] -queryR' (DBC conn) sql params = do +queryR' :: DBConnection + -> String + -> [D.SqlValue] + -> Model + -> IO [Model] +queryR' (DBC conn) sql params model = do res <- D.quickQuery' conn sql params - return (map record res :: [t]) - + return (map (record' model) res) diff --git a/Framework/TGenerator/TemplateGen.hs b/Framework/TGenerator/TemplateGen.hs index ea41494..6951544 100644 --- a/Framework/TGenerator/TemplateGen.hs +++ b/Framework/TGenerator/TemplateGen.hs @@ -1,4 +1,6 @@ -import System.IO +import Prelude hiding (readFile) +import System.IO hiding (readFile,hPutStrLn,hPutStr) +import System.IO.UTF8 import System.Environment import Data.List import Data.Char @@ -91,12 +93,15 @@ genFormat m (IncludeVar v) = (" render ("++(getvar v)++") pairs", m) preamble h = do -- hPutStrLn h "{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, OverlappingInstances #-}" hPutStrLn h "module Framework.TEngine.Templates where" + hPutStrLn h "import Prelude hiding (readFile)" + hPutStrLn h "import System.IO hiding (readFile,hPutStrLn,hPutStr)" + hPutStrLn h "import System.IO.UTF8" hPutStrLn h "import qualified Data.Map as M" hPutStrLn h "import Data.List" hPutStrLn h "import Framework.Types" - hPutStrLn h "import Framework.Models" hPutStrLn h "import Framework.Utils" hPutStrLn h "import Framework.TEngine.TemplateFuncs" + hPutStrLn h "import Models" hPutStrLn h "" hPutStrLn h "render :: String -> M.Map String TContainer -> String" diff --git a/Framework/Types.hs b/Framework/Types.hs index 0fb59d6..f263bdd 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -48,6 +48,7 @@ data HttpActionParams = HP { sessionsDriver :: String, sessionsPath :: String } + deriving (Show) class HttpValue v where httpEmpty :: v -> Bool @@ -90,10 +91,11 @@ type FormVar = HttpHeader (=:) :: (HttpValue v) => String -> v -> HttpHeader name =: value = name := (HB value) -------------------------------------------------------------------------------------------- +repackHeader :: HttpHeader -> (String,String) +repackHeader (n := v) = (n, httpShow v) -class Table t where - record :: [D.SqlValue] -> t +packHeader :: (String,String) -> HttpHeader +packHeader (n,v) = (n =: v) ------------------------------------------------------------------------------------------- diff --git a/Framework/Urls.hs b/Framework/Urls.hs index 94b6de3..2c2f666 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} module Framework.Urls where +import Codec.Binary.UTF8.String import Text.Regex.PCRE import Network.URI import Network.Shed.Httpd(reqBody,Response,reqURI,Request,queryToArguments) @@ -10,7 +11,11 @@ import Framework.Utils import Framework.Types urlSplit :: URI -> URLParts -urlSplit uri = splitWith (=='/') (uriPath uri) +urlSplit uri = splitWith (=='/') (url++slash) + where url = uriPath uri + slash = if (last url)=='/' + then "" + else "/" urlJoin :: URLParts -> String urlJoin us = concat $ intersperse "/" us @@ -43,6 +48,7 @@ runURLConf' (OneOf c d) url ps rq = case runURLConf' c url ps rq of runURLConf' (After c d) (x:xs) ps rq = case runURLConf' c [x] ps rq of Nothing -> runURLConf' d xs ps rq Just act -> Just (maybe act (act>>) (runURLConf' d xs ps rq)) +runURLConf' cc xs ps rq = error $ unlines [show cc,show xs,show ps,show rq] (-->) :: String -> HttpAction -> URLConf s --> act = Prefix s (Action act) @@ -100,11 +106,18 @@ httpPostVar' :: Request -> String -> String -> String httpPostVar' rq name def = maybe def id $ lookup name pairs where pairs = decodePairs (reqBody rq) -decodePairs s = queryToArguments $ replaceplus ('?':s) +httpAddGetVar :: Request -> String -> String -> String +httpAddGetVar rq name value = urlencode (map packHeader pairs') + where pairs' = update name value pairs + pairs = decodePairs (uriQuery $ reqURI rq) + +decodePairs s = map (both decodeString) $ queryToArguments $ replaceplus s + where both f (x,y) = (f x, f y) decodePair = head.decodePairs urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs) - where escapePair (n:=v) = (esc n)++"="++(esc $ httpShow v) + +escapePair (n:=v) = (esc n)++"="++(esc $ httpShow v) esc = escapeURIString isAllowedInURI diff --git a/Framework/Utils.hs b/Framework/Utils.hs index 71c307d..765af35 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -102,3 +102,10 @@ lazySlurp fp ix len w <- peekElemOff p len loop (len-1) p (chr (fromIntegral w):acc) +------------------------------------------------------------------------------------------ + +update :: (Eq a) => a -> t -> [(a, t)] -> [(a, t)] +update k v [] = [(k,v)] +update k v ((x,y):ps) | k==x = (k,v):ps + | otherwise = (x,y):(update k v ps) + diff --git a/Framework/test.db b/Framework/test.db deleted file mode 100644 index f9e9c62..0000000 Binary files a/Framework/test.db and /dev/null differ diff --git a/Framework/www/index.html b/Framework/www/index.html deleted file mode 100644 index a3a798e..0000000 --- a/Framework/www/index.html +++ /dev/null @@ -1,12 +0,0 @@ -<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> - <head> - <title>A test</title> - <meta name='author' content='Portnov'> - </head> - - <body> - <h1>Hello world!</h1> - <p>Just a test.</p> - </body> -</html> diff --git a/Models.hs b/Models.hs new file mode 100644 index 0000000..1416572 --- /dev/null +++ b/Models.hs @@ -0,0 +1,44 @@ +{-# 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/test.db b/test.db new file mode 100644 index 0000000..0b29d55 Binary files /dev/null and b/test.db differ diff --git a/test.hs b/test.hs index 66b8835..5ff6432 100644 --- a/test.hs +++ b/test.hs @@ -1,8 +1,10 @@ {-# LANGUAGE NamedFieldPuns #-} +import Prelude hiding (print,putStr) import Debug.Trace -import System.IO +import System.IO hiding (print) +import System.IO.UTF8 import Network.Shed.Httpd import qualified Data.Map as M import Database.HDBC (SqlValue(..)) @@ -12,9 +14,9 @@ import Framework.Urls import Framework.Utils import Framework.HTTPServer import Framework.TEngine.TemplateUtil -import Framework.Models import Framework.Forms import Framework.API +import Models -- testing _ _ = return $ ok "Happy new year!" @@ -55,7 +57,9 @@ printUsers hp rq = withConfig hp rq $ \conf -> do case d of Right user -> let uname = _username user upass = _password user - in do query conf "INSERT INTO USERS (name,passwd) VALUES (?,?)" [SqlString uname, SqlString upass] + 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 diff --git a/www/index.html b/www/index.html new file mode 100644 index 0000000..a3a798e --- /dev/null +++ b/www/index.html @@ -0,0 +1,12 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>A test</title> + <meta name='author' content='Portnov'> + </head> + + <body> + <h1>Hello world!</h1> + <p>Just a test.</p> + </body> +</html>