{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
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"
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))
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
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 #-}
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
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
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)
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
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
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 }]