diff --git a/Blog/Blog b/Blog/Blog index f942038..6f01e98 100755 Binary files a/Blog/Blog and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 0d85401..46a5807 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -28,7 +28,7 @@ urlconf = "blog" // "new" --> newpost allposts :: HttpAction allposts hp rq = withConfig hp rq $ \conf -> do - (posts,pagerHtml) <- pager conf 5 (table postModel) [] postModel + (posts,pagerHtml) <- pager conf 5 (countChildren postModel "dt") [] postModel -- print posts let code = httpGetVar' rq "code" "" let message = maybe "" id $ lookup code messagecodes @@ -37,11 +37,12 @@ allposts hp rq = withConfig hp rq $ \conf -> do ("pager", C pagerHtml)] newpost :: HttpAction -newpost hp rq = withConfig hp rq $ \conf -> do - (form,err) <- retryForm conf postForm "1" [] url +newpost hp rq = withConfig hp rq $ \conf -> case reqMethod rq of - "GET" -> return $ renderToResponse "newpost.html" [("form", C form), - ("invalid", C err)] + "GET" -> + do (form,err) <- retryForm conf postForm "1" [] url + return $ renderToResponse "newpost.html" [("form", C form), + ("invalid", C err)] "POST" -> do let (d,_) = getForm allForms rq "postform" case d of @@ -54,7 +55,7 @@ newpost hp rq = withConfig hp rq $ \conf -> do where url = myUrl rq editpost :: StrAction -editpost hp rq sid = Just $ withConfig hp rq $ \conf -> do +editpost hp rq sid = Just $ withConfig hp rq $ \conf -> case reqMethod rq of "GET" -> do posts <- querySQL' conf ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel diff --git a/Blog/Makefile b/Blog/Makefile index 95f91e0..32a7f99 100644 --- a/Blog/Makefile +++ b/Blog/Makefile @@ -3,9 +3,12 @@ TEMPLATES=../Framework/TEngine/Templates.hs all: Templates Blog -Templates: +Templates: TemplateGen ../Framework/TGenerator/TemplateGen templates/ $(TEMPLATES) +TemplateGen: + make -C ../Framework/TGenerator/ + Blog: *.hs $(TEMPLATES) $(GHC) Blog.hs diff --git a/Blog/Models.hs b/Blog/Models.hs index 0bb8b82..8c1404a 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -21,8 +21,10 @@ postModel = Model { mChildren = [(commentModel,"id","pid")] } + postid = show.(transformInt 1 id) nComments = show.(transformInt 2 id) +bComments = (/=0).(transformInt 2 id) postDate = transformString 1 id title = transformString 2 id postbody = transformString 3 id diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html index f455522..1338686 100644 --- a/Blog/templates/blogposts.html +++ b/Blog/templates/blogposts.html @@ -14,6 +14,13 @@ <h2><a href='/blog/post/{{postid post}}'>{{title post}}</a></h2> <p><small>at {{postDate post}}</small></p> <p>{{postbody post}}</p> + <p><a href='/blog/post/{{postid post}}/#comments'> + {%if bComments post%} + {{nComments post}} комментариев + {%else%} + Добавить комментарий + {%endif%} + </a></p> <p><small><a href="/blog/edit/{{postid post}}">Edit</a></small></p> <hr> {%endfor%} diff --git a/Blog/templates/onepost.html b/Blog/templates/onepost.html index 88835a7..b018a39 100644 --- a/Blog/templates/onepost.html +++ b/Blog/templates/onepost.html @@ -13,7 +13,7 @@ <p>{{postbody post}}</p> {%if comments%} - <h2>Комментарии</h2> + <h2 id='comments'>Комментарии</h2> {%for comment in comments%} <p><strong>{{author comment}}</strong> пишет:</p> <p>{{commentBody comment}}</p> diff --git a/Framework/API.hs b/Framework/API.hs index 5101ec7..9238d97 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ExistentialQuantification, RankNTypes, NamedFieldPuns #-} +-- | Contains `userland` API. Wraps functions from many other modules. +-- API functions get ActionConfig parameter, which contains all data about current job. module Framework.API where import Debug.Trace @@ -18,23 +20,26 @@ import qualified Framework.SQL as SQL import Framework.Models (Model) import Framework.HTTPServer ((<+>)) +-- | Runtime controller action configuration data ActionConfig = ActionConfig { - request :: Httpd.Request, - httpParams :: HttpActionParams, - dbconnection :: Storage.DBConnection, - sessionID :: Sessions.SessionID, - sessionMap :: Sessions.SessionMap, - sessionsBackend :: Sessions.SessionsConnection, - cacheBackend :: Cache.CacheConnection, - cookiesExp :: String + request :: Httpd.Request, -- ^ HTTP request + httpParams :: HttpActionParams, -- ^ Static (global) configuration + dbconnection :: Storage.DBConnection, -- ^ DB connection + sessionID :: Sessions.SessionID, -- ^ Current HTTP session ID + sessionMap :: Sessions.SessionMap, -- ^ Contains session variables + sessionsBackend :: Sessions.SessionsConnection, -- ^ Connection to sessions backend + cacheBackend :: Cache.CacheConnection, -- ^ Connection to cache backend + cookiesExp :: String -- ^ Cookies expiration date } ---------------------------------------------------------------------------------------------------------- -- * Sessions API +-- | Get variable from session sessionLookup :: ActionConfig -> String -> IO String sessionLookup (ActionConfig {sessionMap}) name = return $ maybe "" id $ M.lookup name sessionMap +-- | Set variable into session sessionSet :: ActionConfig -> String -> String -> IO () sessionSet (ActionConfig {sessionsBackend,sessionID,sessionMap}) name value = Sessions.sPush sessionsBackend sessionID mm @@ -43,15 +48,23 @@ sessionSet (ActionConfig {sessionsBackend,sessionID,sessionMap}) name value = ---------------------------------------------------------------------------------------------------------- -- * Storage API +-- | Simple DB query. Lazy. queryList :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] queryList ac sql params = Storage.query (dbconnection ac) sql params +-- | Just as "queryList", but strict. queryList' :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] queryList' ac sql params = Storage.query' (dbconnection ac) sql params -query :: ActionConfig -> String -> [HDBC.SqlValue] -> Model -> IO [Model] +-- | DB query. Returns list of Models. +query :: ActionConfig + -> String -- ^ SQL + -> [HDBC.SqlValue] -- ^ SQL parameters + -> Model -- ^ Model of query results + -> IO [Model] query ac sql params model = Storage.queryR (dbconnection ac) sql params model +-- | Same as "query", but strict. query' :: ActionConfig -> String -> [HDBC.SqlValue] -> Model -> IO [Model] query' ac sql params model = Storage.queryR' (dbconnection ac) sql params model @@ -61,30 +74,42 @@ commit ac = Storage.commit (dbconnection ac) ---------------------------------------------------------------------------------------------------------- -- * Storage/SQL API +-- | Same as "queryList", but gets SQL.Query instead of plain SQL queryListSQL :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] queryListSQL ac q params = Storage.query (dbconnection ac) (trace (SQL.sql q) (SQL.sql q)) params +-- | Same, but strict. queryListSQL' :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]] queryListSQL' ac q params = Storage.query' (dbconnection ac) (SQL.sql q) params +-- | Same as "query", but gets SQL.Query object instead of plain SQL querySQL :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> Model -> IO [Model] querySQL ac q params model = Storage.queryR (dbconnection ac) (SQL.sql q) params model +-- | Same, but strict. 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 +-- | Get cookie value getcookie :: ActionConfig -> String -> String getcookie ac name = Cookies.getcookie (request ac) name +-- | Return HttpHeader, which sets specified cookie. setcookie :: ActionConfig -> String -> String -> HttpHeader setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value ---------------------------------------------------------------------------------------------------------- - -withConfig :: HttpActionParams -> Httpd.Request -> (ActionConfig -> IO Httpd.Response) -> IO Httpd.Response +-- +-- * Main wrapper + +-- | Main API wrapper. Connects to DB etc, then calls given function, then disconnects. +withConfig :: HttpActionParams -- ^ Static (global) server configuration + -> Httpd.Request -- ^ HTTP request + -> (ActionConfig -> IO Httpd.Response) -- ^ Worker function + -> IO Httpd.Response withConfig hp rq f = do ed <- Cookies.expirationDate conn <- Storage.connect' hp diff --git a/Framework/Forms.hs b/Framework/Forms.hs index 31c4038..02100f7 100644 --- a/Framework/Forms.hs +++ b/Framework/Forms.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} -module Framework.Forms - ( -- $doc +module Framework.Forms + ( Inputbox, Textarea, inputbox, textarea, tag, @@ -13,7 +13,7 @@ module Framework.Forms notEmpty, noValidate, defValidate, getAnyForm, getForm - ) where + ) where -- $doc import Debug.Trace diff --git a/Framework/Models.hs b/Framework/Models.hs index 0171143..ea8bec4 100644 --- a/Framework/Models.hs +++ b/Framework/Models.hs @@ -1,5 +1,14 @@ {-# LANGUAGE TypeSynonymInstances #-} -module Framework.Models where +module Framework.Models + (ColumnType (..), -- $doc + Model (..), + ModelField (..), + cModel,cParent,cChild, + (-:>), + updateField, setCached, + record, record', + fieldName, fieldType, fieldValue + ) where import Data.List import qualified Data.Convertible.Base as CD @@ -7,24 +16,30 @@ import Database.HDBC (SqlValue(..), fromSql) import Framework.Types +-- $doc +-- ADT for DB tables (data models). + +-- | Type of DB table column data ColumnType = IntegerColumn | StringColumn | BoolColumn | CurrentDateColumn deriving (Show,Eq) +-- | Default value of column type defaultValue :: ColumnType -> SqlValue defaultValue IntegerColumn = SqlInt32 0 defaultValue StringColumn = SqlString "" defaultValue BoolColumn = SqlBool False defaultValue CurrentDateColumn = SqlString "current_timestamp" +-- | DB model (table) itself data Model = Model { - mName :: String, - mTable :: String, - mFields :: [ModelField], - mCached :: [ModelField], - mChildren :: [(Model,String,String)] + mName :: String, -- ^ Model name + mTable :: String, -- ^ DB table name + mFields :: [ModelField], -- ^ List of model fields (DB table columns) + mCached :: [ModelField], -- ^ Additional fields, which are no in DB + mChildren :: [(Model,String,String)] -- ^ Children models } deriving (Show) @@ -32,10 +47,12 @@ cModel (m,_,_) = m cParent (_,f,_) = f cChild (_,_,c) = c +-- | Field for Model data ModelField = String ::: ColumnType | FilledField String ColumnType SqlValue deriving (Show) +-- | Get specific field from model model -:> fieldname = lookupField ((mFields model)++(mCached model)) fieldname lookupField [] _ = error "field name not found by lookupField!" @@ -64,8 +81,10 @@ 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) + combine [] lst = combine' (mCached m) lst + combine ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine fs xs) + combine' [] _ = [] + combine' ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine' fs xs) fieldName (n:::_) = n fieldName (FilledField n _ _) = n diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 88fbab1..6c86ff2 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -1,5 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -module Framework.Pager where + -- $doc +module Framework.Pager + (pager + ) where import Database.HDBC (SqlValue (..), fromSql) import Network.Shed.Httpd (Request) @@ -11,11 +14,23 @@ import Framework.API import Framework.Urls import Framework.Types +-- $doc +-- Functions to break query results into pages. + +-- | Represents pager HTML generator type Pager = Request -> Int -> Int -> String +-- | Simple pager pager = genericPager genpager -genericPager :: Pager -> ActionConfig -> Int -> Query -> [SqlValue] -> Model -> IO ([Model], String) +-- | Generic pager function +genericPager :: Pager -- ^ Pager HTML generator function + -> ActionConfig -- + -> Int -- ^ Number of items per page + -> Query -- ^ DB query + -> [SqlValue] -- ^ DB query parameters + -> Model -- ^ Model of result + -> IO ([Model], String) -- ^ Returns list of items on current page and HTML for pager genericPager pg conf perpage q params model = do countRes <- queryListSQL' conf (count q) params let itemCount :: Int @@ -31,6 +46,7 @@ genericPager pg conf perpage q params model = do items <- querySQL' conf (q `limit` (first,perpage)) params model return (items, pg rq pages page) +-- | Simple pager HTML generator genpager :: Pager genpager rq pages page = tag "p" ["class" =: "pager"] (firstlink++prevlink++(concat $ map onepage pagelist)++nextlink++lastlink) where diff --git a/Framework/Storage.hs b/Framework/Storage.hs index 9173be1..f280164 100644 --- a/Framework/Storage.hs +++ b/Framework/Storage.hs @@ -1,12 +1,13 @@ {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, EmptyDataDecls, TypeFamilies, NoMonomorphismRestriction, NamedFieldPuns #-} +-- | This module wraps Database.HDBC and its backends. module Framework.Storage - (DBConnection, + (DBConnection, connect, connect', commit, disconnect, query, query', queryR, queryR' ) - where + where import qualified Database.HDBC.Sqlite3 as Sqlite3 @@ -17,27 +18,39 @@ import qualified Database.HDBC as D import Framework.Types import Framework.Models +-- | Container type for any database connection data DBConnection = forall c. D.IConnection c => DBC c -connect :: String -> String -> IO DBConnection +-- | Connect to DB +connect :: String -- ^ DB backend + -> String -- ^ DB connection path (format is backend-specific) + -> IO DBConnection connect "sqlite3" file = DBC `fmap` (Sqlite3.connectSqlite3 file) connect "psql" str = DBC `fmap` (PostgreSQL.connectPostgreSQL str) +-- | Connect to DB, get parameters from "HttpActionParams" connect' :: HttpActionParams -> IO DBConnection connect' (HP {dbDriver, dbPath}) = connect dbDriver dbPath +-- | Disconnect from DB disconnect :: DBConnection -> IO () disconnect (DBC conn) = D.disconnect conn -query :: DBConnection -> String -> [D.SqlValue] -> IO [[D.SqlValue]] +-- | Generic query. Lazy. +query :: DBConnection + -> String -- ^ SQL + -> [D.SqlValue] -- ^ List of SQL parameters + -> IO [[D.SqlValue]] query (DBC conn) sql params = D.quickQuery conn sql params +-- | Generic query. Strict. query' :: DBConnection -> String -> [D.SqlValue] -> IO [[D.SqlValue]] query' (DBC conn) sql params = D.quickQuery' conn sql params commit :: DBConnection -> IO () commit (DBC conn) = D.commit conn +-- | Same as "query", but return list of Model. Lazy. queryR :: DBConnection -> String -> [D.SqlValue] @@ -47,6 +60,7 @@ queryR (DBC conn) sql params model = do res <- D.quickQuery conn sql params return (map (record' model) res) +-- | Same as "queryR", but strict. queryR' :: DBConnection -> String -> [D.SqlValue]