module Snap.App.Cache
(cache
,cacheIf
,resetCache
,clearCache
,resetCacheModel
,viewCached
,Key(..)
,CacheDir(..))
where
import Control.Monad.Reader
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.IO as T
import Snap.App
import System.Directory
import System.FilePath
import Text.Blaze
import Text.Blaze.Renderer.Text
class Key key where
keyToString :: key -> FilePath
class CacheDir config where
getCacheDir :: config -> FilePath
cacheIf :: (CacheDir c,Key key) => Bool -> key -> Controller c s (Maybe Markup) -> Controller c s (Maybe Text)
cacheIf pred key generate =
if pred
then cache key generate
else fmap (fmap renderHtml) generate
cache :: (CacheDir c,Key key) => key -> Controller c s (Maybe Markup) -> Controller c s (Maybe Text)
cache key generate = do
tmpdir <- asks (getCacheDir . controllerStateConfig)
let cachePath = tmpdir ++ "/" ++ keyToString key
exists <- io $ doesFileExist cachePath
if exists
then do text <- io $ T.readFile cachePath
return (Just text)
else do text <- fmap (fmap renderHtml) generate
case text of
Just text' -> do io $ createDirectoryIfMissing True tmpdir
io $ T.writeFile cachePath text'
return text
Nothing -> return text
clearCache :: CacheDir c => c -> IO ()
clearCache config = do
files <- getDirectoryContents dir
forM_ (filter (not . all (=='.')) files) $ removeFile . (dir </>)
where dir = getCacheDir config
resetCache :: (CacheDir c,Key key) => key -> Controller c s ()
resetCache key = do
tmpdir <- asks (getCacheDir . controllerStateConfig)
io $ do
let cachePath = tmpdir ++ "/" ++ keyToString key
exists <- io $ doesFileExist cachePath
when exists $ removeFile cachePath
resetCacheModel :: (CacheDir c,Key key) => key -> Model c s ()
resetCacheModel key = do
tmpdir <- asks (getCacheDir . modelStateConfig)
io $ do
let cachePath = tmpdir ++ "/" ++ keyToString key
exists <- io $ doesFileExist cachePath
when exists $ removeFile cachePath
io :: MonadIO m => IO a -> m a
io = liftIO
viewCached :: (CacheDir c,Key key) => key -> Controller c s Markup -> Controller c s ()
viewCached key generate = do
text <- cache key (fmap Just generate)
maybe (return ()) outputText text