diff --git a/Blog/Blog b/Blog/Blog index 0125bf1..a8f62cb 100755 Binary files a/Blog/Blog and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 6cdd7e5..cdef9b4 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -2,6 +2,8 @@ import System.IO import Network.Shed.Httpd import Database.HDBC (SqlValue(..),fromSql) +import qualified Data.Map as M +import Control.Monad import Framework.Types import Framework.API @@ -14,6 +16,7 @@ import Framework.Utils import Framework.Forms.Validation import Framework.Models import Framework.Pager +import Framework.Cache import Config import Models @@ -31,14 +34,29 @@ urlconf = "blog" // "new" --> newpost allposts :: HttpAction allposts hp rq = withConfig hp rq $ \conf -> do - (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)] + result <- cGet (cacheBackend conf) key + case result of + Just html -> return $ ok html + Nothing -> do + (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 + let html = render "blogposts.html" $ M.fromList [("posts", C posts), + ("comments", C lastComments), + ("message", C message), + ("pager", C pagerHtml)] + cPut (cacheBackend conf) key html + return $ ok html + where key = "allposts" ++ (httpGetVar' rq "page" "1") + +invalidatePostsCache :: ActionConfig -> IO () +invalidatePostsCache conf = do + [[r]] <- queryListSQL conf (count (table postModel)) [] + let n = fromSql r :: Int + let pages = (n `div` 5) + 1 + forM [1..pages] $ \page -> cUnset (cacheBackend conf) ("allposts"++(show page)) + return () newpost :: HttpAction newpost hp rq = withConfig hp rq $ \conf -> @@ -54,6 +72,7 @@ newpost hp rq = withConfig hp rq $ \conf -> pbody = post -:> "body" in do queryListSQL conf (insertM postModel) [ptitle, pbody] commit conf + invalidatePostsCache conf return $ redirectG "/blog/" ["code" =: "1"] Left e -> returnInvalidForm conf postForm "1" e where url = myUrl rq diff --git a/Blog/Config.hs b/Blog/Config.hs index 5aa5087..6a94e22 100644 --- a/Blog/Config.hs +++ b/Blog/Config.hs @@ -9,7 +9,10 @@ params = HP { docdir = "static", dbDriver = "psql", -- dbPath = "blog.db", dbPath = "host=rtfm-server password=31415", - cacheDriver = "filesystem", +-- cacheDriver = "memcached", +-- cachePath = "localhost:11211", + cacheDriver = "fake", +-- cacheDriver = "filesystem", cachePath = "tmp/", sessionsDriver = "files", sessionsPath = "tmp/sessions/" diff --git a/Blog/Makefile b/Blog/Makefile index da284a7..3399fe3 100644 --- a/Blog/Makefile +++ b/Blog/Makefile @@ -1,4 +1,4 @@ -GHC=ghc --make -O2 -i. -i../ +GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../ TEMPLATES=../Framework/TEngine/Templates.hs all: Templates Blog diff --git a/Framework/Cache.hs b/Framework/Cache.hs index cb85d20..fafb825 100644 --- a/Framework/Cache.hs +++ b/Framework/Cache.hs @@ -2,14 +2,16 @@ module Framework.Cache ( -- $doc initCache, - cGet,cPut, + cGet,cPut,cUnset, cached, cFree, Serializable (..), CacheConnection ) where -import System.Directory(doesFileExist) +import Prelude hiding (readFile,writeFile) +import System.IO.UTF8 +import System.Directory(doesFileExist,removeFile) import System.FilePath ((</>)) import Control.Exception(handle,IOException) @@ -28,6 +30,7 @@ class CacheBackend b where cinit :: String -> IO b -- ^ Init cache backend cget :: (Serializable v) => b -> String -> IO (Maybe v) -- ^ Get data from cache cput :: (Serializable v) => b -> String -> v -> IO Bool -- ^ Put data to cache + cunset :: b -> String -> IO Bool -- ^ Unset data cfree :: b -> IO () -- ^ Free backend -- | Type to incapsulate connection to any cache backend. @@ -45,6 +48,7 @@ instance CacheBackend MemcacheBackend where 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 @@ -64,12 +68,19 @@ instance CacheBackend FilesystemBackend where 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 () -- | Init cache backend. Backend type is given in first argument, @@ -87,6 +98,9 @@ cGet (CConnection b) name = cget b name cPut :: (Serializable v) => CacheConnection -> String -> v -> IO Bool cPut (CConnection b) name value = cput b name value +cUnset :: CacheConnection -> String -> IO Bool +cUnset (CConnection b) name = cunset b name + -- | Free cache backend cFree :: CacheConnection -> IO () cFree (CConnection b) = cfree b diff --git a/Framework/Makefile b/Framework/Makefile index 94d36e5..8ff3645 100644 --- a/Framework/Makefile +++ b/Framework/Makefile @@ -1,4 +1,4 @@ -GHC=ghc --make -O2 -i. -i../ +GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../ all: API.o