1 module Text.Templating.Heist.Splices.Cache
    2   ( CacheTagState
    3   , mkCacheTag
    4   , clearCacheTagState
    5   ) where
    6 
    7 ------------------------------------------------------------------------------
    8 import           Control.Concurrent
    9 import           Control.Monad
   10 import           Control.Monad.Trans
   11 import           Data.IORef
   12 import qualified Data.Map as Map
   13 import           Data.Map (Map)
   14 import           Data.Maybe
   15 import qualified Data.Set as Set
   16 import           Data.Text (Text)
   17 import qualified Data.Text as T
   18 import           Data.Text.Read
   19 import           Data.Time.Clock
   20 import           System.Random
   21 import           Text.XmlHtml.Cursor
   22 import           Text.XmlHtml hiding (Node)
   23 
   24 
   25 ------------------------------------------------------------------------------
   26 import           Text.Templating.Heist.Internal
   27 import           Text.Templating.Heist.Types
   28 
   29 
   30 cacheTagName :: Text
   31 cacheTagName = "cache"
   32 
   33 ------------------------------------------------------------------------------
   34 -- | State for storing cache tag information
   35 newtype CacheTagState = CTS (MVar (Map Text (UTCTime, Template)))
   36 
   37 
   38 ------------------------------------------------------------------------------
   39 -- | Clears the cache tag state.
   40 clearCacheTagState :: CacheTagState -> IO ()
   41 clearCacheTagState (CTS cacheMVar) =
   42     modifyMVar_ cacheMVar (const $ return Map.empty)
   43 
   44 
   45 ------------------------------------------------------------------------------
   46 -- | Converts a TTL string into an integer number of seconds.
   47 parseTTL :: Text -> Int
   48 parseTTL s = value * multiplier
   49   where
   50     value = either (const 0) fst $ decimal s
   51     multiplier = case T.last s of
   52         's' -> 1
   53         'm' -> 60
   54         'h' -> 3600
   55         'd' -> 86400
   56         'w' -> 604800
   57         _   -> 0
   58         
   59 ------------------------------------------------------------------------------
   60 -- | The \"cache\" splice ensures that its contents are cached and only
   61 -- evaluated periodically.  The cached contents are returned every time the
   62 -- splice is referenced.
   63 --
   64 -- Use the ttl attribute to set the amount of time between reloads.  The ttl
   65 -- value should be a positive integer followed by a single character
   66 -- specifying the units.  Valid units are seconds, minutes, hours, days, and
   67 -- weeks.  If the ttl string is invalid or the ttl attribute is not specified,
   68 -- the cache is never refreshed unless explicitly cleared with
   69 -- clearCacheTagState.
   70 cacheImpl :: (MonadIO m)
   71            => CacheTagState
   72            -> HeistT m Template
   73 cacheImpl (CTS mv) = do
   74     tree <- getParamNode
   75     let i = fromJust $ getAttribute "id" tree
   76         ttl = maybe 0 parseTTL $ getAttribute "ttl" tree
   77     mp <- liftIO $ readMVar mv
   78 
   79     (mp',ns) <- do
   80                    curTime <- liftIO getCurrentTime
   81                    let mbn = Map.lookup i mp
   82                        reload = do
   83                            nodes' <- runNodeList $ childNodes tree
   84                            return $! (Map.insert i (curTime,nodes') mp, nodes')
   85                    case mbn of
   86                        Nothing -> reload
   87                        (Just (lastUpdate,n)) -> do
   88                            if ttl > 0 &&
   89                               diffUTCTime curTime lastUpdate > fromIntegral ttl
   90                              then reload
   91                              else do
   92                                  stopRecursion
   93                                  return $! (mp,n)
   94 
   95     liftIO $ modifyMVar_ mv (const $ return mp')
   96 
   97     return ns
   98 
   99 
  100 ------------------------------------------------------------------------------
  101 -- | Modifies a TemplateState to include a \"cache\" tag.  The cache tag is
  102 -- not bound automatically with the other default Heist tags.  This is because
  103 -- this function also returns CacheTagState, so the user will be able to
  104 -- clear it with the 'clearCacheTagState' function.
  105 mkCacheTag :: MonadIO m
  106            => IO (TemplateState m -> TemplateState m, CacheTagState)
  107 mkCacheTag = do
  108     sr <- newIORef $ Set.empty
  109     mv <- liftM CTS $ newMVar Map.empty
  110 
  111     return $ (addOnLoadHook (assignIds sr) .
  112               bindSplice cacheTagName (cacheImpl mv), mv)
  113 
  114   where
  115     generateId :: IO Int
  116     generateId = getStdRandom random
  117 
  118     assignIds setref = mapM f
  119         where
  120           f node = g $ fromNode node
  121 
  122           getId = do
  123               i  <- liftM (T.pack . show) generateId
  124               st <- readIORef setref
  125               if Set.member i st
  126                 then getId
  127                 else do
  128                     writeIORef setref $ Set.insert i st
  129                     return $ T.append "cache-id-" i
  130 
  131           g curs = do
  132               let node = current curs
  133               curs' <- if tagName node == Just cacheTagName
  134                          then do
  135                              i <- getId
  136                              return $ modifyNode (setAttribute "id" i) curs
  137                          else return curs
  138               let mbc = nextDF curs'
  139               maybe (return $ topNode curs') g mbc
  140 
  141 
  142 
  143