{-# 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
    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) -> forall (m :: * -> *) a. Monad m => a -> m a
return (IORef (Maybe (UTCTime, Builder))
refforall 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 <- 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)
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (([IORef (Maybe (UTCTime, Builder))]
a, forall k v. HashMap k v
H.empty), [IORef (Maybe (UTCTime, Builder))]
a))
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\IORef (Maybe (UTCTime, Builder))
ref -> forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (UTCTime, Builder))
ref 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 forall a. Num a => a -> a -> a
* Int
multiplier
  where
    (Int
value,Text
rest) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (Int
0::Int,Text
"s")) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Text -> Int
parseTTL 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
    Node
tree <- forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
    let err :: a
err = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"cacheImpl is bound to a tag"
                              ,[Char]
"that didn't get an id attribute."
                              ,[Char]
" This should never happen."]
    let i :: Text
i = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
err forall a. a -> a
id 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
mv

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

    DList (Chunk n)
compiled <- forall (n :: * -> *). Monad n => Template -> Splice n
C.runNodeList forall a b. (a -> b) -> a -> b
$ Node -> Template
childNodes Node
tree
    IORef (Maybe (UTCTime, Builder))
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 <- forall (n :: * -> *).
Monad n =>
DList (Chunk n) -> RuntimeSplice n Builder
C.codeGen DList (Chunk n)
compiled
            let out :: Builder
out = ByteString -> Builder
fromByteString forall a b. (a -> b) -> a -> b
$! Builder -> ByteString
toByteString forall a b. (a -> b) -> a -> b
$! Builder
builder
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (UTCTime, Builder))
ref (forall a. a -> Maybe a
Just (UTCTime
curTime, Builder
out))
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Builder
out
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (n :: * -> *). RuntimeSplice n Builder -> DList (Chunk n)
C.yieldRuntime forall a b. (a -> b) -> a -> b
$ do
        Maybe (UTCTime, Builder)
mbn <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Maybe (UTCTime, Builder))
ref
        UTCTime
cur <- 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 forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0 Bool -> Bool -> Bool
&& UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
cur UTCTime
lastUpdate forall a. Ord a => a -> a -> Bool
> NominalDiffTime
ttl)
                  then UTCTime -> RuntimeSplice n Builder
reload UTCTime
cur
                  else forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a. HashSet a
Set.empty
    CacheTagState
mv <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM MVar
  ([IORef (Maybe (UTCTime, Builder))],
   HashMap Text (UTCTime, Template))
-> CacheTagState
CTS forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar ([], forall k v. HashMap k v
H.empty)

    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom 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 <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) IO Word
generateId
    HashSet Text
_set <- forall a. IORef a -> IO a
readIORef IORef (HashSet Text)
setref
    if 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
          forall a. IORef a -> a -> IO ()
writeIORef IORef (HashSet Text)
setref forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert Text
i HashSet Text
_set
          forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IORef (HashSet Text) -> IO Text
getId IORef (HashSet Text)
setref
    Node
node <- forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode

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