diff --git a/Blog/Blog.hs b/Blog/Blog.hs index f4e0c07..82135c2 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -22,10 +22,6 @@ import Framework.Pager import Models -messagecodes = [("1","Пост успешно добавлен."), - ("2","Комментарий добавлен."), - ("3","Пост отредактирован.")] - urlconf = "blog" // "new" --> newpost <|> "blog" // "post" // number ~> onepost <|> "blog" // "edit" // number ~> editpost @@ -51,18 +47,11 @@ allposts = do tryReturnFromCache key (posts,pagerHtml) <- pager 5 (countChildren postModel commentModel "dt") [] postModel lastComments <- querySQL' ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel - code <- sessionLookup "code" - sessionUnset "code" - let message = fromMaybe "" $ lookup code messagecodes - let html = render "blogposts.html" $ - M.fromList [("posts", C posts), - ("comments", C lastComments), - ("message", C message), - ("pager", C pagerHtml)] - cachePut key html - return $ ok html + renderToResponseP key "blogposts.html" [("posts", C posts), + ("comments", C lastComments), + ("pager", C pagerHtml)] -invalidatePostsCache :: Controller ActionConfig () +invalidatePostsCache :: AController () invalidatePostsCache = do [[r]] <- queryListSQL (count (table postModel)) [] let n = fromSql r :: Int @@ -77,12 +66,12 @@ newpost = do case rqMethod rq of GET -> do (form,err) <- retryForm postForm "1" [] url - return $ renderToResponse "newpost.html" [("form", C form), - ("invalid", C err)] + renderToResponseM "newpost.html" [("form", C form), + ("invalid", C err)] POST -> do insertModel allForms postModel postForm "1" [] + message "Пост успешно добавлен." invalidatePostsCache - sessionSet "code" "1" return $ redirect "/blog/" editpost :: StrAction @@ -94,12 +83,12 @@ editpost sid = do GET -> do post <- getOneObject postModel pid (form,err) <- editModelForm post postForm "1" url - return $ renderToResponse "editpost.html" [("form", C form), - ("invalid", C err)] + renderToResponseM "editpost.html" [("form", C form), + ("invalid", C err)] POST -> do updateModel allForms postModel postForm "1" sid + message "Пост отредактирован." invalidatePostsCache - sessionSet "code" "3" return $ redirect "/blog/" onepost :: StrAction @@ -112,17 +101,13 @@ onepost sid = do GET -> do post <- getOneObject postModel pid comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 $ fromIntegral pid] commentModel - code <- sessionLookup "code" - sessionUnset "code" - let message = fromMaybe "" $ lookup code messagecodes - return $ renderToResponse "onepost.html" [("post", C post), - ("comments", C comments), - ("message", C message), - ("form", C form)] + renderToResponseM "onepost.html" [("post", C post), + ("comments", C comments), + ("form", C form)] POST -> do insertModel allForms commentModel commentForm "1" [SqlInt32 $ fromIntegral pid] + message "Комментарий добавлен." invalidatePostsCache - sessionSet "code" "2" return $ redirect url main = serveHttp "blog.conf" urlconf diff --git a/Framework/API.hs b/Framework/API.hs index 4721283..1b12852 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -9,6 +9,7 @@ module Framework.API module Framework.API.Storage, module Framework.API.SQL, module Framework.API.Logger, + module Framework.API.UserMessage ) where import Network.HTTP @@ -22,6 +23,7 @@ import Framework.API.Sessions import Framework.API.Storage import Framework.API.SQL import Framework.API.Logger +import Framework.API.UserMessage ---------------------------------------------------------------------------------------------------------- -- * Cookies API diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs index a2aa346..91c48a8 100644 --- a/Framework/API/Sessions.hs +++ b/Framework/API/Sessions.hs @@ -12,19 +12,19 @@ import Framework.Http.Sessions -- * Sessions API -- | Get variable from session -sessionLookup :: String -> AController String +sessionLookup :: String -> Controller ActionConfig r String sessionLookup name = do mm <- asks sessionMap return $ maybe "" id $ M.lookup name mm -- | Set variable into session -sessionSet :: String -> String -> AController () +sessionSet :: String -> String -> Controller ActionConfig r () sessionSet name value = do ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask liftC $ sPush sessionsBackend sessionID $ M.insert name value sessionMap -- | Unset value in the session -sessionUnset :: String -> AController () +sessionUnset :: String -> Controller ActionConfig r () sessionUnset name = do ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask liftC $ sPush sessionsBackend sessionID $ M.delete name sessionMap diff --git a/Framework/API/Storage.hs b/Framework/API/Storage.hs index 130cd42..61a8224 100644 --- a/Framework/API/Storage.hs +++ b/Framework/API/Storage.hs @@ -12,13 +12,13 @@ import qualified Framework.Storage as Storage -- * Storage API -- | Simple DB query. Lazy. -queryList :: String -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]] +queryList :: String -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryList sql params = do conn <- asks dbconnection liftC $ Storage.query conn sql params -- | Just as "queryList", but strict. -queryList' :: String -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]] +queryList' :: String -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryList' sql params = do conn <- asks dbconnection liftC $ Storage.query' conn sql params diff --git a/Framework/API/UserMessage.hs b/Framework/API/UserMessage.hs new file mode 100644 index 0000000..a5b284f --- /dev/null +++ b/Framework/API/UserMessage.hs @@ -0,0 +1,17 @@ +module Framework.API.UserMessage where + +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Controller +import Framework.API.Sessions + +message :: String -> AController () +message msg = sessionSet "message" msg + +ifMessage :: a -> a -> AController a +ifMessage x y = do + msg <- sessionLookup "message" + return $ if null msg + then y + else x diff --git a/Framework/Cache.hs b/Framework/Cache.hs index ff0fffc..46e1388 100644 --- a/Framework/Cache.hs +++ b/Framework/Cache.hs @@ -1,144 +1,16 @@ {-# LANGUAGE ExistentialQuantification #-} module Framework.Cache ( -- $doc - initCache, - cGet,cPut,cUnset, - cached, - cFree, cDisconnect, - Serializable (..), - CacheConnection + module Framework.Cache.Types, + module Framework.Cache.Cache, + Serializable (..) ) where -import Prelude hiding (readFile,writeFile) -import System.IO.UTF8 -import System.Directory(doesFileExist,removeFile) -import System.FilePath ((</>)) -import Control.Exception(handle,IOException) - -import Network.Memcache (Memcache) -import qualified Network.Memcache as MC -import qualified Network.Memcache.Protocol as SMC +import Framework.Cache.Types +import Framework.Cache.Cache import Network.Memcache.Serializable (Serializable(..)) -import Framework.Utils -import Framework.Pool -import Framework.CacheTypes - -- $doc -- This module manages caching of any data. Caching is implemented by several backends, -- such as Memcache and Filesystem. -data MemcacheBackend = MB SMC.Server -data FilesystemBackend = FB String -data FakeBackend = Fake - -instance CacheBackend MemcacheBackend where - cinit str = do - s <- SMC.connect host (fromIntegral $ read port) - return $ MB s - where [host,port] = splitWith (==':') str - - cget (MB s) name = MC.get s name - cput (MB s) name value = MC.set s name value - cunset (MB s) name = MC.delete s name 0 - cfree (MB s) = SMC.disconnect s - -instance CacheBackend FilesystemBackend where - cinit str = return $ FB str - - cget (FB path) name = do - b <- doesFileExist file - if b - then do s <- readFile file - return $ fromString s - else return Nothing - where file = path </> name - - cput (FB path) name value = handle hndl $ do - writeFile (path </> name) (toString value) - return True - where hndl :: IOException -> IO Bool - hndl _ = return False - - cunset (FB path) name = handle hndl $ do - removeFile (path </> name) - return True - where hndl :: IOException -> IO Bool - hndl _ = return False - - cfree _ = return () - -instance CacheBackend FakeBackend where - cinit _ = return Fake - cget _ _ = return Nothing - cput _ _ _ = return True - cunset _ _ = return True - cfree _ = return () - --- | Initialize cache -initCache' :: String -- ^ Cache backend - -> String -- ^ Path to cache (backend-specific) - -> IO CacheConnection -initCache' "memcached" s = CConnection `fmap` (cinit s :: IO MemcacheBackend) -initCache' "filesystem" s = CConnection `fmap` (cinit s :: IO FilesystemBackend) -initCache' "fake" s = CConnection `fmap` (cinit s :: IO FakeBackend) - --- | Get connection to cache backend. Backend type is given in second argument, --- i.e. : initCache pool ("memcached", "localhost:11211"). -initCache :: MPool CacheConnection -- ^ Pool of cache connections - ->(String,String) -- ^ (cache backend, cache path) - -> IO (Int,CacheConnection) -- ^ (Index in the pool, connection) -initCache mpool x = acquire mpool x (\(backend, s) -> initCache' backend s) - --- | Get data from cache (from given connection) -cGet :: (Serializable v) => CacheConnection -> String -> IO (Maybe v) -cGet (CConnection b) name = cget b name - --- | Put data to cache -cPut :: (Serializable v) => CacheConnection -> String -> v -> IO Bool -cPut (CConnection b) name value = cput b name value - --- | Unset key in cache -cUnset :: CacheConnection -> String -> IO Bool -cUnset (CConnection b) name = cunset b name - --- | Free cache backend -cFree :: MPool CacheConnection -- ^ Pool of connections - -> Int -- ^ Index in the pool - -> CacheConnection -- ^ Connection - -> IO () -cFree mpool n conn = free mpool n conn - --- | Actually disconnect from cache -cDisconnect :: CacheConnection -> IO () -cDisconnect (CConnection b) = cfree b - --- showC Nothing = "Nothing" --- showC (Just x) = s++" ("++(show $ length s)++")" --- where s = toString x - --- | cached cConnection name key function argument --- Executes given function with given argument, caching the result --- (under given function name and item key) -cached :: (Serializable k, Serializable v) => CacheConnection - -> String -- ^ Cache variable (prefix of cache key) - -> k -- ^ Key in the cache (suffix) - -> (a -> v) -- ^ Function to cache - -> a -- ^ Function's argument - -> IO v -cached (CConnection b) name k f x = - do c <- cget b key --- putStrLn $ "Server answer: "++(showC c) - case c of - Nothing -> putcache - Just y -> if null (toString y) - then putcache - else {-do print (toString y) -} - return y - where key = name ++ ":" ++ (toString k) - putcache = let y = f x - in do cput b key y --- putStrLn $ "No "++key++" in cache" - return y - - diff --git a/Framework/Cache/Cache.hs b/Framework/Cache/Cache.hs new file mode 100644 index 0000000..581a8bc --- /dev/null +++ b/Framework/Cache/Cache.hs @@ -0,0 +1,68 @@ +module Framework.Cache.Cache where + +import Network.Memcache.Serializable (Serializable(..)) + +import Framework.Types +import Framework.Pool +import Framework.Cache.Types +import Framework.Cache.Instances + +-- | Get connection to cache backend. Backend type is given in second argument, +-- i.e. : initCache pool ("memcached", "localhost:11211"). +initCache :: MPool CacheConnection -- ^ Pool of cache connections + ->(String,String) -- ^ (cache backend, cache path) + -> IO (Int,CacheConnection) -- ^ (Index in the pool, connection) +initCache mpool x = acquire mpool x (\(backend, s) -> initCache' backend s) + +-- | Get data from cache (from given connection) +cGet :: (Serializable v) => CacheConnection -> String -> IO (Maybe v) +cGet (CConnection b) name = cget b name + +-- | Put data to cache +cPut :: (Serializable v) => CacheConnection -> String -> v -> IO Bool +cPut (CConnection b) name value = cput b name value + +-- | Unset key in cache +cUnset :: CacheConnection -> String -> IO Bool +cUnset (CConnection b) name = cunset b name + +-- | Free cache backend +cFree :: MPool CacheConnection -- ^ Pool of connections + -> Int -- ^ Index in the pool + -> CacheConnection -- ^ Connection + -> IO () +cFree mpool n conn = free mpool n conn + +-- | Actually disconnect from cache +cDisconnect :: CacheConnection -> IO () +cDisconnect (CConnection b) = cfree b + +-- showC Nothing = "Nothing" +-- showC (Just x) = s++" ("++(show $ length s)++")" +-- where s = toString x + +-- | cached cConnection name key function argument +-- Executes given function with given argument, caching the result +-- (under given function name and item key) +cached :: (Serializable k, Serializable v) => CacheConnection + -> String -- ^ Cache variable (prefix of cache key) + -> k -- ^ Key in the cache (suffix) + -> (a -> v) -- ^ Function to cache + -> a -- ^ Function's argument + -> IO v +cached (CConnection b) name k f x = + do c <- cget b key +-- putStrLn $ "Server answer: "++(showC c) + case c of + Nothing -> putcache + Just y -> if null (toString y) + then putcache + else {-do print (toString y) -} + return y + where key = name ++ ":" ++ (toString k) + putcache = let y = f x + in do cput b key y +-- putStrLn $ "No "++key++" in cache" + return y + + diff --git a/Framework/Cache/Instances.hs b/Framework/Cache/Instances.hs new file mode 100644 index 0000000..c4a51b3 --- /dev/null +++ b/Framework/Cache/Instances.hs @@ -0,0 +1,70 @@ +module Framework.Cache.Instances where + +import Prelude hiding (readFile,writeFile) +import System.IO.UTF8 +import System.Directory(doesFileExist,removeFile) +import System.FilePath ((</>)) +import Control.Exception(handle,IOException) +import Network.Memcache (Memcache) +import qualified Network.Memcache as MC +import qualified Network.Memcache.Protocol as SMC +import Network.Memcache.Serializable (Serializable(..)) + +import Framework.Utils +import Framework.Cache.Types + +data MemcacheBackend = MB SMC.Server +data FilesystemBackend = FB String +data FakeBackend = Fake + +instance CacheBackend MemcacheBackend where + cinit str = do + s <- SMC.connect host (fromIntegral $ read port) + return $ MB s + where [host,port] = splitWith (==':') str + + cget (MB s) name = MC.get s name + cput (MB s) name value = MC.set s name value + cunset (MB s) name = MC.delete s name 0 + cfree (MB s) = SMC.disconnect s + +instance CacheBackend FilesystemBackend where + cinit str = return $ FB str + + cget (FB path) name = do + b <- doesFileExist file + if b + then do s <- readFile file + return $ fromString s + else return Nothing + where file = path </> name + + cput (FB path) name value = handle hndl $ do + writeFile (path </> name) (toString value) + return True + where hndl :: IOException -> IO Bool + hndl _ = return False + + cunset (FB path) name = handle hndl $ do + removeFile (path </> name) + return True + where hndl :: IOException -> IO Bool + hndl _ = return False + + cfree _ = return () + +instance CacheBackend FakeBackend where + cinit _ = return Fake + cget _ _ = return Nothing + cput _ _ _ = return True + cunset _ _ = return True + cfree _ = return () + +-- | Initialize cache +initCache' :: String -- ^ Cache backend + -> String -- ^ Path to cache (backend-specific) + -> IO CacheConnection +initCache' "memcached" s = CConnection `fmap` (cinit s :: IO MemcacheBackend) +initCache' "filesystem" s = CConnection `fmap` (cinit s :: IO FilesystemBackend) +initCache' "fake" s = CConnection `fmap` (cinit s :: IO FakeBackend) + diff --git a/Framework/Cache/Types.hs b/Framework/Cache/Types.hs new file mode 100644 index 0000000..1c703fd --- /dev/null +++ b/Framework/Cache/Types.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Framework.Cache.Types where + +import Network.Memcache.Serializable (Serializable(..)) + +class CacheBackend b where + -- | Init cache backend + cinit :: String -> IO b + -- | Get data from cache + cget :: (Serializable v) => b -> String -> IO (Maybe v) + -- | Put data to cache + cput :: (Serializable v) => b -> String -> v -> IO Bool + -- | Unset data + cunset :: b -> String -> IO Bool + -- | Free backend + cfree :: b -> IO () + +-- | Type to incapsulate connection to any cache backend. +data CacheConnection = forall b. (CacheBackend b) => CConnection b + +instance Show CacheConnection where + show _ = "<Cache connection>" + diff --git a/Framework/CacheTypes.hs b/Framework/CacheTypes.hs deleted file mode 100644 index 9ad115e..0000000 --- a/Framework/CacheTypes.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Framework.CacheTypes where - -import Network.Memcache.Serializable (Serializable(..)) - -class CacheBackend b where - -- | Init cache backend - cinit :: String -> IO b - -- | Get data from cache - cget :: (Serializable v) => b -> String -> IO (Maybe v) - -- | Put data to cache - cput :: (Serializable v) => b -> String -> v -> IO Bool - -- | Unset data - cunset :: b -> String -> IO Bool - -- | Free backend - cfree :: b -> IO () - --- | Type to incapsulate connection to any cache backend. -data CacheConnection = forall b. (CacheBackend b) => CConnection b - -instance Show CacheConnection where - show _ = "<Cache connection>" - diff --git a/Framework/ContextProcessors.hs b/Framework/ContextProcessors.hs new file mode 100644 index 0000000..d926693 --- /dev/null +++ b/Framework/ContextProcessors.hs @@ -0,0 +1,15 @@ +module Framework.ContextProcessors where + +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Controller +import Framework.API.Sessions + +defaultProcessors = [addMessage] + +addMessage :: ContextProcessor +addMessage = do + msg <- sessionLookup "message" + sessionUnset "message" + return [("message", C msg)] diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 0744098..f82f3b7 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -2,8 +2,10 @@ module Framework.Controller (Controller, AController, HttpController, StaticController, + ContextProcessor, liftC, returnNow, - internalError, rejectUrl, + concatC, changeR, + internalError, reject, assertC, errorIf, forceMaybe, evalController ) where @@ -15,29 +17,35 @@ import Framework.Http.Response -- | Controller may reject url, return a value for further processing, -- or return a value right now to avoid succeding computations -data ControllerResult a = RejectUrl -- ^ `No, I wann't process this URL!' - | RightNow HttpResponse -- ^ `Return this response and do not see what is writen below!' - | Result a -- ^ `I return this value; use it in following computations.' +data ControllerResult r a = Reject -- ^ `No, I wann't process this URL!' + | RightNow r -- ^ `Return this response and do not look what is writen below!' + | Result a -- ^ `I return this value; use it in following computations.' -- | Controller itself -newtype Controller s a = Controller { - runController :: s -> IO (ControllerResult a) +newtype Controller s r a = Controller { + runController :: s -> IO (ControllerResult r a) } -- | Type of application-level controllers -type HttpController = Controller ActionConfig HttpResponse +type HttpController = Controller ActionConfig HttpResponse HttpResponse -- | Type of application-level controllers, that use StaticConfig -type StaticController = Controller StaticConfig HttpResponse +type StaticController = Controller StaticConfig HttpResponse HttpResponse -- | Most common type of controllers -type AController a = Controller ActionConfig a +type AController a = Controller ActionConfig HttpResponse a + +------------------------------------------------------------------------------------------- + +type ContextProcessor = Controller ActionConfig Context Context + +------------------------------------------------------------------------------------------- -- | Convert any result to Maybe HttpResponse -anyResult :: ControllerResult HttpResponse -> Maybe HttpResponse -anyResult RejectUrl = Nothing +anyResult :: ControllerResult a a -> Maybe a +anyResult Reject = Nothing anyResult (RightNow r) = Just r anyResult (Result r) = Just r -instance Monad (Controller s) where +instance Monad (Controller s r) where -- return :: a -> Controller s a return v = Controller $ \_ -> return (Result v) @@ -46,38 +54,61 @@ instance Monad (Controller s) where Controller $ \s -> do -- `do` in IO res <- cmd s case res of - RejectUrl -> return RejectUrl + Reject -> return Reject RightNow resp -> return $ RightNow resp Result res' -> (runController . f) res' s -instance MonadReader s (Controller s) where +instance MonadReader s (Controller s r) where ask = Controller $ \s -> return (Result s) local f m = Controller $ runController m . f +-- | Run all controllers in list in given environment, and concatenate results +concatC :: [Controller b [a] [a]] -- ^ List of controllers + -> Controller b r [a] +concatC cs = do + s <- ask + rs <- liftC $ mapM (flip runController s) cs + return $ process rs + where + process [] = [] + process (Reject:_) = [] + process ((RightNow x):xs) = x + process ((Result x):xs) = x++process xs + +-- | Run a controller, but reject if it returns RightNow t. +changeR :: Controller s r a -> Controller s q a +changeR m = do + s <- ask + r <- liftC $ runController m s + case r of + Reject -> reject + RightNow t -> reject + Result x -> return x + -- | `Lift' an IO action into Controller -liftC :: IO a -> Controller s a +liftC :: IO a -> Controller s r a liftC act = Controller $ \_ -> Result `fmap` act -- | Assert that condition is satisfied. Otherwise, reject URL. -assertC :: Bool -> Controller s () +assertC :: Bool -> Controller s r () assertC b = if b then return () - else rejectUrl + else reject -- | Return given value and do not evaluate following computations -returnNow :: HttpResponse -> Controller s a +returnNow :: r -> Controller s r a returnNow v = Controller $ \_ -> return (RightNow v) -- | Return HTTP 500 error with given message -internalError :: String -> Controller s a +internalError :: String -> Controller s HttpResponse a internalError msg = returnNow $ response 500 [] msg -- | Return HTTP error with given code, if condition is satisfied errorIf :: Int -- ^ HTTP status code -> String -- ^ Error message -> Bool -- ^ Value of condition - -> Controller s () + -> Controller s HttpResponse () errorIf code msg b = if b then returnNow $ response code [] msg @@ -86,20 +117,20 @@ errorIf code msg b = -- | If value is supplied, return it. Otherwise, raise HTTP 500 error. forceMaybe :: String -- ^ Error message -> Maybe a -- ^ Maybe value - -> Controller s a -- + -> Controller s HttpResponse a -- forceMaybe msg x = case x of Just v -> return v Nothing -> internalError msg -- | Reject this URL -rejectUrl :: Controller s a -rejectUrl = Controller $ \_ -> return RejectUrl +reject :: Controller s r a +reject = Controller $ \_ -> return Reject -- | Evaluate controller with given configuration -evalController :: Controller s HttpResponse -- ^ Controller +evalController :: Controller s a a -- ^ Controller -> s -- ^ Configuration for controller - -> IO (Maybe HttpResponse) + -> IO (Maybe a) evalController m s = anyResult `fmap` (runController m s) diff --git a/Framework/Http/Sessions.hs b/Framework/Http/Sessions.hs index a229b87..43c806b 100644 --- a/Framework/Http/Sessions.hs +++ b/Framework/Http/Sessions.hs @@ -12,7 +12,9 @@ module Framework.Http.Sessions import Debug.Trace -import System.IO +import Prelude hiding (readFile,writeFile) +import System.IO hiding (readFile,writeFile) +import System.IO.UTF8 import System.Directory import System.FilePath ((</>)) import System.Random diff --git a/Framework/Makefile b/Framework/Makefile index 8ff3645..fb4ad9a 100644 --- a/Framework/Makefile +++ b/Framework/Makefile @@ -1,4 +1,4 @@ -GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../ +GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../ -i../Blog/ all: API.o diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index e6dd151..b681fb2 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -1,27 +1,52 @@ module Framework.TEngine.TemplateUtil (render, renderToResponse, - renderToResponseC - ) - where + renderToResponseM, + renderToResponseP, + processContext + ) where +import Control.Monad (when) +import Control.Monad.Reader.Class import qualified Data.Map as M import Network.HTTP import Framework.Http.Response (ok) import Framework.TEngine.Templates (render) import Framework.Types +import Framework.Controller import Framework.API import Framework.Cache +import Framework.ContextProcessors (defaultProcessors) instance (Ord k, Show k,Show v, Read k, Read v) => Serializable (M.Map k v) where toString = show fromString = read -renderToResponse :: String -> [(String,TContainer)] -> HttpResponse +renderToResponse :: String -> Context -> HttpResponse renderToResponse name pairs = ok $! render name (M.fromList pairs) -renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> [(String,TContainer)] -> IO HttpResponse +processContext :: Context -> Controller ActionConfig HttpResponse Context +processContext ctx = do + res <- concatC defaultProcessors + return $ ctx++res + +renderToResponseM :: String -> Context -> HttpController +renderToResponseM name pairs = do + ctx <- processContext pairs + return $ renderToResponse name ctx + +renderToResponseP :: String -> String -> Context -> HttpController +renderToResponseP key name pairs = do + ctx <- processContext pairs + msg <- sessionLookup "message" + let html = render name (M.fromList ctx) + when (null msg) $ do + cachePut key html + return () + return $ ok html + +renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> Context -> IO HttpResponse renderToResponseC (ActionConfig{cacheBackend=b}) key name pairs = do v <- cached b ("render:"++name) key (render name) (M.fromList pairs) return $ ok v diff --git a/Framework/Types.hs b/Framework/Types.hs index 207a39e..0c92294 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -9,7 +9,7 @@ import qualified Database.HDBC as D import Network.HTTP import Framework.Http.SessionTypes -import Framework.CacheTypes +import Framework.Cache.Types import Framework.Pool ---------------------------------------------------------------- @@ -193,6 +193,11 @@ type SFunction = forall a. (TemplateItem a) => a -> String -- | Boolean function of "TContainer" type BFunction = forall a. (TemplateItem a) => a -> Bool +------------------------------------------------------------------------------------------- +type Context = [(String,TContainer)] +------------------------------------------------------------------------------------------- + + -- | Apply given function (render) for each item in the list (contained in TContainer). -- Used in Templates. mapF :: String -- ^ Name of list-item variable