{-# LANGUAGE CPP               #-}
{-# 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           System.Random
import           Text.XmlHtml

#if !MIN_VERSION_base(4,8,0)
import           Data.Word (Word)
#endif

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


------------------------------------------------------------------------------
cacheTagName :: Text
cacheTagName :: Text
cacheTagName = Text
"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 :: IORef (Maybe (UTCTime, Builder)) -> CacheTagState -> IO ()
addCompiledRef IORef (Maybe (UTCTime, Builder))
ref (CTS MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
mv) = do
    MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
-> (([IORef (Maybe (UTCTime, Builder))],
     HashMap Text (UTCTime, Template))
    -> IO
         ([IORef (Maybe (UTCTime, Builder))],
          HashMap Text (UTCTime, Template)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
mv (\([IORef (Maybe (UTCTime, Builder))]
a,HashMap Text (UTCTime, Template)
b) -> ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
-> IO
     ([IORef (Maybe (UTCTime, Builder))],
      HashMap Text (UTCTime, Template))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef (Maybe (UTCTime, Builder))
refIORef (Maybe (UTCTime, Builder))
-> [IORef (Maybe (UTCTime, Builder))]
-> [IORef (Maybe (UTCTime, Builder))]
forall a. a -> [a] -> [a]
:[IORef (Maybe (UTCTime, Builder))]
a, HashMap Text (UTCTime, Template)
b))

    
------------------------------------------------------------------------------
-- | Clears the cache tag state.
clearCacheTagState :: CacheTagState -> IO ()
clearCacheTagState :: CacheTagState -> IO ()
clearCacheTagState (CTS MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
cacheMVar) = do
    refs <- MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
-> (([IORef (Maybe (UTCTime, Builder))],
     HashMap Text (UTCTime, Template))
    -> IO
         (([IORef (Maybe (UTCTime, Builder))],
           HashMap Text (UTCTime, Template)),
          [IORef (Maybe (UTCTime, Builder))]))
-> IO [IORef (Maybe (UTCTime, Builder))]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
cacheMVar (\([IORef (Maybe (UTCTime, Builder))]
a,HashMap Text (UTCTime, Template)
_) -> (([IORef (Maybe (UTCTime, Builder))],
  HashMap Text (UTCTime, Template)),
 [IORef (Maybe (UTCTime, Builder))])
-> IO
     (([IORef (Maybe (UTCTime, Builder))],
       HashMap Text (UTCTime, Template)),
      [IORef (Maybe (UTCTime, Builder))])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([IORef (Maybe (UTCTime, Builder))]
a, HashMap Text (UTCTime, Template)
forall k v. HashMap k v
H.empty), [IORef (Maybe (UTCTime, Builder))]
a))
    mapM_ (\IORef (Maybe (UTCTime, Builder))
ref -> IORef (Maybe (UTCTime, Builder))
-> Maybe (UTCTime, Builder) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (UTCTime, Builder))
ref Maybe (UTCTime, Builder)
forall a. Maybe a
Nothing) refs


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


getTTL :: Node -> NominalDiffTime
getTTL :: Node -> NominalDiffTime
getTTL Node
tree = Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> NominalDiffTime) -> Int -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Int -> (Text -> Int) -> Maybe Text -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Text -> Int
parseTTL (Maybe Text -> Int) -> Maybe Text -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Maybe Text
getAttribute Text
"ttl" Node
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 :: forall (n :: * -> *). MonadIO n => CacheTagState -> Splice n
cacheImpl (CTS MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
mv) = do
    tree <- HeistT n n Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
    let err = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"cacheImpl is bound to a tag"
                              ,String
"that didn't get an id attribute."
                              ,String
" This should never happen."]
    let i = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall {a}. a
err Text -> Text
forall a. a -> a
id (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Maybe Text
getAttribute Text
"id" Node
tree
        !ttl = Node -> NominalDiffTime
getTTL Node
tree
    mp <- liftIO $ readMVar mv

    ns <- do
        cur <- liftIO getCurrentTime
        let mbn = Text
-> HashMap Text (UTCTime, Template) -> Maybe (UTCTime, Template)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
i (HashMap Text (UTCTime, Template) -> Maybe (UTCTime, Template))
-> HashMap Text (UTCTime, Template) -> Maybe (UTCTime, Template)
forall a b. (a -> b) -> a -> b
$ ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
-> HashMap Text (UTCTime, Template)
forall a b. (a, b) -> b
snd ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
mp
            reload = do
                nodes' <- Template -> HeistT n n Template
forall (n :: * -> *). Monad n => Template -> Splice n
runNodeList (Template -> HeistT n n Template)
-> Template -> HeistT n n Template
forall a b. (a -> b) -> a -> b
$ Node -> Template
childNodes Node
tree
                let newMap = Text
-> (UTCTime, Template)
-> HashMap Text (UTCTime, Template)
-> HashMap Text (UTCTime, Template)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
i (UTCTime
cur, Template
nodes') (HashMap Text (UTCTime, Template)
 -> HashMap Text (UTCTime, Template))
-> HashMap Text (UTCTime, Template)
-> HashMap Text (UTCTime, Template)
forall a b. (a -> b) -> a -> b
$ ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
-> HashMap Text (UTCTime, Template)
forall a b. (a, b) -> b
snd ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
mp
                liftIO $ modifyMVar_ mv (\([IORef (Maybe (UTCTime, Builder))]
a,HashMap Text (UTCTime, Template)
_) -> ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
-> IO
     ([IORef (Maybe (UTCTime, Builder))],
      HashMap Text (UTCTime, Template))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([IORef (Maybe (UTCTime, Builder))]
a, HashMap Text (UTCTime, Template)
newMap))
                return $! nodes'
        case mbn of
            Maybe (UTCTime, Template)
Nothing -> HeistT n n Template
forall {n :: * -> *}. MonadIO n => HeistT n n Template
reload
            (Just (UTCTime
lastUpdate,Template
n)) -> do
                if NominalDiffTime
ttl NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0 Bool -> Bool -> Bool
&& Node -> Maybe Text
tagName Node
tree Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
cacheTagName Bool -> Bool -> Bool
&&
                   UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
cur UTCTime
lastUpdate NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
ttl
                  then HeistT n n Template
forall {n :: * -> *}. MonadIO n => HeistT n n Template
reload
                  else do
                      HeistT n n ()
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m ()
stopRecursion
                      Template -> HeistT n n Template
forall a. a -> HeistT n n a
forall (m :: * -> *) a. Monad m => a -> m a
return (Template -> HeistT n n Template)
-> Template -> HeistT n n Template
forall a b. (a -> b) -> a -> b
$! Template
n

    return ns


------------------------------------------------------------------------------
-- | This is the compiled splice version of cacheImpl.
cacheImplCompiled :: (MonadIO n) => CacheTagState -> C.Splice n
cacheImplCompiled :: forall (n :: * -> *). MonadIO n => CacheTagState -> Splice n
cacheImplCompiled CacheTagState
cts = do
    tree <- HeistT n IO Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
    let !ttl = Node -> NominalDiffTime
getTTL Node
tree

    compiled <- C.runNodeList $ childNodes tree
    ref <- liftIO $ newIORef Nothing
    liftIO $ addCompiledRef ref cts
    let reload UTCTime
curTime = do
            builder <- DList (Chunk n) -> RuntimeSplice n Builder
forall (n :: * -> *).
Monad n =>
DList (Chunk n) -> RuntimeSplice n Builder
C.codeGen DList (Chunk n)
compiled
            let out = ByteString -> Builder
fromByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$! Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$! Builder
builder
            liftIO $ writeIORef ref (Just (curTime, out))
            return $! out
    return $ C.yieldRuntime $ do
        mbn <- liftIO $ readIORef ref
        cur <- liftIO getCurrentTime
        case mbn of
            Maybe (UTCTime, Builder)
Nothing -> UTCTime -> RuntimeSplice n Builder
reload UTCTime
cur
            (Just (UTCTime
lastUpdate,Builder
bs)) -> do
                if (NominalDiffTime
ttl NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0 Bool -> Bool -> Bool
&& UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
cur UTCTime
lastUpdate NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
ttl)
                  then UTCTime -> RuntimeSplice n Builder
reload UTCTime
cur
                  else Builder -> RuntimeSplice n Builder
forall a. a -> RuntimeSplice n a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> RuntimeSplice n Builder)
-> Builder -> RuntimeSplice n Builder
forall a b. (a -> b) -> a -> b
$! Builder
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 :: IO (Splice IO, CacheTagState)
mkCacheTag = do
    sr <- HashSet Text -> IO (IORef (HashSet Text))
forall a. a -> IO (IORef a)
newIORef (HashSet Text -> IO (IORef (HashSet Text)))
-> HashSet Text -> IO (IORef (HashSet Text))
forall a b. (a -> b) -> a -> b
$ HashSet Text
forall a. HashSet a
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 :: IO Word
generateId = (StdGen -> (Word, StdGen)) -> IO Word
forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom StdGen -> (Word, StdGen)
forall a g. (Random a, RandomGen g) => g -> (a, g)
forall g. RandomGen g => g -> (Word, g)
random


------------------------------------------------------------------------------
-- | Gets a unique ID for use in the cache tags.
getId :: IORef (Set.HashSet Text) -> IO Text
getId :: IORef (HashSet Text) -> IO Text
getId IORef (HashSet Text)
setref = do
    i <- (Word -> Text) -> IO Word -> IO Text
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Text
T.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show) IO Word
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 :: IORef (HashSet Text) -> Splice IO
setupSplice IORef (HashSet Text)
setref = do
    i <- IO Text -> HeistT IO IO Text
forall a. IO a -> HeistT IO IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> HeistT IO IO Text) -> IO Text -> HeistT IO IO Text
forall a b. (a -> b) -> a -> b
$ IORef (HashSet Text) -> IO Text
getId IORef (HashSet Text)
setref
    node <- getParamNode

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