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 Data.Maybe
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
-> TemplateMonad m Template
cacheImpl (CTS mv) = do
tree <- getParamNode
let i = fromJust $ getAttribute "id" tree
ttl = maybe 0 parseTTL $ getAttribute "ttl" tree
mp <- liftIO $ readMVar mv
(mp',ns) <- do
curTime <- liftIO getCurrentTime
let mbn = Map.lookup i mp
reload = do
nodes' <- runNodeList $ childNodes tree
return $! (Map.insert i (curTime,nodes') mp, nodes')
case mbn of
Nothing -> reload
(Just (lastUpdate,n)) -> do
if ttl > 0 &&
diffUTCTime curTime 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), 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
then do
i <- getId
return $ modifyNode (setAttribute "id" i) curs
else return curs
let mbc = nextDF curs'
maybe (return $ topNode curs') g mbc