diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 227023d..3beec00 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -15,6 +15,7 @@ urlconf :: URLConf urlconf = "blog" // "new" --> newpost <|> "blog" // "post" // number ~> onepost <|> "blog" // "edit" // number ~> editpost + <|> "blog2" --> allposts2 <|> "blog" --> allposts <|> "login" --> login <|> "logout" --> (doLogout "/blog/") @@ -47,6 +48,13 @@ i18ntest = do text <- __ "Hello world!" return $ renderToResponse "i18ntest.html" [("text", C text)] +allposts2 = do + methodOnly GET + (posts,pagerHtml) <- pager (countChildren postModel commentModel) [] postModel + posts' <- selectRelated posts + renderToResponseM "posts2.html" [("posts", C posts'), + ("pager", C pagerHtml)] + allposts :: HttpAction allposts = do methodOnly GET diff --git a/Blog/Models.hs b/Blog/Models.hs index 943ee58..4f90846 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -25,11 +25,11 @@ postModel = emptyModel { (__ "title") ::: StringColumn `ValidateBy` notEmpty, (__ "body") ::: StringColumn `ValidateBy` notEmpty `UsingWidget` textarea], mCached = ["ncomments" ::: IntegerColumn], + related = [("pid",[commentModel])], defaultOrdering = [Desceding "dt"], perPage = Just 5 } - postid :: (TemplateOne a) => a -> String postid = show.(transformInt 1 id) nComments :: (TemplateOne a) => a -> String diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs index 9adb554..df922ae 100644 --- a/Framework/API/SQL.hs +++ b/Framework/API/SQL.hs @@ -1,13 +1,16 @@ module Framework.API.SQL where import Control.Monad.Reader.Class +import Control.Monad import qualified Database.HDBC as HDBC +import Data.Maybe import Framework.Types import Framework.Controller import qualified Framework.Storage as Storage import Framework.ORM.Types import Framework.ORM.SQL +import Framework.ORM.Models ---------------------------------------------------------------------------------------------------------- -- * Storage/SQL API @@ -35,3 +38,14 @@ querySQL' :: Query -> [HDBC.SqlValue] -> Model -> AController [Model] querySQL' q params model = do conn <- asks dbconnection liftIO $ Storage.queryR' conn (sql q) params model + +selectRelated :: [Model] -> AController [Model] +selectRelated models = do + forM models $ \m -> do + let rel = related m + rel' <- forM rel $ \(n,r) -> let r1 = head r + in querySQL' ((table r1) `restrict` (n :==: "?")) [pkey m] r1 +-- liftIO $ print rel' + return $ m {related = zip (map fst rel) rel'} + where + pkey t = t -:> (fromJust $ getPK t) diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index 3ce82d9..a045bbf 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -71,10 +71,6 @@ serveStatic' ps rq resource = httpWorker :: StaticConfig -> URLConf -> HttpRequest -> IO HttpResponse httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do req' <- requestMiddlewares hap req --- let s = unEscapeString $ rqBody req' --- putStrLn $ "Request body: "++show s --- putStrLn $ "deUTF:"++(decodeString s) --- putStrLn $ "Serving "++uriPath resp <- runURLConf hap req' (tail uriPath) conf responseMiddlewares hap resp diff --git a/Framework/ORM/Models.hs b/Framework/ORM/Models.hs index 279029a..bb38bd5 100644 --- a/Framework/ORM/Models.hs +++ b/Framework/ORM/Models.hs @@ -23,6 +23,7 @@ emptyModel = Model { mTable = "default", mFields = [], mCached = [], + related = [], defaultOrdering = [], perPage = Nothing } @@ -152,3 +153,4 @@ instance TemplateOne Model where intField n x = fieldValue' $ nthTypeField [IntegerColumn,PrimaryKey] x n stringField n x = fieldValue' $ nthTypeField [StringColumn,CurrentDateColumn] x n boolField n x = fieldValue' $ nthTypeField [BoolColumn] x n + getRelated = related diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs index 744a3af..6639d3c 100644 --- a/Framework/ORM/SQL.hs +++ b/Framework/ORM/SQL.hs @@ -8,11 +8,10 @@ module Framework.ORM.SQL limit, countChildren, insertM,updateM, --- insertQ, updateQ, aggregate, count ) where --- import Debug.Trace +import Debug.Trace import Data.List diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs index 5c393b0..fa4e5c8 100644 --- a/Framework/ORM/Types.hs +++ b/Framework/ORM/Types.hs @@ -120,6 +120,7 @@ data Model = Model { mTable :: String, -- ^ DB table name mFields :: [ModelField], -- ^ List of model fields (DB table columns) mCached :: [ModelField], -- ^ Additional fields, which are no in DB + related :: [(String,[Model])], defaultOrdering :: [SQLOrder], -- ^ How to sort list of this models by default perPage :: Maybe Int -- ^ Default paging } diff --git a/Framework/TEngine/TemplateFuncs.hs b/Framework/TEngine/TemplateFuncs.hs index a66e771..a431963 100644 --- a/Framework/TEngine/TemplateFuncs.hs +++ b/Framework/TEngine/TemplateFuncs.hs @@ -3,7 +3,8 @@ module Framework.TEngine.TemplateFuncs (bold, uppercase,lowercase, evenP,oddP, - list + list, separateWith, + children ) where import Data.Char @@ -33,3 +34,8 @@ list sep f lst = concat $ intersperse sep $ map transform (mkList lst) separateWith :: String -> SFunction 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]) diff --git a/Framework/TGenerator/TemplateGen.hs b/Framework/TGenerator/TemplateGen.hs index e532ab5..6d10fc5 100644 --- a/Framework/TGenerator/TemplateGen.hs +++ b/Framework/TGenerator/TemplateGen.hs @@ -25,7 +25,8 @@ import TemplateParser quote s = "\""++s++"\"" getvar v = "maybe \"\" showC (M.lookup "++quote v++" pairs)" -getlist n = "maybe (C ([]::[Int])) id (M.lookup "++quote n++" pairs)" +getlist [n] = "maybe (C ([]::[Int])) id (M.lookup "++quote n++" pairs)" +getlist ns = "maybe (C ([]::[Int])) ("++(unwords $ init ns)++") (M.lookup "++quote (last ns)++" pairs)" instance Hashable Format where hash (Verbatim s) = hash s @@ -82,7 +83,7 @@ genquoteB xs = genFormat m (Verbatim s) = (quoteLines s, 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) +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 "++(genquoteB v)++" then "++(quote h1)++" else "++(quote h2)++") pairs", M.insert h1 tpl1 $ M.insert h2 tpl2 m) diff --git a/Framework/TGenerator/TemplateParser.hs b/Framework/TGenerator/TemplateParser.hs index 2670e56..398e9ba 100644 --- a/Framework/TGenerator/TemplateParser.hs +++ b/Framework/TGenerator/TemplateParser.hs @@ -57,12 +57,8 @@ pForTag = do symbol "%}" tpl <- pTemplate let ws = words s --- 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 + return $ ForTag ((ws!!0):(tail $ tail ws)) tpl pIfTag :: GenParser Char st Format pIfTag = do diff --git a/Framework/Types.hs b/Framework/Types.hs index 040a280..b208b1a 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -126,6 +126,8 @@ class TemplateOne a where stringField :: Int -> a -> String -- | Get n'th boolean field boolField :: Int -> a -> Bool + getRelated :: a -> [(String,[a])] + getRelated _ = [] -- | Multiple-valued item to render in template. class (TemplateOne a) => TemplateItem a where