diff --git a/Blog/Blog.hs b/Blog/Blog.hs index bfbfeb3..b4185a7 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -41,7 +41,7 @@ testform = do case rqMethod rq of GET -> return $ renderToResponse "testform.html" [] POST -> do - liftIO $ print $ _POST rq + liftIO $ print $ postvars rq return $ redirect "/blog/" i18ntest :: HttpAction @@ -59,8 +59,8 @@ allposts2 = do allposts :: HttpAction allposts = do methodOnly GET - rq <- asks request - let key = "allposts" ++ (httpGetVar' rq "page" "1") + page <- asks (_GET' "page" "1") + let key = "allposts" ++ page tryReturnFromCache key (posts,pagerHtml) <- pager (countChildren postModel commentModel) [] postModel lastComments <- querySQL' ((table commentModel) `order` [Desceding "dt"] `limit` (0,10)) [] commentModel @@ -88,16 +88,16 @@ editpost sid = loginRequired $ do ("invalid", C err)] onepost sid = do - rq <- asks request - let url = myUrl rq - pid = read sid + url <- asks (myUrl.request) + let pid = read sid (form,err) <- create commentModel [toSql pid] url post <- getOneObject postModel pid - comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?")) [toSql pid] commentModel + (comments, pagerHtml) <- pager ((table commentModel) `restrict` ("pid" :==: "?")) [toSql pid] commentModel renderToResponseM "onepost.html" [("post", C post), ("comments", C comments), ("form", C form), - ("invalid", C err)] + ("invalid", C err), + ("pager", C pagerHtml)] main :: IO () main = serveHttp "blog.conf" urlconf diff --git a/Blog/Models.hs b/Blog/Models.hs index e583ebb..4ba0958 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -31,20 +31,20 @@ postModel = emptyModel { showMe = getfield "title" } -postid :: (TemplateOne a) => a -> String -postid = show.(transformInt 1 id) -nComments :: (TemplateOne a) => a -> String -nComments = show.(transformInt 2 id) -bComments :: (TemplateOne a) => a -> Bool -bComments = (/=0).(transformInt 2 id) -postDate :: (TemplateOne a) => a -> String -postDate = transformString 1 id -title :: (TemplateOne a) => a -> String -title = transformString 2 id -postbody :: (TemplateOne a) => a -> String -postbody = transformString 3 id -postmarkdown :: (TemplateOne a) => a -> String -postmarkdown = markdown2html . (transformString 3 id) +postid :: Maybe TContainer -> String +postid x = show ((field 1 x)::Int) +nComments :: Maybe TContainer -> String +nComments x = show ((field 2 x)::Int) +bComments :: Maybe TContainer -> Bool +bComments x = (/=0) ((field 2 x)::Int) +postDate :: Maybe TContainer -> String +postDate = field 1 +title :: Maybe TContainer -> String +title = field 2 +postbody :: Maybe TContainer -> String +postbody = field 3 +postmarkdown :: Maybe TContainer -> String +postmarkdown x = app 3 markdown2html x postForm :: Form postForm = modelForm postModel @@ -62,23 +62,23 @@ commentModel = emptyModel { "dt" ::: CurrentDateColumn, (__ "author") ::: StringColumn, (__ "body") ::: StringColumn `ValidateBy` notEmpty `UsingWidget` textarea ], - mCached = [], + perPage = Just 5, defaultOrdering = [Asceding "dt"] } commentForm :: Form commentForm = modelForm commentModel -commentId :: (TemplateOne a) => a -> String -commentId = show.(transformInt 1 id) -commendPID :: (TemplateOne a) => a -> String -commendPID = show.(transformInt 2 id) -commentDate :: (TemplateOne a) => a -> String -commentDate = transformString 1 id -author :: (TemplateOne a) => a -> String -author = transformString 2 id -commentBody :: (TemplateOne a) => a -> String -commentBody = transformString 3 id +commentId :: Maybe TContainer -> String +commentId x = show ((field 1 x)::Int) +commentPID :: Maybe TContainer -> String +commentPID x = show ((field 2 x)::Int) +commentDate :: Maybe TContainer -> String +commentDate = field 1 +author :: Maybe TContainer -> String +author = field 2 +commentBody :: Maybe TContainer -> String +commentBody = field 3 ------------------------------------------------------------------------------- diff --git a/Blog/templates/onepost.html b/Blog/templates/onepost.html index b018a39..775862a 100644 --- a/Blog/templates/onepost.html +++ b/Blog/templates/onepost.html @@ -15,12 +15,14 @@ {%if comments%} <h2 id='comments'>Комментарии</h2> {%for comment in comments%} + {%if evenP it%}<hr>{%endif%} <p><strong>{{author comment}}</strong> пишет:</p> <p>{{commentBody comment}}</p> {%endfor%} {%else%} <p>Комментариев пока нет.</p> {%endif%} + <p>{{pager}}</p> <h3>Добавить комментарий</h3> {{form}} diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs index 06911b5..e24e347 100644 --- a/Framework/API/Sessions.hs +++ b/Framework/API/Sessions.hs @@ -33,4 +33,11 @@ sessionUnset name = do let m' = M.delete name $ sessionMap ac liftIO $ sPush (sessionsBackend ac) (sessionID ac) m' put $ ac {sessionMap = m'} + +-- | Get variable and unset it +sessionTake :: String -> Controller ActionConfig r String +sessionTake name = do + v <- sessionLookup name + sessionUnset name + return v diff --git a/Framework/ContextProcessors.hs b/Framework/ContextProcessors.hs index 9a3feb7..28780d5 100644 --- a/Framework/ContextProcessors.hs +++ b/Framework/ContextProcessors.hs @@ -8,12 +8,13 @@ import Framework.Types import Framework.Utils import Framework.Controller import Framework.API.Sessions +import Framework.Http.Vars import qualified Extensions.Context as Context (contextProcessors) -- | Default set of context processors defaultProcessors :: [ContextProcessor] -defaultProcessors = [addMessage, addMyUrl] +defaultProcessors = [addMessage, addMyUrl, addHttpVars] contextProcessors :: [ContextProcessor] contextProcessors = defaultProcessors ++ Context.contextProcessors @@ -21,11 +22,15 @@ contextProcessors = defaultProcessors ++ Context.contextProcessors -- | Add `message` variable from session to context addMessage :: ContextProcessor addMessage = do - msg <- sessionLookup "message" - sessionUnset "message" + msg <- sessionTake "message" return [("message", C msg)] addMyUrl :: ContextProcessor addMyUrl = do rq <- asks request return [("myurl", C $ myUrl rq)] + +addHttpVars :: ContextProcessor +addHttpVars = do + page <- asks (_GET' "page" "1") + return [("page", C page)] diff --git a/Framework/Forms/Rendering.hs b/Framework/Forms/Rendering.hs index fa5960b..ece54df 100644 --- a/Framework/Forms/Rendering.hs +++ b/Framework/Forms/Rendering.hs @@ -34,13 +34,10 @@ renderCreateForm form fid pairs action = do -- liftIO $ print "renderCreateForm" form' <- processForm form -- liftIO $ print $ fFields form' - filled <- sessionLookup "filled" - sessionUnset "filled" + filled <- sessionTake "filled" let defvals = decodePairs filled - err <- sessionLookup "invalid" - sessionUnset "invalid" - msg <- sessionLookup "errors" - sessionUnset "errors" + err <- sessionTake "invalid" + msg <- sessionTake "errors" -- liftIO $ print err if null err then do html <- processHtmlForm $ createform form' fid pairs action @@ -57,13 +54,10 @@ renderCreateForm' :: Form -- ^ A form -> AController (String, String) -- ^ (Form HTML, error message) renderCreateForm' form fid defvals hidden action = do form' <- processForm form - filled <- sessionLookup "filled" - sessionUnset "filled" + filled <- sessionTake "filled" let filledVals = decodePairs filled - err <- sessionLookup "invalid" - sessionUnset "invalid" - msg <- sessionLookup "errors" - sessionUnset "errors" + err <- sessionTake "invalid" + msg <- sessionTake "errors" if null err then do form' <- processHtmlForm $ refillFormU [] [] form' fid hidden defvals action return (form', "") diff --git a/Framework/Http/PostParser.hs b/Framework/Http/PostParser.hs index 8393a92..85a53c4 100644 --- a/Framework/Http/PostParser.hs +++ b/Framework/Http/PostParser.hs @@ -1,5 +1,5 @@ module Framework.Http.PostParser - (_POST) + (postvars) where import Data.List @@ -26,8 +26,8 @@ multipart :: String multipart = "multipart/form-data" -- | Get map of POST variables from request -_POST :: HttpRequest -> HttpVarsMap -_POST rq = +postvars :: HttpRequest -> HttpVarsMap +postvars rq = if hdr == multipart then let bound = getBoundary ctype in M.fromList $ flattenFormData $ parse bound $ rqBody rq diff --git a/Framework/Http/Vars.hs b/Framework/Http/Vars.hs index 7f62917..745f00c 100644 --- a/Framework/Http/Vars.hs +++ b/Framework/Http/Vars.hs @@ -1,12 +1,13 @@ -- | This module contains functions to access HTTP GET and POST variables. module Framework.Http.Vars - (_GET, _POST, + (_GET, _GET', _POST, _POST', + getvars, postvars, getVar, getVar', getFile, getString, getString', httpGetVar', httpPostVar, httpPostVar', - httpAddGetVar + httpAddGetVar, urlAddGetVar ) where import Control.Arrow @@ -21,9 +22,21 @@ import Framework.Utils import Framework.Http.Httpd import Framework.Http.PostParser +_GET :: String -> ActionConfig -> String +_GET name ac = _GET' name "" ac + +_POST :: String -> ActionConfig -> String +_POST name ac = _POST' name "" ac + +_GET' :: String -> String -> ActionConfig -> String +_GET' name def ac = httpGetVar' (request ac) name def + +_POST' :: String -> String -> ActionConfig -> String +_POST' name def ac = httpPostVar' (request ac) name def + -- | Get map of GET variables from request -_GET :: HttpRequest -> HttpVarsMap -_GET rq = M.fromList $ map (second Str) $ queryToArguments $ uriQuery $ rqURI rq +getvars :: HttpRequest -> HttpVarsMap +getvars rq = M.fromList $ map (second Str) $ queryToArguments $ uriQuery $ rqURI rq varToString :: HttpVar -> String varToString (Str s) = s @@ -68,25 +81,32 @@ httpGetVar' :: HttpRequest -> String -- ^ Variable name -> String -- ^ Default value -> String -httpGetVar' rq name def = getString' (_GET rq) name def +httpGetVar' rq name def = getString' (getvars rq) name def -- | Get string POST variable directly from request httpPostVar :: HttpRequest -> String -> Maybe String -httpPostVar rq name = getString (_POST rq) name +httpPostVar rq name = getString (postvars rq) name -- | Same, but with default value httpPostVar' :: HttpRequest -> String -- ^ Variable name -> String -- ^ Default value -> String -httpPostVar' rq name def = getString' (_POST rq) name def +httpPostVar' rq name def = getString' (postvars rq) name def -- | Add GET var to given Request and return resulting URL httpAddGetVar :: HttpRequest -> String -- ^ Var name -> String -- ^ Var value -> String -httpAddGetVar rq name value = urlencode (map packParam pairs') +httpAddGetVar rq name value = urlAddGetVar (myUrl rq) name value + +-- | Add GET variable to given URL +urlAddGetVar :: String -- ^ URL + -> String -- ^ Var name + -> String -- ^ Var value + -> String -- ^ New URL +urlAddGetVar url name value = urlencode (map packParam pairs') where pairs' = addToAL pairs name value - pairs = decodePairs (uriQuery $ rqURI rq) + pairs = decodePairs url diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs index c695c14..b9d0458 100644 --- a/Framework/Modules/Auth/Controllers.hs +++ b/Framework/Modules/Auth/Controllers.hs @@ -70,8 +70,7 @@ loginPage' form target retry = do then returnNow $ redirect target else return () POST -> do - t <- sessionLookup "target" - sessionUnset "target" + t <- sessionTake "target" let target' = if null t then target else t diff --git a/Framework/Modules/Auth/Models.hs b/Framework/Modules/Auth/Models.hs index a18802e..4333260 100644 --- a/Framework/Modules/Auth/Models.hs +++ b/Framework/Modules/Auth/Models.hs @@ -16,10 +16,10 @@ defaultUserModel = emptyModel { "password" ::: StringColumn ] } -uid :: (TemplateOne a) => a -> String -uid = show.(transformInt 1 id) -username :: (TemplateOne a) => a -> String -username = transformString 1 id +uid :: Maybe TContainer -> String +uid x = show ((field 1 x)::Int) +username :: Maybe TContainer -> String +username = field 1 defaultLoginForm :: Form defaultLoginForm = Form { diff --git a/Framework/ORM/Models.hs b/Framework/ORM/Models.hs index 0edcf60..7a7c40f 100644 --- a/Framework/ORM/Models.hs +++ b/Framework/ORM/Models.hs @@ -11,6 +11,7 @@ module Framework.ORM.Models ) where import Data.List +import Data.Maybe import qualified Data.Convertible.Base as CD import Database.HDBC (SqlValue(..), fromSql) @@ -158,3 +159,4 @@ instance TemplateOne Model where stringField n x = fieldValue' $ nthTypeField [StringColumn,CurrentDateColumn] x n boolField n x = fieldValue' $ nthTypeField [BoolColumn] x n getRelated = related + getPerPage m = fromMaybe 20 $ perPage m diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 3dc3b82..4a4c96d 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -- | Functions to break query results into pages. module Framework.Pager - (pager + (pager, genpager ) where import Control.Monad.Reader.Class @@ -13,11 +13,12 @@ import Framework.ORM.Types import Framework.ORM.SQL import Framework.API.SQL import Framework.Types +import Framework.Utils import Framework.Controller import Framework.Http.Vars -- | Represents pager HTML generator -type Pager = HttpRequest -> Int -> Int -> String +type Pager = String -> Int -> Int -> String -- | Simple pager pager :: Query -- ^ Query itself @@ -48,7 +49,7 @@ genericPager pg q params model = do let first = (page-1)*perpage let pages = (itemCount `div` perpage)+1 items <- querySQL' (q `limit` (first,perpage)) params model - return (items, pg rq pages page) + return (items, pg (myUrl rq) pages page) where returnAll = do items <- querySQL' q params model @@ -56,12 +57,12 @@ genericPager pg q params model = do -- | Simple pager HTML generator genpager :: Pager -genpager rq pages page = tagToHtml $ tag "p" ["class" := "pager"] (firstlink++prevlink++(map onepage pagelist)++nextlink++lastlink) +genpager url pages page = tagToHtml $ tag "p" ["class" := "pager"] (firstlink++prevlink++(map onepage pagelist)++nextlink++lastlink) where pagelist = [1..pages] onepage n | n==page = tag "span" [] [Text $ show n] | otherwise = tag "a" ["href" := (pagelink n)] [Text $ show n] - pagelink m = httpAddGetVar rq "page" (show m) + pagelink m = urlAddGetVar url "page" (show m) prevlink | page==1 = [] | otherwise = [tag "a" ["href" := (pagelink $ page-1)] [Text "<"]] nextlink | page==pages = [] diff --git a/Framework/TEngine/TemplateFuncs.hs b/Framework/TEngine/TemplateFuncs.hs index a431963..6136b80 100644 --- a/Framework/TEngine/TemplateFuncs.hs +++ b/Framework/TEngine/TemplateFuncs.hs @@ -4,38 +4,54 @@ module Framework.TEngine.TemplateFuncs uppercase,lowercase, evenP,oddP, list, separateWith, - children + children, + pager ) where import Data.Char import Data.List import Framework.Types +import qualified Framework.Pager as Pager -bold :: (TemplateOne a) => a -> String -bold = transformString 1 $ \s -> "<strong>"++s++"</strong>" +bold :: Maybe TContainer -> String +bold = apply $ \s -> "<strong>"++s++"</strong>" -italic :: (TemplateOne a) => a -> String -italic = transformString 1 $ \s -> "<em>"++s++"</em>" +italic :: Maybe TContainer -> String +italic = apply $ \s -> "<em>"++s++"</em>" -uppercase :: (TemplateOne a) => a -> String -uppercase = transformString 1 $ map toUpper -lowercase :: (TemplateOne a) => a -> String -lowercase = transformString 1 $ map toLower +uppercase :: Maybe TContainer -> String +uppercase = apply $ map toUpper +lowercase :: Maybe TContainer -> String +lowercase = apply $ map toLower -evenP :: (TemplateOne a) => a -> Bool -evenP = transformInt 1 even -oddP :: (TemplateOne a) => a -> Bool -oddP = transformInt 1 odd +evenP :: Maybe TContainer -> Bool +evenP = apply (even::Int -> Bool) +oddP :: Maybe TContainer -> Bool +oddP = apply (odd::Int -> Bool) -list :: String -> (String -> String) -> SFunction -list sep f lst = concat $ intersperse sep $ map transform (mkList lst) +list :: String -> (String -> String) -> Maybe TContainer -> String +list sep f (Just (C lst)) = intercalate sep $ map transform (mkList lst) where transform = \(C x) -> f (stringField 1 x) +list _ _ Nothing = "" -separateWith :: String -> SFunction +separateWith :: String -> Maybe TContainer -> String separateWith s = list s id children :: String -> TContainer -> TContainer children key (C x) = case lookup key (getRelated x) of Just lst -> C lst Nothing -> C ([]::[Int]) + +pager :: TContainer -- ^ List of models + -> TContainer -- ^ URL + -> TContainer -- ^ Page number + -> String -- ^ Pager HTML +pager (C lst) (C url) (C p) = Pager.genpager url' pages p' + where + url' = stringField 1 url + p' = intField 1 p + pages = (itemCount `div` perpage)+1 + itemCount = length $ mkList lst + perpage = n $ head $ mkList lst + n (C first) = getPerPage first diff --git a/Framework/TGenerator/TemplateGen.hs b/Framework/TGenerator/TemplateGen.hs index 6d10fc5..80feb55 100644 --- a/Framework/TGenerator/TemplateGen.hs +++ b/Framework/TGenerator/TemplateGen.hs @@ -68,7 +68,7 @@ undollars = unwords genquote xs = if null fs then getvar x - else "("++(undollars fs)++") `tmap` (M.lookup "++(quote x)++" pairs)" + else "("++(undollars fs)++") (M.lookup "++(quote x)++" pairs)" where fs = init xs x = last xs @@ -76,7 +76,7 @@ genquote xs = genquoteB xs = if null fs then "isTrue `bmap` (M.lookup "++(quote x)++" pairs)" - else "("++(undollars fs)++") `bmap` (M.lookup "++(quote x)++" pairs)" + else "("++(undollars fs)++") (M.lookup "++(quote x)++" pairs)" where fs = init xs x = last xs diff --git a/Framework/Types.hs b/Framework/Types.hs index b208b1a..dfb462d 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, RankNTypes, ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, RankNTypes, ImpredicativeTypes, ScopedTypeVariables, MultiParamTypeClasses #-} module Framework.Types where import Control.Concurrent.Chan @@ -126,8 +126,12 @@ class TemplateOne a where stringField :: Int -> a -> String -- | Get n'th boolean field boolField :: Int -> a -> Bool + + -- | Get assoc.list of related models getRelated :: a -> [(String,[a])] getRelated _ = [] + getPerPage :: a -> Int + getPerPage _ = 20 -- | Multiple-valued item to render in template. class (TemplateOne a) => TemplateItem a where @@ -209,6 +213,77 @@ type BFunction = forall a. (TemplateItem a) => a -> Bool type Context = [(String,TContainer)] ------------------------------------------------------------------------------------------- +class Applicable f a b where + app :: Int -> f -> a -> b + +apply :: (Applicable f a b) => f -> a -> b +apply = app 1 + +instance Applicable (a -> b) a b where + app _ f x = f x + +instance Applicable (a -> b) [a] [b] where + app _ f lst = map f lst + +class FieldType a where + _field :: Int -> TContainer -> a + fzero :: a + +instance (FieldType b, Applicable f a b) => Applicable f (Maybe a) b where + app n f (Just x) = app n f x + app _ _ Nothing = fzero + +instance Applicable (Int -> a) TContainer a where + app n f (C x) = f (intField n x) + +instance Applicable (String -> a) TContainer a where + app n f (C x) = f (stringField n x) + +instance Applicable (Bool -> a) TContainer a where + app n f (C x) = f (boolField n x) + +instance Applicable (a -> b) TContainer b => Applicable (String -> a -> b) TContainer (TContainer -> b) where + app n op (C x) = \y -> app n (op (stringField n x)) y + +instance Applicable (a -> b) TContainer b => Applicable (Int -> a -> b) TContainer (TContainer -> b) where + app n op (C x) = \y -> app n (op (intField n x)) y + +instance Applicable (a -> b) TContainer b => Applicable (Bool -> a -> b) TContainer (TContainer -> b) where + app n op (C x) = \y -> app n (op (boolField n x)) y + +instance (TemplateOne a, FieldType a) => Applicable (String -> a -> b) a (TContainer -> b) where + app n op x = \y -> app n (op (_field n $ C x)) ((_field n y)::a) + +instance (TemplateOne a, FieldType a) => Applicable (Int -> a -> b) a (TContainer -> b) where + app n op x = \y -> app n (op (_field n $ C x)) ((_field n y)::a) + +instance (TemplateOne a, FieldType a) => Applicable (Bool -> a -> b) a (TContainer -> b) where + app n op x = \y -> app n (op (_field n $ C x)) ((_field n y)::a) + +idString :: String -> String +idString = id + +idInt :: Int -> Int +idInt = id + +idBool :: Bool -> Bool +idBool = id + +instance FieldType String where + _field n x = app n idString x + fzero = "" + +instance FieldType Int where + _field n x = app n idInt x + fzero = 0 + +instance FieldType Bool where + _field n x = app n idBool x + fzero = False + +field :: FieldType a => Int -> Maybe TContainer -> a +field n (Just x) = _field n x +field n Nothing = fzero -- | Apply given function (render) for each item in the list (contained in TContainer). -- Used in Templates. @@ -219,12 +294,6 @@ mapF :: String -- ^ Name of list-item variable -> 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)] --- | Apply "SFunction" to content of TContainer -tmap :: SFunction -> Maybe TContainer -> String -tmap f x = maybe "" id $ tmap' `fmap` x - where tmap' :: TContainer -> String - tmap' (C y) = f y - -- | Apply "BFunction" to content of TContainer bmap :: BFunction -> Maybe TContainer -> Bool bmap f x = maybe False id $ bmap' `fmap` x