diff --git a/Blog/Blog b/Blog/Blog
index 6f01e98..dc91d96 100755
Binary files a/Blog/Blog and b/Blog/Blog differ
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 46a5807..dd88eeb 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -25,14 +25,16 @@ urlconf = "blog" // "new" --> newpost
<|> "blog" // "post" // number ~> onepost
<|> "blog" // "edit" // number ~> editpost
<|> "blog" --> allposts
+ <|> Function serveStatic
allposts :: HttpAction
allposts hp rq = withConfig hp rq $ \conf -> do
- (posts,pagerHtml) <- pager conf 5 (countChildren postModel "dt") [] postModel
--- print posts
+ (posts,pagerHtml) <- pager conf 5 (countChildren postModel commentModel "dt") [] postModel
+ lastComments <- querySQL' conf ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel
let code = httpGetVar' rq "code" ""
let message = maybe "" id $ lookup code messagecodes
return $ renderToResponse "blogposts.html" [("posts", C posts),
+ ("comments", C lastComments),
("message", C message),
("pager", C pagerHtml)]
diff --git a/Blog/Config.hs b/Blog/Config.hs
index be94fc0..6a33f93 100644
--- a/Blog/Config.hs
+++ b/Blog/Config.hs
@@ -3,7 +3,7 @@ module Config where
import System.IO
import Framework.Types
-params = HP { docdir = "",
+params = HP { docdir = "static",
hLog = stdout,
-- dbDriver = "sqlite3",
dbDriver = "psql",
diff --git a/Blog/Models.hs b/Blog/Models.hs
index 8c1404a..1cc2856 100644
--- a/Blog/Models.hs
+++ b/Blog/Models.hs
@@ -17,8 +17,7 @@ postModel = Model {
"dt" ::: CurrentDateColumn,
"title" ::: StringColumn,
"body" ::: StringColumn],
- mCached = ["ncomments" ::: IntegerColumn],
- mChildren = [(commentModel,"id","pid")]
+ mCached = ["ncomments" ::: IntegerColumn]
}
@@ -44,12 +43,11 @@ commentModel = Model {
mName = "comment",
mTable = "comments",
mFields = ["id" ::: IntegerColumn,
- "pid" ::: IntegerColumn,
+ "pid" ::: ForeignKey postModel "id",
"dt" ::: CurrentDateColumn,
"author" ::: StringColumn,
"body" ::: StringColumn ],
- mCached = [],
- mChildren = []
+ mCached = []
}
commentId = show.(transformInt 1 id)
diff --git a/Blog/static/blog.css b/Blog/static/blog.css
new file mode 100644
index 0000000..e90de7a
--- /dev/null
+++ b/Blog/static/blog.css
@@ -0,0 +1,6 @@
+.lastcomments {
+ width: 20em;
+ float: right;
+ border: 1px black solid;
+}
+
diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html
index 1338686..47bf8ef 100644
--- a/Blog/templates/blogposts.html
+++ b/Blog/templates/blogposts.html
@@ -3,6 +3,7 @@
<head>
<title>Blog posts</title>
<meta name='author' content='Portnov'>
+ <link rel='stylesheet' type='text/css' href='/blog.css'/>
</head>
<body>
<h1>Blog posts</h1>
@@ -10,6 +11,13 @@
<p>{{message}}</p>
{%endif%}
+ <div class='lastcomments'>
+ <h3>Последние комментарии</h3>
+ {%for comm in comments%}
+ <p>{{commentBody comm}} от <b>{{author comm}}</b></p>
+ {%endfor%}
+ </div>
+
{%for post in posts%}
<h2><a href='/blog/post/{{postid post}}'>{{title post}}</a></h2>
<p><small>at {{postDate post}}</small></p>
diff --git a/Framework/Models.hs b/Framework/Models.hs
index ea8bec4..dc5c1cb 100644
--- a/Framework/Models.hs
+++ b/Framework/Models.hs
@@ -3,8 +3,8 @@ module Framework.Models
(ColumnType (..), -- $doc
Model (..),
ModelField (..),
- cModel,cParent,cChild,
(-:>),
+ foreignModel, foreignField,
updateField, setCached,
record, record',
fieldName, fieldType, fieldValue
@@ -21,6 +21,7 @@ import Framework.Types
-- | Type of DB table column
data ColumnType = IntegerColumn
+ | ForeignKey Model String
| StringColumn
| BoolColumn
| CurrentDateColumn
@@ -29,6 +30,7 @@ data ColumnType = IntegerColumn
-- | Default value of column type
defaultValue :: ColumnType -> SqlValue
defaultValue IntegerColumn = SqlInt32 0
+defaultValue (ForeignKey _ _) = SqlInt32 0
defaultValue StringColumn = SqlString ""
defaultValue BoolColumn = SqlBool False
defaultValue CurrentDateColumn = SqlString "current_timestamp"
@@ -38,19 +40,18 @@ data Model = Model {
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
+ mCached :: [ModelField] -- ^ Additional fields, which are no in DB
+-- mChildren :: [(Model,String,String)] -- ^ Children models
}
- deriving (Show)
+ deriving (Eq,Show)
-cModel (m,_,_) = m
-cParent (_,f,_) = f
-cChild (_,_,c) = c
+foreignModel (ForeignKey m _) = m
+foreignField (ForeignKey _ f) = f
-- | Field for Model
data ModelField = String ::: ColumnType
| FilledField String ColumnType SqlValue
- deriving (Show)
+ deriving (Eq,Show)
-- | Get specific field from model
model -:> fieldname = lookupField ((mFields model)++(mCached model)) fieldname
diff --git a/Framework/SQL.hs b/Framework/SQL.hs
index 3979eb0..13989a6 100644
--- a/Framework/SQL.hs
+++ b/Framework/SQL.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ExistentialQuantification, FlexibleContexts,NoMonomorphismRestriction, TypeSynonymInstances, PatternGuards #-}
+-- | EDSL for SQL, and SQL generation from Models descriptions
module Framework.SQL
(sql,
Query,
@@ -21,36 +22,46 @@ import qualified Data.Convertible.Base as CD
import Framework.Models
+-- | List of tables: simple list or Join
data Tables = TableList [SQLTable] | TableJoin [SQLTable]
deriving (Eq,Show)
-data Query = Query {
- qFields :: [SQLField],
- qTables :: Tables,
- qWhere :: SQLCondition,
- qOrder :: [SQLOrder],
- qGroup :: [String],
- qLimits :: Maybe (Int,Int) }
- | InsertQuery {
- iTable :: String,
- iFields :: [String],
- iValues :: [String] }
- | UpdateQuery {
- uTable :: String,
- uFields :: [String],
- uValues :: [String],
- uWhere :: SQLCondition }
- deriving (Eq,Show)
-
-data SQLField = QField String
- | QFn String String
+-- | ADT for SQL Query
+data Query = Query -- SELECT query
+ {
+ qFields :: [SQLField], -- ^ Fields to select
+ qTables :: Tables, --
+ qWhere :: SQLCondition, -- ^ Conditions (WHERE part)
+ qOrder :: [SQLOrder], -- ^ ORDER BY part
+ qGroup :: [String], -- ^ GROUP BY part
+ qLimits :: Maybe (Int,Int) -- ^ OFFSET ... LIMIT part
+ }
+ | InsertQuery -- INSERT query
+ {
+ iTable :: String, -- ^ Table
+ iFields :: [String], -- ^ Fields list
+ iValues :: [String] -- ^ Values
+ }
+ | UpdateQuery -- UPDATE query
+ {
+ uTable :: String, -- ^ Table
+ uFields :: [String], -- ^ Fields
+ uValues :: [String], -- ^ Values
+ uWhere :: SQLCondition -- ^ Condition (WHERE part)
+ }
+ deriving (Eq,Show)
+
+data SQLField = QField String -- ^ Just a named field
+ | QFn String String -- ^ Some function of field, e.g. count(id)
deriving (Eq,Show)
+-- | Get name of field
fieldname (QField n) = n
fieldname (QFn _ n) = n
type SQLTable = String
+-- | ADT for SQL conditions
data SQLCondition =
NoCondition
| Selector :==: Selector
@@ -91,6 +102,7 @@ instance SQLFragment SQLOrder where
sqlFragment (Asceding o) = o++" ASC"
sqlFragment (Desceding o) = o++" DESC"
+-- | Generate SQL query from its Query description
sql :: Query -> String
sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" FROM "++tlist++other
where other = wpart++gpart++opart++lpart
@@ -114,13 +126,17 @@ commas = concat . intersperse ", "
sqlList = commas.map sqlFragment
sqlJoin = concat . (intersperse " LEFT JOIN ")
+-- | Get some aggregate function of query
aggregate q fn = q {qFields=(onlyLast (liftF fn) (qFields q))}
+-- | Apply function only to last item of list
onlyLast f lst = (init lst)++[(f $ last lst)]
+-- | Apply function to SQLField
liftF fn (QField name) = QFn fn name
liftF fn (QFn _ name) = QFn fn name
+-- | Get `count` function of query
count = flip aggregate "count"
allFields = [QField "*"]
@@ -128,29 +144,31 @@ allFields = [QField "*"]
tableR t = Query allFields (TableList [t]) NoCondition [] [] Nothing
tablesR ts = Query allFields (TableList ts) NoCondition [] [] Nothing
-object = Model {
- mName = "object",
- mTable = "objects",
- mFields = [ "id" ::: IntegerColumn,
- "dt" ::: CurrentDateColumn,
- "name" ::: StringColumn,
- "value" ::: StringColumn ],
- mCached = [],
- mChildren = [(sub,"id","pid")]
- }
-
-sub = Model {
- mName = "child",
- mTable = "children",
- mFields = [ "id" ::: IntegerColumn,
- "pid" ::: IntegerColumn,
- "body" ::: StringColumn ],
- mCached = [],
- mChildren = []
- }
-
+-- object = Model {
+-- mName = "object",
+-- mTable = "objects",
+-- mFields = [ "id" ::: IntegerColumn,
+-- "dt" ::: CurrentDateColumn,
+-- "name" ::: StringColumn,
+-- "value" ::: StringColumn ],
+-- mCached = []
+-- }
+--
+-- sub = Model {
+-- mName = "child",
+-- mTable = "children",
+-- mFields = [ "id" ::: IntegerColumn,
+-- "pid" ::: ForeignKey object "id",
+-- "body" ::: StringColumn ],
+-- mCached = []
+-- }
+
+-- | Simple query -- SELECT * FROM tablename
+table :: Model -> Query
table m = tableR (mTable m)
+-- | Generate INSERT query for given model
+insertM :: Model -> Query
insertM m = InsertQuery (mTable m) (map fieldName insfields) temps
where insfields = filter notid $ mFields m
notid s = not ("id" == (fieldName s))
@@ -158,17 +176,28 @@ insertM m = InsertQuery (mTable m) (map fieldName insfields) temps
then "current_timestamp"
else "?") insfields
+-- | Generate UPDATE query for the model
+updateM :: Model -> SQLCondition -> Query
updateM m cond = UpdateQuery (mTable m) (map fieldName updfields) temps cond
where updfields = filter normal $ mFields m
normal s = (not ("id" `isSuffixOf` (fieldName s))) && ((fieldType s)/=CurrentDateColumn)
temps = replicate (length updfields) "?"
-countChildren m ord = count $ setFields fs $ ((table m) `joinT` childTable)
+-- | Get foreign key of the model
+getForeignKey m = fkey (mFields m)
+ where fkey (f:fs) | ForeignKey _ _ <- fieldType f = f
+ | otherwise = fkey fs
+ fkey [] = error $ "No foreign key in model "++(mName m)
+
+-- | SELECT all items in table and, for each item, count it's subitems
+countChildren :: Model -> Model -> String -> Query
+countChildren m c ord = count $ setFields fs $ ((table m) `joinT` childTable)
`restrict` ((childTable++"."++childId) :==: parentField)
`sgroup` (parentField++", "++ordField) `order` (Asceding ordField)
- where childTable = mTable $ cModel $ head $ mChildren m
- parentId = cParent $ head $ mChildren m
- childId = cChild $ head $ mChildren m
+ where childTable = mTable c
+ fkey = getForeignKey c
+ parentId = foreignField $ fieldType fkey
+ childId = fieldName fkey
parentField = mTable m ++"."++ parentId
ordField = (mTable m)++"."++ord
fs = parent++child
@@ -179,28 +208,32 @@ countChildren m ord = count $ setFields fs $ ((table m) `joinT` childTable)
else QFn "max" $ (mTable m)++"."++(fieldName f)) $ mFields m
child = [QField childTable]
+setFields :: [SQLField] -> Query -> Query
setFields fs q = q { qFields = fs }
+joinT :: Query -> String -> Query
joinT q@(Query {qTables = tables}) tbl | TableList ts <- tables = q { qTables = TableJoin (ts++[tbl]) }
| TableJoin ts <- tables = q { qTables = TableJoin (ts++[tbl]) }
+-- | Select only given fields from the table/query
+select :: Query -> [String] -> Query
select q fs = q {qFields= (map QField fs)}
onlyFields = select
selectF q fs = q{qFields=fs}
+-- | Restrict query (add the WHERE part)
+restrict :: Query -> SQLCondition -> Query
restrict q@(Query {qWhere=NoCondition}) cond = q {qWhere=cond}
restrict q cond = q {qWhere = (qWhere q) :&: cond}
+-- | Sort items in query (add ORDER BY part)
+order :: Query -> SQLOrder -> Query
order q ord = q {qOrder = (qOrder q)++[ord]}
+-- | Group items in query (add GROUP BY part)
+sgroup :: Query -> String -> Query
sgroup q grp = q {qGroup = (qGroup q)++[grp]}
+-- | Limit query (add OFFSET ... LIMIT ... part)
+limit :: Query -> (Int,Int) -> Query
limit q pair = q {qLimits = Just pair}
-
--- insertQ (Query fields tables _ _ _ _) values = InsertQuery (tablename $ head tables) (map fieldname fields) values
---
--- updateQ (Query fields tables _ _ _ _) cond values = UpdateQuery (tablename $ head tables) (map fieldname fields) values cond
-
--- myquery = (table "users") `select` ["name","passwd"] `order` (Asceding "name")
-
--- main = print $ sql myquery
diff --git a/Framework/Urls.hs b/Framework/Urls.hs
index 5ab2ed9..61a88ae 100644
--- a/Framework/Urls.hs
+++ b/Framework/Urls.hs
@@ -14,11 +14,11 @@ import Framework.Utils
import Framework.Types
urlSplit :: URI -> URLParts
-urlSplit uri = splitWith (=='/') (url++slash)
+urlSplit uri = filter (/="") $ splitWith (=='/') url -- (url++slash)
where url = uriPath uri
- slash = if (last url)=='/'
- then ""
- else "/"
+-- slash = if (last url)=='/'
+-- then ""
+-- else "/"
urlJoin :: URLParts -> String
urlJoin us = concat $ intersperse "/" us
@@ -35,6 +35,7 @@ runURLConf' :: URLConf -> URLParts -> HttpActionParams -> Request -> Maybe (IO R
-- runURLConf' _ [] _ = Nothing
runURLConf' (Prefix p conf) (x:xs) ps rq | p==x = runURLConf' conf xs ps rq
| otherwise = Nothing
+runURLConf' (Prefix p conf) [] ps rq = Nothing
runURLConf' (Regexp r conf) (x:xs) ps rq = let b = x =~ r :: Bool
in if b then runURLConf' conf xs ps rq else Nothing
runURLConf' (RegexpFun r f) (x:_) ps rq = let part = x =~ r :: String
@@ -51,7 +52,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]
+runURLConf' cc xs ps rq = error $ unlines ["URLConf error",show cc,show xs,show ps,show rq]
(-->) :: String -> HttpAction -> URLConf
s --> act = Prefix s (Action act)