module Text.Templating.Heist.Splices.Cache
( CacheTagState
, mkCacheTag
, clearCacheTagState
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
import Data.IORef
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Read
import Data.Time.Clock
import System.Random
import Text.XmlHtml.Cursor
import Text.XmlHtml hiding (Node)
import Text.Templating.Heist.Internal
import Text.Templating.Heist.Types
cacheTagName :: Text
cacheTagName = "cache"
newtype CacheTagState = CTS (MVar (Map Text (UTCTime, Template)))
clearCacheTagState :: CacheTagState -> IO ()
clearCacheTagState (CTS cacheMVar) =
modifyMVar_ cacheMVar (const $ return Map.empty)
parseTTL :: Text -> Int
parseTTL s = value * multiplier
where
value = either (const 0) fst $ decimal s
multiplier = case T.last s of
's' -> 1
'm' -> 60
'h' -> 3600
'd' -> 86400
'w' -> 604800
_ -> 0
cacheImpl :: (MonadIO m)
=> CacheTagState
-> HeistT m Template
cacheImpl (CTS mv) = do
tree <- getParamNode
let err = error $ unwords ["cacheImpl is bound to a tag"
,"that didn't get an id attribute."
," This should never happen."]
let i = maybe err id $ getAttribute "id" tree
ttl = maybe 0 parseTTL $ getAttribute "ttl" tree
mp <- liftIO $ readMVar mv
(mp',ns) <- do
cur <- liftIO getCurrentTime
let mbn = Map.lookup i mp
reload = do
nodes' <- runNodeList $ childNodes tree
return $! (Map.insert i (cur,nodes') mp, nodes')
case mbn of
Nothing -> reload
(Just (lastUpdate,n)) -> do
if ttl > 0 && tagName tree == Just cacheTagName &&
diffUTCTime cur lastUpdate > fromIntegral ttl
then reload
else do
stopRecursion
return $! (mp,n)
liftIO $ modifyMVar_ mv (const $ return mp')
return ns
mkCacheTag :: MonadIO m
=> IO (TemplateState m -> TemplateState m, CacheTagState)
mkCacheTag = do
sr <- newIORef $ Set.empty
mv <- liftM CTS $ newMVar Map.empty
return $ ( addOnLoadHook (assignIds sr) .
bindSplice cacheTagName (cacheImpl mv) .
bindSplice "static" (cacheImpl mv)
, mv)
where
generateId :: IO Int
generateId = getStdRandom random
assignIds setref = mapM f
where
f node = g $ fromNode node
getId = do
i <- liftM (T.pack . show) generateId
st <- readIORef setref
if Set.member i st
then getId
else do
writeIORef setref $ Set.insert i st
return $ T.append "cache-id-" i
g curs = do
let node = current curs
curs' <- if tagName node == Just cacheTagName ||
tagName node == Just "static"
then do
i <- getId
return $ modifyNode (setAttribute "id" i) curs
else return curs
let mbc = nextDF curs'
maybe (return $ topNode curs') g mbc