{-# 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 (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
    [IORef (Maybe (UTCTime, Builder))]
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 (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))
    (IORef (Maybe (UTCTime, Builder)) -> IO ())
-> [IORef (Maybe (UTCTime, Builder))] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
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) [IORef (Maybe (UTCTime, Builder))]
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 :: CacheTagState -> Splice n
cacheImpl (CTS MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
mv) = do
    Node
tree <- HeistT n n Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
    let err :: a
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
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 :: NominalDiffTime
ttl = Node -> NominalDiffTime
getTTL Node
tree
    ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
mp <- IO
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
-> HeistT
     n
     n
     ([IORef (Maybe (UTCTime, Builder))],
      HashMap Text (UTCTime, Template))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([IORef (Maybe (UTCTime, Builder))],
    HashMap Text (UTCTime, Template))
 -> HeistT
      n
      n
      ([IORef (Maybe (UTCTime, Builder))],
       HashMap Text (UTCTime, Template)))
-> IO
     ([IORef (Maybe (UTCTime, Builder))],
      HashMap Text (UTCTime, Template))
-> HeistT
     n
     n
     ([IORef (Maybe (UTCTime, Builder))],
      HashMap Text (UTCTime, Template))
forall a b. (a -> b) -> a -> b
$ MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
-> IO
     ([IORef (Maybe (UTCTime, Builder))],
      HashMap Text (UTCTime, Template))
forall a. MVar a -> IO a
readMVar MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
mv

    Template
ns <- do
        UTCTime
cur <- IO UTCTime -> HeistT n n UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        let mbn :: Maybe (UTCTime, Template)
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 :: HeistT n n Template
reload = do
                Template
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 :: HashMap Text (UTCTime, Template)
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
                IO () -> HeistT n n ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HeistT n n ()) -> IO () -> HeistT n n ()
forall a b. (a -> b) -> a -> b
$ 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)
_) -> ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
-> IO
     ([IORef (Maybe (UTCTime, Builder))],
      HashMap Text (UTCTime, Template))
forall (m :: * -> *) a. Monad m => a -> m a
return ([IORef (Maybe (UTCTime, Builder))]
a, HashMap Text (UTCTime, Template)
newMap))
                Template -> HeistT n n Template
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
nodes'
        case Maybe (UTCTime, Template)
mbn of
            Maybe (UTCTime, Template)
Nothing -> Splice n
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 Splice n
forall (n :: * -> *). MonadIO n => HeistT n n Template
reload
                  else do
                      HeistT n n ()
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m ()
stopRecursion
                      Template -> Splice n
forall (m :: * -> *) a. Monad m => a -> m a
return (Template -> Splice n) -> Template -> Splice n
forall a b. (a -> b) -> a -> b
$! Template
n

    Template -> Splice n
forall (m :: * -> *) a. Monad m => a -> m a
return Template
ns


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

    DList (Chunk n)
compiled <- Template -> Splice n
forall (n :: * -> *). Monad n => Template -> Splice n
C.runNodeList (Template -> Splice n) -> Template -> Splice n
forall a b. (a -> b) -> a -> b
$ Node -> Template
childNodes Node
tree
    IORef (Maybe (UTCTime, Builder))
ref <- IO (IORef (Maybe (UTCTime, Builder)))
-> HeistT n IO (IORef (Maybe (UTCTime, Builder)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe (UTCTime, Builder)))
 -> HeistT n IO (IORef (Maybe (UTCTime, Builder))))
-> IO (IORef (Maybe (UTCTime, Builder)))
-> HeistT n IO (IORef (Maybe (UTCTime, Builder)))
forall a b. (a -> b) -> a -> b
$ Maybe (UTCTime, Builder) -> IO (IORef (Maybe (UTCTime, Builder)))
forall a. a -> IO (IORef a)
newIORef Maybe (UTCTime, Builder)
forall a. Maybe a
Nothing
    IO () -> HeistT n IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HeistT n IO ()) -> IO () -> HeistT n IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (UTCTime, Builder)) -> CacheTagState -> IO ()
addCompiledRef IORef (Maybe (UTCTime, Builder))
ref CacheTagState
cts
    let reload :: UTCTime -> RuntimeSplice n Builder
reload UTCTime
curTime = do
            Builder
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 :: Builder
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
            IO () -> RuntimeSplice n ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RuntimeSplice n ()) -> IO () -> RuntimeSplice n ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (UTCTime, Builder))
-> Maybe (UTCTime, Builder) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (UTCTime, Builder))
ref ((UTCTime, Builder) -> Maybe (UTCTime, Builder)
forall a. a -> Maybe a
Just (UTCTime
curTime, Builder
out))
            Builder -> RuntimeSplice n Builder
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
out
    DList (Chunk n) -> Splice n
forall (m :: * -> *) a. Monad m => a -> m a
return (DList (Chunk n) -> Splice n) -> DList (Chunk n) -> Splice n
forall a b. (a -> b) -> a -> b
$ RuntimeSplice n Builder -> DList (Chunk n)
forall (n :: * -> *). RuntimeSplice n Builder -> DList (Chunk n)
C.yieldRuntime (RuntimeSplice n Builder -> DList (Chunk n))
-> RuntimeSplice n Builder -> DList (Chunk n)
forall a b. (a -> b) -> a -> b
$ do
        Maybe (UTCTime, Builder)
mbn <- IO (Maybe (UTCTime, Builder))
-> RuntimeSplice n (Maybe (UTCTime, Builder))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (UTCTime, Builder))
 -> RuntimeSplice n (Maybe (UTCTime, Builder)))
-> IO (Maybe (UTCTime, Builder))
-> RuntimeSplice n (Maybe (UTCTime, Builder))
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (UTCTime, Builder)) -> IO (Maybe (UTCTime, Builder))
forall a. IORef a -> IO a
readIORef IORef (Maybe (UTCTime, Builder))
ref
        UTCTime
cur <- IO UTCTime -> RuntimeSplice n UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        case Maybe (UTCTime, Builder)
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 (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
    IORef (HashSet Text)
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
    CacheTagState
mv <- (MVar
   ([IORef (Maybe (UTCTime, Builder))],
    HashMap Text (UTCTime, Template))
 -> CacheTagState)
-> IO
     (MVar
        ([IORef (Maybe (UTCTime, Builder))],
         HashMap Text (UTCTime, Template)))
-> IO CacheTagState
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
-> CacheTagState
CTS (IO
   (MVar
      ([IORef (Maybe (UTCTime, Builder))],
       HashMap Text (UTCTime, Template)))
 -> IO CacheTagState)
-> IO
     (MVar
        ([IORef (Maybe (UTCTime, Builder))],
         HashMap Text (UTCTime, Template)))
-> IO CacheTagState
forall a b. (a -> b) -> a -> b
$ ([IORef (Maybe (UTCTime, Builder))],
 HashMap Text (UTCTime, Template))
-> IO
     (MVar
        ([IORef (Maybe (UTCTime, Builder))],
         HashMap Text (UTCTime, Template)))
forall a. a -> IO (MVar a)
newMVar ([], HashMap Text (UTCTime, Template)
forall k v. HashMap k v
H.empty)

    (Splice IO, CacheTagState) -> IO (Splice IO, CacheTagState)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Splice IO, CacheTagState) -> IO (Splice IO, CacheTagState))
-> (Splice IO, CacheTagState) -> IO (Splice IO, CacheTagState)
forall a b. (a -> b) -> a -> b
$ (IORef (HashSet Text) -> Splice IO
setupSplice IORef (HashSet Text)
sr, CacheTagState
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)
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
    Text
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
    HashSet Text
_set <- IORef (HashSet Text) -> IO (HashSet Text)
forall a. IORef a -> IO a
readIORef IORef (HashSet Text)
setref
    if Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member Text
i HashSet Text
_set
      then IORef (HashSet Text) -> IO Text
getId IORef (HashSet Text)
setref
      else do
          IORef (HashSet Text) -> HashSet Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (HashSet Text)
setref (HashSet Text -> IO ()) -> HashSet Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> HashSet Text -> HashSet Text
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert Text
i HashSet Text
_set
          Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"cache-id-" Text
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
    Text
i <- IO Text -> HeistT IO IO Text
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
node <- HeistT IO IO Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode

    Template
newChildren <- Template -> Splice IO
forall (n :: * -> *). Monad n => Template -> Splice n
runNodeList (Template -> Splice IO) -> Template -> Splice IO
forall a b. (a -> b) -> a -> b
$ Node -> Template
childNodes Node
node
    HeistT IO IO ()
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m ()
stopRecursion
    Template -> Splice IO
forall (m :: * -> *) a. Monad m => a -> m a
return (Template -> Splice IO) -> Template -> Splice IO
forall a b. (a -> b) -> a -> b
$ [Text -> Text -> Node -> Node
setAttribute Text
"id" Text
i (Node -> Node) -> Node -> Node
forall a b. (a -> b) -> a -> b
$ Node
node { elementChildren :: Template
elementChildren = Template
newChildren }]