{-#LANGUAGE NoImplicitPrelude #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE OverloadedLists #-}
{-#LANGUAGE LambdaCase #-}
{-#LANGUAGE TupleSections #-}
module Web.Sprinkles.Cache
where
import Web.Sprinkles.Prelude
import Control.MaybeEitherMonad
import Data.Time.Clock.POSIX
data Cache k v =
Cache
{ cacheGet :: k -> IO (Maybe v)
, cachePut :: k -> v -> IO ()
, cacheDelete :: k -> IO ()
, cacheVacuum :: IO Int
}
instance Semigroup (Cache k v) where
(<>) = appendCache
instance Monoid (Cache k v) where
mempty = nullCache
mappend = appendCache
cacheFetch :: (k -> IO v) -> Cache k v -> k -> IO v
cacheFetch load cache key = do
entryMay <- cacheGet cache key
case entryMay of
Just value ->
return value
Nothing -> do
value <- load key
cachePut cache key value
return value
cached :: Cache k v -> (k -> IO v) -> k -> IO v
cached = flip cacheFetch
nullCache :: Cache k v
nullCache =
Cache
{ cacheGet = const $ return Nothing
, cachePut = const . const $ return ()
, cacheDelete = const $ return ()
, cacheVacuum = return 0
}
appendCache :: Cache k v -> Cache k v -> Cache k v
appendCache first second =
Cache
{ cacheGet = \key -> cacheGet first key >>= \case
Nothing ->
cacheGet second key >>=
maybe
(return Nothing)
(\value -> do
cachePut first key value
return $ Just value
)
Just value ->
return $ Just value
, cachePut = \key value -> do
cachePut first key value
cachePut second key value
, cacheDelete = \key -> do
cacheDelete first key
cacheDelete second key
, cacheVacuum = (+) <$> cacheVacuum first <*> cacheVacuum second
}
transformCache :: (k -> j)
-> (j -> Maybe k)
-> (v -> IO (Maybe u))
-> (u -> IO (Maybe v))
-> Cache j u
-> Cache k v
transformCache transK
untransK
transV
untransV
innerCache =
Cache
{ cacheGet = \key -> cacheGet innerCache (transK key) >>= \case
Nothing -> return Nothing
Just tval -> untransV tval
, cachePut = \key value ->
transV value >>= optionally (cachePut innerCache (transK key))
, cacheDelete = cacheDelete innerCache . transK
, cacheVacuum = cacheVacuum innerCache
}