Cache.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

-- | The \"cache\" splice ensures that its contents are cached and only
-- evaluated periodically.  The cached contents are returned every time the
-- splice is referenced.
--
-- Use the ttl attribute to set the amount of time between reloads.  The ttl
-- value should be a positive integer followed by a single character
-- specifying the units.  Valid units are a single letter abbreviation for one
-- of seconds, minutes, hours, days, and weeks.  If the ttl string is invalid
-- or the ttl attribute is not specified, the cache is never refreshed unless
-- explicitly cleared with clearCacheTagState.  The compiled splice version of
-- the cache tag does not require a cache tag state, so clearCacheTagState
-- will not work for compiled cache tags.

module Heist.Splices.Cache
  ( CacheTagState
  , cacheImpl
  , cacheImplCompiled
  , mkCacheTag
  , clearCacheTagState
  ) where

------------------------------------------------------------------------------
import           Blaze.ByteString.Builder
import           Control.Concurrent
import           Control.Monad
import           Control.Monad.Trans
import           Data.IORef
import qualified Data.HashMap.Strict as H
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashSet as Set
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Read
import           Data.Time.Clock
import           Data.Word
import           System.Random
import           Text.XmlHtml


------------------------------------------------------------------------------
import qualified Heist.Compiled.Internal as C
import           Heist.Interpreted.Internal
import           Heist.Types


------------------------------------------------------------------------------
cacheTagName :: Text
cacheTagName = "cache"


------------------------------------------------------------------------------
-- | State for storing cache tag information
newtype CacheTagState =
    CTS (MVar ([IORef (Maybe (UTCTime, Builder))], HashMap Text (UTCTime, Template)))


addCompiledRef :: IORef (Maybe (UTCTime, Builder)) -> CacheTagState -> IO ()
addCompiledRef ref (CTS mv) = do
    modifyMVar_ mv (\(a,b) -> return (ref:a, b))

    
------------------------------------------------------------------------------
-- | Clears the cache tag state.
clearCacheTagState :: CacheTagState -> IO ()
clearCacheTagState (CTS cacheMVar) = do
    refs <- modifyMVar cacheMVar (\(a,_) -> return ((a, H.empty), a))
    mapM_ (\ref -> writeIORef ref Nothing) refs


------------------------------------------------------------------------------
-- | Converts a TTL string into an integer number of seconds.
parseTTL :: Text -> Int
parseTTL s = value * multiplier
  where
    (value,rest) = either (const (0::Int,"s")) id $ decimal s
    multiplier = case T.take 1 rest of
        "s" -> 1 :: Int
        "m" -> 60
        "h" -> 3600
        "d" -> 86400
        "w" -> 604800
        _   -> 1


getTTL :: Node -> NominalDiffTime
getTTL tree = fromIntegral $ maybe 0 parseTTL $ getAttribute "ttl" tree
{-# INLINE getTTL #-}


------------------------------------------------------------------------------
-- | This is the splice that actually does the work.  You should bind it to
-- the same tag name as you bound the splice returned by mkCacheTag otherwise
-- it won't work and you'll get runtime errors.
cacheImpl :: (MonadIO n) => CacheTagState -> Splice n
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 = getTTL tree
    mp <- liftIO $ readMVar mv

    ns <- do
        cur <- liftIO getCurrentTime
        let mbn = H.lookup i $ snd mp
            reload = do
                nodes' <- runNodeList $ childNodes tree
                let newMap = H.insert i (cur, nodes') $ snd mp
                liftIO $ modifyMVar_ mv (\(a,_) -> return (a, newMap))
                return $! nodes'
        case mbn of
            Nothing -> reload
            (Just (lastUpdate,n)) -> do
                if ttl > 0 && tagName tree == Just cacheTagName &&
                   diffUTCTime cur lastUpdate > ttl
                  then reload
                  else do
                      stopRecursion
                      return $! n

    return ns


------------------------------------------------------------------------------
-- | This is the compiled splice version of cacheImpl.
cacheImplCompiled :: (MonadIO n) => CacheTagState -> C.Splice n
cacheImplCompiled cts = do
    tree <- getParamNode
    let !ttl = getTTL tree

    compiled <- C.runNodeList $ childNodes tree
    ref <- liftIO $ newIORef Nothing
    liftIO $ addCompiledRef ref cts
    let reload curTime = do
            builder <- C.codeGen $! C.consolidate compiled
            let out = fromByteString $! toByteString $! builder
            liftIO $ writeIORef ref (Just (curTime, out))
            return $! out
    return $ C.yieldRuntime $ do
        mbn <- liftIO $ readIORef ref
        cur <- liftIO getCurrentTime
        case mbn of
            Nothing -> reload cur
            (Just (lastUpdate,bs)) -> do
                if (ttl > 0 && diffUTCTime cur lastUpdate > ttl)
                  then reload cur
                  else return $! bs


------------------------------------------------------------------------------
-- | Returns items necessary to set up a \"cache\" tag.  The cache tag cannot
-- be bound automatically with the other default Heist tags.  This is because
-- this function also returns CacheTagState, so the user will be able to clear
-- it with the 'clearCacheTagState' function.
--
-- This function returns a splice and a CacheTagState.  The splice is of type
-- @Splice IO@ because it has to be bound as a load time preprocessing splice.
-- Haskell's type system won't allow you to screw up and pass this splice as
-- the wrong argument to initHeist.
mkCacheTag :: IO (Splice IO, CacheTagState)
mkCacheTag = do
    sr <- newIORef $ Set.empty
    mv <- liftM CTS $ newMVar ([], H.empty)

    return $ (setupSplice sr, mv)


------------------------------------------------------------------------------
-- | Explicit type signature to avoid the Show polymorphism problem.
generateId :: IO Word
generateId = getStdRandom random


------------------------------------------------------------------------------
-- | Gets a unique ID for use in the cache tags.
getId :: IORef (Set.HashSet Text) -> IO Text
getId setref = do
    i <- liftM (T.pack . show) generateId
    _set <- readIORef setref
    if Set.member i _set
      then getId setref
      else do
          writeIORef setref $ Set.insert i _set
          return $ T.append "cache-id-" i


------------------------------------------------------------------------------
-- | A splice that sets the id attribute so that nodes can be cache-aware.
setupSplice :: IORef (Set.HashSet Text) -> Splice IO
setupSplice setref = do
    i <- liftIO $ getId setref
    node <- getParamNode

    newChildren <- runNodeList $ childNodes node
    stopRecursion
    return $ [setAttribute "id" i $ node { elementChildren = newChildren }]