diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 3be4c8b..53334fa 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -43,14 +43,6 @@ allposts = do
("comments", C lastComments),
("pager", C pagerHtml)]
-invalidatePostsCache :: AController ()
-invalidatePostsCache = do
- [[r]] <- queryListSQL (count (table postModel)) []
- let n = fromSql r :: Int
- let pages = (n `div` 5) + 1
- forM [1..pages] $ \page -> cacheUnset ("allposts"++(show page))
- return ()
-
newpost :: HttpAction
newpost = do
rq <- asks request
@@ -63,7 +55,6 @@ newpost = do
POST -> do
insertModel allForms postModel postForm "1" []
message "Пост успешно добавлен."
- invalidatePostsCache
return $ redirect "/blog/"
editpost :: StrAction
@@ -80,7 +71,6 @@ editpost sid = do
POST ->
do updateModel allForms postModel postForm "1" sid
message "Пост отредактирован."
- invalidatePostsCache
return $ redirect "/blog/"
onepost :: StrAction
@@ -99,7 +89,6 @@ onepost sid = do
POST -> do
insertModel allForms commentModel commentForm "1" [SqlInt32 $ fromIntegral pid]
message "Комментарий добавлен."
- invalidatePostsCache
return $ redirect url
main = serveHttp "blog.conf" urlconf
diff --git a/Blog/Invalidation.hs b/Blog/Invalidation.hs
new file mode 100644
index 0000000..7770bfb
--- /dev/null
+++ b/Blog/Invalidation.hs
@@ -0,0 +1,22 @@
+module Invalidation where
+
+import Control.Monad
+import Data.Maybe
+import Database.HDBC (fromSql)
+
+import Framework.SignalTypes
+import Framework.ORM
+import Framework.API.Cache
+import Framework.API.SQL
+
+import Models
+
+invalidatePostsCache :: SignalHandler
+invalidatePostsCache _ model = do
+ [[r]] <- queryListSQL (count (table postModel)) []
+ let n = fromSql r :: Int
+ let perpage = fromMaybe 5 $ perPage postModel
+ let pages = (n `div` perpage) + 1
+ forM [1..pages] $ \page -> cacheUnset ("allposts"++(show page))
+ return ()
+
diff --git a/Blog/Settings.hs b/Blog/Settings.hs
index 158636f..d2035c9 100644
--- a/Blog/Settings.hs
+++ b/Blog/Settings.hs
@@ -2,12 +2,16 @@ module Settings where
import Network.HTTP
import Network.URI
+import qualified Data.Map as M
import Framework.Types
+import Framework.SignalTypes
import Framework.Controller
import Framework.TEngine.TemplateUtil
import Framework.Forms.Types
+import Invalidation
+
requestExcHandler :: ExcHandler
requestExcHandler rq code msg = do
returnNow $ renderToResponse (show code++".html") [("error", C msg),
@@ -24,3 +28,8 @@ simple = id
requestMiddlewares = []
responseMiddlewares = []
+
+connectSignals :: M.Map Signal [SignalHandler]
+connectSignals = M.fromList [
+ ("pre_insert", [invalidatePostsCache]),
+ ("pre_update", [invalidatePostsCache]) ]
diff --git a/Framework/API.hs b/Framework/API.hs
index f5fe7af..4f0d9de 100644
--- a/Framework/API.hs
+++ b/Framework/API.hs
@@ -14,12 +14,14 @@ module Framework.API
module Framework.Types,
module Framework.Controller,
module Framework.Exceptions,
+ module Framework.Signals,
module Framework.GetText,
-- ** API modules
module Framework.API.Cache,
module Framework.API.Sessions,
module Framework.API.Storage,
module Framework.API.SQL,
+ module Framework.API.SQLUtils,
module Framework.API.Logger,
module Framework.API.UserMessage,
-- ** Specific modules
@@ -39,6 +41,7 @@ import Framework.Types
import Framework.Controller
import Framework.Exceptions
import Framework.GetText
+import Framework.Signals
import qualified Framework.Http.Cookies as Cookies
import Framework.Http.HTTPServer (serveHttp,serveStatic)
@@ -47,6 +50,7 @@ import Framework.API.Cache
import Framework.API.Sessions
import Framework.API.Storage
import Framework.API.SQL
+import Framework.API.SQLUtils
import Framework.API.Logger
import Framework.API.UserMessage
diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs
index d4a5f4e..78e71b7 100644
--- a/Framework/API/SQL.hs
+++ b/Framework/API/SQL.hs
@@ -6,11 +6,12 @@ import qualified Data.Map as M
import Framework.Types
import Framework.Controller
-import Framework.Exceptions
+-- import Framework.Exceptions
import qualified Framework.Storage as Storage
-import Framework.ORM
-import Framework.Forms.Types
-import Framework.Forms.Validation
+import Framework.ORM.Types
+import Framework.ORM.SQL
+-- import Framework.Forms.Types
+-- import Framework.Forms.Validation
import Framework.API.Storage
@@ -40,51 +41,3 @@ querySQL' :: Query -> [HDBC.SqlValue] -> Model -> AController [Model]
querySQL' q params model = do
conn <- asks dbconnection
liftIO $ Storage.queryR' conn (sql q) params model
-
--- | Get an object from DB specified by Model and object ID.
--- Fail if count(such objects)=!1.
-getOneObject :: Model -> Int -> AController Model
-getOneObject model oid = do
- idf <- forceMaybe "Could not find primary key!" $ getPK model
- objs <- querySQL' ((table model) `restrict` (idf :==: "?")) [HDBC.SqlInt32 $ fromIntegral oid] model
- assertC $ (length objs)==1
- return $ head objs
-
-insertModel :: M.Map String Form -- ^ Map of all forms
- -> Model
- -> Form
- -> String -- ^ Form ID
- -> [HDBC.SqlValue] -- ^ Additional fields (which are not in form)
- -> AController ()
-insertModel mm model form fid params = do
- rq <- asks request
- let (d,_) = getForm mm rq (formName form)
- case d of
- Right obj ->
- do queryListSQL (insertM model) $ params ++ values
- commit
- where
- fields = map fieldName $ filter (not . isExternalField) $ mFields model
- values = map (obj -:>) fields
- Left e -> returnInvalidForm form fid e
-
-updateModel :: M.Map String Form -- ^ Map of all forms
- -> Model -- ^ Model
- -> Form
- -> String -- ^ Form ID
- -> String -- ^ Object ID
- -> AController ()
-updateModel mm model form fid oid = do
- rq <- asks request
- idf <- forceMaybe "Could not find PK!" $ getPK model
- let (d,_) = getForm mm rq (formName form)
- case d of
- Right obj ->
- do queryListSQL (updateM model (idf :==: oid)) values
- commit
- where
- fields = map fieldName $ filter (not . isExternalField) $ mFields model
- values = map (obj -:>) fields
- Left e -> returnInvalidForm form fid e
-
-
diff --git a/Framework/API/SQLUtils.hs b/Framework/API/SQLUtils.hs
new file mode 100644
index 0000000..af61f44
--- /dev/null
+++ b/Framework/API/SQLUtils.hs
@@ -0,0 +1,65 @@
+module Framework.API.SQLUtils where
+
+import Control.Monad.Reader.Class
+import qualified Database.HDBC as HDBC
+import qualified Data.Map as M
+
+import Framework.Types
+import Framework.Controller
+import Framework.Exceptions
+import Framework.Signals
+import Framework.Forms.Types
+import Framework.Forms.Validation
+import Framework.ORM
+import Framework.API.SQL
+import Framework.API.Storage
+
+-- | Get an object from DB specified by Model and object ID.
+-- Fail if count(such objects)=!1.
+getOneObject :: Model -> Int -> AController Model
+getOneObject model oid = do
+ idf <- forceMaybe "Could not find primary key!" $ getPK model
+ objs <- querySQL' ((table model) `restrict` (idf :==: "?")) [HDBC.SqlInt32 $ fromIntegral oid] model
+ assertC $ (length objs)==1
+ return $ head objs
+
+insertModel :: M.Map String Form -- ^ Map of all forms
+ -> Model
+ -> Form
+ -> String -- ^ Form ID
+ -> [HDBC.SqlValue] -- ^ Additional fields (which are not in form)
+ -> AController ()
+insertModel mm model form fid params = do
+ rq <- asks request
+ let (d,_) = getForm mm rq (formName form)
+ case d of
+ Right obj ->
+ do send "pre_insert" obj
+ queryListSQL (insertM model) $ params ++ values
+ commit
+ where
+ fields = map fieldName $ filter (not . isExternalField) $ mFields model
+ values = map (obj -:>) fields
+ Left e -> returnInvalidForm form fid e
+
+updateModel :: M.Map String Form -- ^ Map of all forms
+ -> Model -- ^ Model
+ -> Form
+ -> String -- ^ Form ID
+ -> String -- ^ Object ID
+ -> AController ()
+updateModel mm model form fid oid = do
+ rq <- asks request
+ idf <- forceMaybe "Could not find PK!" $ getPK model
+ let (d,_) = getForm mm rq (formName form)
+ case d of
+ Right obj ->
+ do send "pre_update" obj
+ queryListSQL (updateM model (idf :==: oid)) values
+ commit
+ where
+ fields = map fieldName $ filter (not . isExternalField) $ mFields model
+ values = map (obj -:>) fields
+ Left e -> returnInvalidForm form fid e
+
+
diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs
index 0ec7d08..84f295b 100644
--- a/Framework/ORM/SQL.hs
+++ b/Framework/ORM/SQL.hs
@@ -12,7 +12,7 @@ module Framework.ORM.SQL
aggregate, count
) where
--- import Debug.Trace
+import Debug.Trace
import Data.List
@@ -26,9 +26,11 @@ fieldname (QFn _ n) = n
-- sql q = let s = sql' q
-- in trace s s
+sql = sql'
+
-- | Generate SQL query from its Query description
-sql :: Query -> String
-sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" FROM "++tlist++other
+sql' :: Query -> String
+sql' (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" FROM "++tlist++other
where other = wpart++gpart++opart++lpart
tlist | TableList ts <- tables = commas ts
| TableJoin ts <- tables = sqlJoin ts
@@ -41,8 +43,8 @@ sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" F
| otherwise = " GROUP BY "++(commas group)
lpart | Just (x,y) <- ls = " OFFSET "++(show x)++" LIMIT "++(show y)
| otherwise = ""
-sql (InsertQuery table fields values) = "INSERT INTO "++table++" ("++(commas fields)++") VALUES ("++(commas values)++")"
-sql (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wpart
+sql' (InsertQuery table fields values) = "INSERT INTO "++table++" ("++(commas fields)++") VALUES ("++(commas values)++")"
+sql' (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wpart
where wpart = if whre==NoCondition then "" else " WHERE "++(sqlFragment whre)
eqs = commas $ zipWith (\n v -> n++"="++v) fields values
@@ -57,7 +59,11 @@ sqlJoin = concat . (intersperse " LEFT JOIN ")
-- | Get some aggregate function of query
aggregate :: Query -> String -> Query
-aggregate q fn = q {qFields=(onlyLast (liftF fn) (qFields q))}
+aggregate q fn = q {qFields=(onlyLast (liftF fn) (qFields q)), qOrder=[]}
+
+-- | Get some aggregate function of query
+aggregate' :: Query -> String -> Query
+aggregate' q fn = q {qFields=(onlyLast (liftF fn) (qFields q))}
-- | Apply function only to last item of list
onlyLast :: (b -> b) -> [b] -> [b]
@@ -111,7 +117,7 @@ getForeignKey m = fkey (mFields m)
-- | SELECT all items in table and, for each item, count it's subitems
countChildren :: Model -> Model -> Query
-countChildren m c = (flip aggregate "count") $ setFields fs $ ((table m) `joinT` childTable)
+countChildren m c = (flip aggregate' "count") $ setFields fs $ ((table m) `joinT` childTable)
`restrict` ((childTable++"."++childId) :==: parentField)
`sgroup` (parentField++", "++ordField)
where childTable = mTable c
diff --git a/Framework/SignalTypes.hs b/Framework/SignalTypes.hs
new file mode 100644
index 0000000..3fdcc52
--- /dev/null
+++ b/Framework/SignalTypes.hs
@@ -0,0 +1,9 @@
+module Framework.SignalTypes where
+
+import Framework.Controller
+import Framework.ORM.Types
+
+type Signal = String
+
+type SignalHandler = Signal -> Model -> AController ()
+
diff --git a/Framework/Signals.hs b/Framework/Signals.hs
new file mode 100644
index 0000000..baaf9c5
--- /dev/null
+++ b/Framework/Signals.hs
@@ -0,0 +1,25 @@
+module Framework.Signals
+ (Signal,
+ SignalHandler,
+ send
+ ) where
+
+import qualified Data.Map as M
+import Control.Monad
+
+import Framework.Controller
+import Framework.ORM.Types
+import Framework.SignalTypes
+
+import Settings (connectSignals)
+
+signals :: M.Map Signal [SignalHandler]
+signals = defaultSignals `M.union` connectSignals
+
+defaultSignals = M.fromList []
+
+send :: Signal -> Model -> AController ()
+send sig model =
+ case M.lookup sig signals of
+ Nothing -> return ()
+ Just handlers -> forM_ handlers $ \fn -> fn sig model