{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -O2 -fdicts-strict -fspec-constr-recursive=16 -fmax-worker-args=16 #-}
module Knit.Effect.AtomicCache
(
Cache
, WithCacheTime
, ActionWithCacheTime
, withCacheTime
, onlyCacheTime
, ignoreCacheTime
, ignoreCacheTimeM
, cacheTime
, wctMapAction
, encodeAndStore
, retrieveAndDecode
, lookupAndDecode
, retrieveOrMake
, clear
, clearIfPresent
, persistStreamlyByteArray
, persistLazyByteString
, persistStrictByteString
, AtomicMemCache
, runAtomicInMemoryCache
, runBackedAtomicInMemoryCache
, runPersistenceBackedAtomicInMemoryCache
, runPersistenceBackedAtomicInMemoryCache'
, CacheError(..)
)
where
import qualified Polysemy as P
import qualified Polysemy.Error as P
import qualified Knit.Effect.Logger as K
import qualified Knit.Effect.Serialize as KS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity (Identity(..))
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Time.Clock as Time
import qualified Data.Word as Word
import qualified Control.Concurrent.STM as C
import qualified Control.Exception as Exception
import Control.Monad ( join )
import qualified Streamly.Internal.Memory.Array as Streamly.Array
import qualified Streamly.Internal.FileSystem.File as Streamly.File
import qualified System.Directory as System
import qualified System.IO.Error as IO.Error
data CacheError =
ItemNotFoundError T.Text
| ItemTooOldError T.Text
| DeSerializationError T.Text
| PersistError T.Text
| OtherCacheError T.Text deriving (Int -> CacheError -> ShowS
[CacheError] -> ShowS
CacheError -> String
(Int -> CacheError -> ShowS)
-> (CacheError -> String)
-> ([CacheError] -> ShowS)
-> Show CacheError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheError] -> ShowS
$cshowList :: [CacheError] -> ShowS
show :: CacheError -> String
$cshow :: CacheError -> String
showsPrec :: Int -> CacheError -> ShowS
$cshowsPrec :: Int -> CacheError -> ShowS
Show, CacheError -> CacheError -> Bool
(CacheError -> CacheError -> Bool)
-> (CacheError -> CacheError -> Bool) -> Eq CacheError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheError -> CacheError -> Bool
$c/= :: CacheError -> CacheError -> Bool
== :: CacheError -> CacheError -> Bool
$c== :: CacheError -> CacheError -> Bool
Eq)
data WithCacheTime m a where
WithCacheTime :: Maybe Time.UTCTime -> m a -> WithCacheTime m a
deriving (Int -> WithCacheTime m a -> ShowS
[WithCacheTime m a] -> ShowS
WithCacheTime m a -> String
(Int -> WithCacheTime m a -> ShowS)
-> (WithCacheTime m a -> String)
-> ([WithCacheTime m a] -> ShowS)
-> Show (WithCacheTime m a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (m :: k -> *) (a :: k).
Show (m a) =>
Int -> WithCacheTime m a -> ShowS
forall k (m :: k -> *) (a :: k).
Show (m a) =>
[WithCacheTime m a] -> ShowS
forall k (m :: k -> *) (a :: k).
Show (m a) =>
WithCacheTime m a -> String
showList :: [WithCacheTime m a] -> ShowS
$cshowList :: forall k (m :: k -> *) (a :: k).
Show (m a) =>
[WithCacheTime m a] -> ShowS
show :: WithCacheTime m a -> String
$cshow :: forall k (m :: k -> *) (a :: k).
Show (m a) =>
WithCacheTime m a -> String
showsPrec :: Int -> WithCacheTime m a -> ShowS
$cshowsPrec :: forall k (m :: k -> *) (a :: k).
Show (m a) =>
Int -> WithCacheTime m a -> ShowS
Show)
instance Functor m => Functor (WithCacheTime m) where
fmap :: (a -> b) -> WithCacheTime m a -> WithCacheTime m b
fmap f :: a -> b
f (WithCacheTime tM :: Maybe UTCTime
tM ma :: m a
ma) = Maybe UTCTime -> m b -> WithCacheTime m b
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
tM ((a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f m a
ma)
{-# INLINE fmap #-}
instance Applicative m => Applicative (WithCacheTime m) where
pure :: a -> WithCacheTime m a
pure x :: a
x = Maybe UTCTime -> m a -> WithCacheTime m a
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
forall a. Maybe a
Nothing (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
{-# INLINE pure #-}
WithCacheTime t1M :: Maybe UTCTime
t1M mf :: m (a -> b)
mf <*> :: WithCacheTime m (a -> b) -> WithCacheTime m a -> WithCacheTime m b
<*> WithCacheTime t2M :: Maybe UTCTime
t2M ma :: m a
ma = Maybe UTCTime -> m b -> WithCacheTime m b
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime (Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall a. Ord a => a -> a -> a
max Maybe UTCTime
t1M Maybe UTCTime
t2M) (m (a -> b)
mf m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
ma)
{-# INLINE (<*>) #-}
type ActionWithCacheTime r a = WithCacheTime (P.Sem r) a
onlyCacheTime :: Applicative m => Maybe Time.UTCTime -> WithCacheTime m ()
onlyCacheTime :: Maybe UTCTime -> WithCacheTime m ()
onlyCacheTime tM :: Maybe UTCTime
tM = Maybe UTCTime -> m () -> WithCacheTime m ()
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
tM (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
{-# INLINEABLE onlyCacheTime #-}
withCacheTime :: Maybe Time.UTCTime -> m a -> WithCacheTime m a
withCacheTime :: Maybe UTCTime -> m a -> WithCacheTime m a
withCacheTime = Maybe UTCTime -> m a -> WithCacheTime m a
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime
{-# INLINEABLE withCacheTime #-}
wctApplyNat :: (forall a. f a -> g a) -> WithCacheTime f b -> WithCacheTime g b
wctApplyNat :: (forall (a :: k). f a -> g a)
-> WithCacheTime f b -> WithCacheTime g b
wctApplyNat nat :: forall (a :: k). f a -> g a
nat (WithCacheTime tM :: Maybe UTCTime
tM fb :: f b
fb) = Maybe UTCTime -> g b -> WithCacheTime g b
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
tM (f b -> g b
forall (a :: k). f a -> g a
nat f b
fb)
{-# INLINEABLE wctApplyNat #-}
wctMapAction :: (m a -> n b) -> WithCacheTime m a -> WithCacheTime n b
wctMapAction :: (m a -> n b) -> WithCacheTime m a -> WithCacheTime n b
wctMapAction f :: m a -> n b
f (WithCacheTime tM :: Maybe UTCTime
tM ma :: m a
ma) = Maybe UTCTime -> n b -> WithCacheTime n b
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
tM (m a -> n b
f m a
ma)
{-# INLINEABLE wctMapAction #-}
toSem :: Identity a -> P.Sem r a
toSem :: Identity a -> Sem r a
toSem = a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Sem r a) -> (Identity a -> a) -> Identity a -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity
{-# INLINE toSem #-}
ignoreCacheTime :: WithCacheTime m a -> m a
ignoreCacheTime :: WithCacheTime m a -> m a
ignoreCacheTime (WithCacheTime _ ma :: m a
ma) = m a
ma
{-# INLINEABLE ignoreCacheTime #-}
ignoreCacheTimeM :: Monad m => m (WithCacheTime m a) -> m a
ignoreCacheTimeM :: m (WithCacheTime m a) -> m a
ignoreCacheTimeM = m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m a) -> m a)
-> (m (WithCacheTime m a) -> m (m a))
-> m (WithCacheTime m a)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithCacheTime m a -> m a) -> m (WithCacheTime m a) -> m (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithCacheTime m a -> m a
forall k (m :: k -> *) (a :: k). WithCacheTime m a -> m a
ignoreCacheTime
{-# INLINEABLE ignoreCacheTimeM #-}
cacheTime :: WithCacheTime m a -> Maybe Time.UTCTime
cacheTime :: WithCacheTime m a -> Maybe UTCTime
cacheTime (WithCacheTime tM :: Maybe UTCTime
tM _) = Maybe UTCTime
tM
{-# INLINEABLE cacheTime #-}
data Cache k v m a where
CacheLookup :: k -> Cache k v m (Maybe (WithCacheTime Identity v))
CacheUpdate :: k -> Maybe v -> Cache k v m ()
P.makeSem ''Cache
debugLogSeverity :: K.LogSeverity
debugLogSeverity :: LogSeverity
debugLogSeverity = Int -> LogSeverity
K.Debug 3
{-# INLINE debugLogSeverity #-}
encodeAndStore
:: ( Show k
, P.Member (Cache k ct) r
, K.LogWithPrefixesLE r
)
=> KS.Serialize CacheError r a ct
-> k
-> a
-> P.Sem r ()
encodeAndStore :: Serialize CacheError r a ct -> k -> a -> Sem r ()
encodeAndStore (KS.Serialize encode :: a -> Sem r (ct, a)
encode _ encBytes :: ct -> Int64
encBytes) k :: k
k x :: a
x =
Text -> Sem r () -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix ("AtomicCache.encodeAndStore (key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")") (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Diagnostic (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "encoding (serializing) data for key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k)
ct
encoded <- (ct, a) -> ct
forall a b. (a, b) -> a
fst ((ct, a) -> ct) -> Sem r (ct, a) -> Sem r ct
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Sem r (ct, a)
encode a
x
let nBytes :: Int64
nBytes = ct -> Int64
encBytes ct
encoded
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Diagnostic (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Storing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
nBytes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " bytes of encoded data in cache for key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k)
k -> Maybe ct -> Sem r ()
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Maybe v -> Sem r ()
cacheUpdate k
k (ct -> Maybe ct
forall a. a -> Maybe a
Just ct
encoded)
{-# INLINEABLE encodeAndStore #-}
retrieveOrMakeAndUpdateCache
:: forall ct k r b a.
( P.Members [Cache k ct, P.Embed IO] r
, K.LogWithPrefixesLE r
, Show k
)
=> KS.Serialize CacheError r a ct
-> (b -> P.Sem r (Maybe a))
-> k
-> ActionWithCacheTime r b
-> P.Sem r (Maybe (ActionWithCacheTime r a))
retrieveOrMakeAndUpdateCache :: Serialize CacheError r a ct
-> (b -> Sem r (Maybe a))
-> k
-> ActionWithCacheTime r b
-> Sem r (Maybe (ActionWithCacheTime r a))
retrieveOrMakeAndUpdateCache (KS.Serialize encode :: a -> Sem r (ct, a)
encode decode :: ct -> Sem r a
decode encBytes :: ct -> Int64
encBytes) tryIfMissing :: b -> Sem r (Maybe a)
tryIfMissing key :: k
key (WithCacheTime newestM :: Maybe UTCTime
newestM bA :: Sem r b
bA) =
Text
-> Sem r (Maybe (ActionWithCacheTime r a))
-> Sem r (Maybe (ActionWithCacheTime r a))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix ("AtomicCache.retrieveOrMakeAndUpdateCache (key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")") (Sem r (Maybe (ActionWithCacheTime r a))
-> Sem r (Maybe (ActionWithCacheTime r a)))
-> Sem r (Maybe (ActionWithCacheTime r a))
-> Sem r (Maybe (ActionWithCacheTime r a))
forall a b. (a -> b) -> a -> b
$ do
let
makeAndUpdate :: P.Sem r (Maybe (ActionWithCacheTime r a))
makeAndUpdate :: Sem r (Maybe (ActionWithCacheTime r a))
makeAndUpdate = do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": Trying to make from given action."
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": running actions for dependencies."
b
b <- Sem r b
bA
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": making new item."
Maybe a
ma <- b -> Sem r (Maybe a)
tryIfMissing b
b
case Maybe a
ma of
Nothing -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Error (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": Making failed."
k -> Maybe ct -> Sem r ()
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Maybe v -> Sem r ()
cacheUpdate k
key Maybe ct
forall a. Maybe a
Nothing
Maybe (ActionWithCacheTime r a)
-> Sem r (Maybe (ActionWithCacheTime r a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ActionWithCacheTime r a)
forall a. Maybe a
Nothing
Just a :: a
a -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": Making/Encoding..."
(ct' :: ct
ct', a' :: a
a') <- a -> Sem r (ct, a)
encode a
a
let nBytes :: Int64
nBytes = ct -> Int64
encBytes ct
ct'
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": serialized to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
nBytes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " bytes."
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Updating cache..."
k -> Maybe ct -> Sem r ()
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Maybe v -> Sem r ()
cacheUpdate k
key (ct -> Maybe ct
forall a. a -> Maybe a
Just ct
ct')
UTCTime
curTime <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
Time.getCurrentTime
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Finished making and updating."
Maybe (ActionWithCacheTime r a)
-> Sem r (Maybe (ActionWithCacheTime r a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ActionWithCacheTime r a)
-> Sem r (Maybe (ActionWithCacheTime r a)))
-> Maybe (ActionWithCacheTime r a)
-> Sem r (Maybe (ActionWithCacheTime r a))
forall a b. (a -> b) -> a -> b
$ ActionWithCacheTime r a -> Maybe (ActionWithCacheTime r a)
forall a. a -> Maybe a
Just (Maybe UTCTime -> Sem r a -> ActionWithCacheTime r a
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
curTime) (a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'))
Maybe (WithCacheTime Identity ct)
fromCache <- k -> Sem r (Maybe (WithCacheTime Identity ct))
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Sem r (Maybe (WithCacheTime Identity v))
cacheLookup k
key
case Maybe (WithCacheTime Identity ct)
fromCache of
Just (WithCacheTime cTimeM :: Maybe UTCTime
cTimeM mct :: Identity ct
mct) -> do
if Maybe UTCTime
cTimeM Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= Maybe UTCTime
newestM
then do
let ct :: ct
ct = Identity ct -> ct
forall a. Identity a -> a
runIdentity Identity ct
mct
let nBytes :: Int64
nBytes = ct -> Int64
encBytes ct
ct
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Diagnostic (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": Retrieved " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
nBytes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " bytes from cache."
let decodeAction :: P.Sem r a
decodeAction :: Sem r a
decodeAction = do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": deserializing."
a
a <- ct -> Sem r a
decode ct
ct
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": deserializing complete."
a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe (ActionWithCacheTime r a)
-> Sem r (Maybe (ActionWithCacheTime r a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ActionWithCacheTime r a -> Maybe (ActionWithCacheTime r a)
forall a. a -> Maybe a
Just (ActionWithCacheTime r a -> Maybe (ActionWithCacheTime r a))
-> ActionWithCacheTime r a -> Maybe (ActionWithCacheTime r a)
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> Sem r a -> ActionWithCacheTime r a
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
cTimeM Sem r a
decodeAction)
else do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Diagnostic (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": Item in cache too old. Making new."
Sem r (Maybe (ActionWithCacheTime r a))
makeAndUpdate
Nothing -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Diagnostic (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": Item not found in cache. Making new."
Sem r (Maybe (ActionWithCacheTime r a))
makeAndUpdate
{-# INLINEABLE retrieveOrMakeAndUpdateCache #-}
retrieveAndDecode
:: forall ct k r a .
(P.Member (Cache k ct) r
, P.Member (P.Embed IO) r
, P.MemberWithError (P.Error CacheError) r
, K.LogWithPrefixesLE r
, Show k
)
=> KS.Serialize CacheError r a ct
-> k
-> Maybe Time.UTCTime
-> P.Sem r (ActionWithCacheTime r a)
retrieveAndDecode :: Serialize CacheError r a ct
-> k -> Maybe UTCTime -> Sem r (ActionWithCacheTime r a)
retrieveAndDecode s :: Serialize CacheError r a ct
s k :: k
k newestM :: Maybe UTCTime
newestM = Text
-> Sem r (ActionWithCacheTime r a)
-> Sem r (ActionWithCacheTime r a)
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix ("AtomicCache.retrieveAndDecode (key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")") (Sem r (ActionWithCacheTime r a)
-> Sem r (ActionWithCacheTime r a))
-> Sem r (ActionWithCacheTime r a)
-> Sem r (ActionWithCacheTime r a)
forall a b. (a -> b) -> a -> b
$ do
Maybe (ActionWithCacheTime r a)
fromCache <- Serialize CacheError r a ct
-> (() -> Sem r (Maybe a))
-> k
-> ActionWithCacheTime r ()
-> Sem r (Maybe (ActionWithCacheTime r a))
forall ct k (r :: [(* -> *) -> * -> *]) b a.
(Members '[Cache k ct, Embed IO] r, LogWithPrefixesLE r, Show k) =>
Serialize CacheError r a ct
-> (b -> Sem r (Maybe a))
-> k
-> ActionWithCacheTime r b
-> Sem r (Maybe (ActionWithCacheTime r a))
retrieveOrMakeAndUpdateCache Serialize CacheError r a ct
s (Sem r (Maybe a) -> () -> Sem r (Maybe a)
forall a b. a -> b -> a
const (Sem r (Maybe a) -> () -> Sem r (Maybe a))
-> Sem r (Maybe a) -> () -> Sem r (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> Sem r (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) k
k (Maybe UTCTime -> ActionWithCacheTime r ()
forall (m :: * -> *).
Applicative m =>
Maybe UTCTime -> WithCacheTime m ()
onlyCacheTime Maybe UTCTime
newestM)
case Maybe (ActionWithCacheTime r a)
fromCache of
Nothing -> CacheError -> Sem r (ActionWithCacheTime r a)
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (CacheError -> Sem r (ActionWithCacheTime r a))
-> CacheError -> Sem r (ActionWithCacheTime r a)
forall a b. (a -> b) -> a -> b
$ Text -> CacheError
ItemNotFoundError (Text -> CacheError) -> Text -> CacheError
forall a b. (a -> b) -> a -> b
$ "No item found/item too old for key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "."
Just x :: ActionWithCacheTime r a
x -> ActionWithCacheTime r a -> Sem r (ActionWithCacheTime r a)
forall (m :: * -> *) a. Monad m => a -> m a
return ActionWithCacheTime r a
x
{-# INLINEABLE retrieveAndDecode #-}
lookupAndDecode
:: forall ct k r a
. ( P.Member (Cache k ct) r
, K.LogWithPrefixesLE r
, P.Member (P.Embed IO) r
, P.MemberWithError (P.Error CacheError) r
, Show k
)
=> KS.Serialize CacheError r a ct
-> k
-> Maybe Time.UTCTime
-> P.Sem r (Maybe (ActionWithCacheTime r a))
lookupAndDecode :: Serialize CacheError r a ct
-> k -> Maybe UTCTime -> Sem r (Maybe (ActionWithCacheTime r a))
lookupAndDecode s :: Serialize CacheError r a ct
s k :: k
k newestM :: Maybe UTCTime
newestM = Text
-> Sem r (Maybe (ActionWithCacheTime r a))
-> Sem r (Maybe (ActionWithCacheTime r a))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix ("AtomicCache.lookupAndDecode (key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
(Sem r (Maybe (ActionWithCacheTime r a))
-> Sem r (Maybe (ActionWithCacheTime r a)))
-> Sem r (Maybe (ActionWithCacheTime r a))
-> Sem r (Maybe (ActionWithCacheTime r a))
forall a b. (a -> b) -> a -> b
$ Serialize CacheError r a ct
-> (() -> Sem r (Maybe a))
-> k
-> ActionWithCacheTime r ()
-> Sem r (Maybe (ActionWithCacheTime r a))
forall ct k (r :: [(* -> *) -> * -> *]) b a.
(Members '[Cache k ct, Embed IO] r, LogWithPrefixesLE r, Show k) =>
Serialize CacheError r a ct
-> (b -> Sem r (Maybe a))
-> k
-> ActionWithCacheTime r b
-> Sem r (Maybe (ActionWithCacheTime r a))
retrieveOrMakeAndUpdateCache Serialize CacheError r a ct
s (Sem r (Maybe a) -> () -> Sem r (Maybe a)
forall a b. a -> b -> a
const (Sem r (Maybe a) -> () -> Sem r (Maybe a))
-> Sem r (Maybe a) -> () -> Sem r (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> Sem r (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) k
k (Maybe UTCTime -> ActionWithCacheTime r ()
forall (m :: * -> *).
Applicative m =>
Maybe UTCTime -> WithCacheTime m ()
onlyCacheTime Maybe UTCTime
newestM)
{-# INLINEABLE lookupAndDecode #-}
retrieveOrMake
:: forall ct k r a b.
( P.Member (Cache k ct) r
, K.LogWithPrefixesLE r
, P.Member (P.Embed IO) r
, P.MemberWithError (P.Error CacheError) r
, Show k
)
=> KS.Serialize CacheError r a ct
-> k
-> ActionWithCacheTime r b
-> (b -> P.Sem r a)
-> P.Sem r (ActionWithCacheTime r a)
retrieveOrMake :: Serialize CacheError r a ct
-> k
-> ActionWithCacheTime r b
-> (b -> Sem r a)
-> Sem r (ActionWithCacheTime r a)
retrieveOrMake s :: Serialize CacheError r a ct
s key :: k
key cachedDeps :: ActionWithCacheTime r b
cachedDeps makeAction :: b -> Sem r a
makeAction = Text
-> Sem r (ActionWithCacheTime r a)
-> Sem r (ActionWithCacheTime r a)
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix ("retrieveOrMake (key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")") (Sem r (ActionWithCacheTime r a)
-> Sem r (ActionWithCacheTime r a))
-> Sem r (ActionWithCacheTime r a)
-> Sem r (ActionWithCacheTime r a)
forall a b. (a -> b) -> a -> b
$ do
let makeIfMissing :: b -> Sem r (Maybe a)
makeIfMissing x :: b
x = Text -> Sem r (Maybe a) -> Sem r (Maybe a)
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "retrieveOrMake.makeIfMissing" (Sem r (Maybe a) -> Sem r (Maybe a))
-> Sem r (Maybe a) -> Sem r (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Item (at key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ") not found/too old. Making..."
(a -> Maybe a) -> Sem r a -> Sem r (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Sem r a -> Sem r (Maybe a)) -> Sem r a -> Sem r (Maybe a)
forall a b. (a -> b) -> a -> b
$ b -> Sem r a
makeAction b
x
Maybe (ActionWithCacheTime r a)
fromCache <- Serialize CacheError r a ct
-> (b -> Sem r (Maybe a))
-> k
-> ActionWithCacheTime r b
-> Sem r (Maybe (ActionWithCacheTime r a))
forall ct k (r :: [(* -> *) -> * -> *]) b a.
(Members '[Cache k ct, Embed IO] r, LogWithPrefixesLE r, Show k) =>
Serialize CacheError r a ct
-> (b -> Sem r (Maybe a))
-> k
-> ActionWithCacheTime r b
-> Sem r (Maybe (ActionWithCacheTime r a))
retrieveOrMakeAndUpdateCache Serialize CacheError r a ct
s b -> Sem r (Maybe a)
makeIfMissing k
key ActionWithCacheTime r b
cachedDeps
case Maybe (ActionWithCacheTime r a)
fromCache of
Just x :: ActionWithCacheTime r a
x -> ActionWithCacheTime r a -> Sem r (ActionWithCacheTime r a)
forall (m :: * -> *) a. Monad m => a -> m a
return ActionWithCacheTime r a
x
Nothing -> CacheError -> Sem r (ActionWithCacheTime r a)
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (CacheError -> Sem r (ActionWithCacheTime r a))
-> CacheError -> Sem r (ActionWithCacheTime r a)
forall a b. (a -> b) -> a -> b
$ Text -> CacheError
OtherCacheError (Text -> CacheError) -> Text -> CacheError
forall a b. (a -> b) -> a -> b
$ "retrieveOrMake returned with Nothing. Which should be impossible, unless called with action which produced Nothing."
{-# INLINEABLE retrieveOrMake #-}
clear :: P.Member (Cache k ct) r => k -> P.Sem r ()
clear :: k -> Sem r ()
clear k :: k
k = k -> Maybe ct -> Sem r ()
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Maybe v -> Sem r ()
cacheUpdate k
k Maybe ct
forall a. Maybe a
Nothing
{-# INLINEABLE clear #-}
clearIfPresent :: (P.Member (Cache k ct) r, P.MemberWithError (P.Error CacheError) r) => k -> P.Sem r ()
clearIfPresent :: k -> Sem r ()
clearIfPresent k :: k
k = k -> Maybe ct -> Sem r ()
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Maybe v -> Sem r ()
cacheUpdate k
k Maybe ct
forall a. Maybe a
Nothing Sem r () -> (CacheError -> Sem r ()) -> Sem r ()
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`P.catch` (\(CacheError
_ :: CacheError) -> () -> Sem r ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINEABLE clearIfPresent #-}
type AtomicMemCache k v = C.TVar (M.Map k (C.TMVar (Maybe (WithCacheTime Identity v))))
atomicMemLookup :: (Ord k
, Show k
, P.Member (P.Embed IO) r
, K.LogWithPrefixesLE r
)
=> AtomicMemCache k ct
-> k
-> P.Sem r (Maybe (WithCacheTime Identity ct))
atomicMemLookup :: AtomicMemCache k ct
-> k -> Sem r (Maybe (WithCacheTime Identity ct))
atomicMemLookup cache :: AtomicMemCache k ct
cache key :: k
key = Text
-> Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "atomicMemLookup" (Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct)))
-> Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": Called."
IO (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct)))
-> IO (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ STM (Maybe (WithCacheTime Identity ct))
-> IO (Maybe (WithCacheTime Identity ct))
forall a. STM a -> IO a
C.atomically (STM (Maybe (WithCacheTime Identity ct))
-> IO (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (WithCacheTime Identity ct))
-> IO (Maybe (WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ do
Maybe (WithCacheTime Identity ct)
mv <- (AtomicMemCache k ct
-> STM (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
forall a. TVar a -> STM a
C.readTVar AtomicMemCache k ct
cache STM (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
-> (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe (Maybe (WithCacheTime Identity ct))
-> Maybe (WithCacheTime Identity ct))
-> STM (Maybe (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (WithCacheTime Identity ct))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe (WithCacheTime Identity ct))
-> Maybe (WithCacheTime Identity ct)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (STM (Maybe (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (WithCacheTime Identity ct)))
-> (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (Maybe (WithCacheTime Identity ct))))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (WithCacheTime Identity ct))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TMVar (Maybe (WithCacheTime Identity ct))
-> STM (Maybe (WithCacheTime Identity ct)))
-> Maybe (TMVar (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (Maybe (WithCacheTime Identity ct)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TMVar (Maybe (WithCacheTime Identity ct))
-> STM (Maybe (WithCacheTime Identity ct))
forall a. TMVar a -> STM a
C.readTMVar (Maybe (TMVar (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (Maybe (WithCacheTime Identity ct))))
-> (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Maybe (TMVar (Maybe (WithCacheTime Identity ct))))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> STM (Maybe (Maybe (WithCacheTime Identity ct)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Maybe (TMVar (Maybe (WithCacheTime Identity ct)))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
key)
case Maybe (WithCacheTime Identity ct)
mv of
Just wctv :: WithCacheTime Identity ct
wctv -> Maybe (WithCacheTime Identity ct)
-> STM (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WithCacheTime Identity ct)
-> STM (Maybe (WithCacheTime Identity ct)))
-> Maybe (WithCacheTime Identity ct)
-> STM (Maybe (WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just WithCacheTime Identity ct
wctv
Nothing -> do
TMVar (Maybe (WithCacheTime Identity ct))
newTMV <- STM (TMVar (Maybe (WithCacheTime Identity ct)))
forall a. STM (TMVar a)
C.newEmptyTMVar
AtomicMemCache k ct
-> (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct))))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
C.modifyTVar AtomicMemCache k ct
cache (k
-> TMVar (Maybe (WithCacheTime Identity ct))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
key TMVar (Maybe (WithCacheTime Identity ct))
newTMV)
Maybe (WithCacheTime Identity ct)
-> STM (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WithCacheTime Identity ct)
forall a. Maybe a
Nothing
{-# INLINEABLE atomicMemLookup #-}
data MemUpdateAction = Deleted | Replaced | Filled deriving (Int -> MemUpdateAction -> ShowS
[MemUpdateAction] -> ShowS
MemUpdateAction -> String
(Int -> MemUpdateAction -> ShowS)
-> (MemUpdateAction -> String)
-> ([MemUpdateAction] -> ShowS)
-> Show MemUpdateAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MemUpdateAction] -> ShowS
$cshowList :: [MemUpdateAction] -> ShowS
show :: MemUpdateAction -> String
$cshow :: MemUpdateAction -> String
showsPrec :: Int -> MemUpdateAction -> ShowS
$cshowsPrec :: Int -> MemUpdateAction -> ShowS
Show)
atomicMemUpdate :: (Ord k
, Show k
, P.Member (P.Embed IO) r
, K.LogWithPrefixesLE r
)
=> AtomicMemCache k ct
-> k
-> Maybe ct
-> P.Sem r ()
atomicMemUpdate :: AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
atomicMemUpdate cache :: AtomicMemCache k ct
cache key :: k
key mct :: Maybe ct
mct =
Text -> Sem r () -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "atomicMemUpdate" (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
let keyText :: Text
keyText = "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": "
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "called."
MemUpdateAction
updateAction <- case Maybe ct
mct of
Nothing -> (IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
C.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ AtomicMemCache k ct
-> (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct))))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
C.modifyTVar AtomicMemCache k ct
cache (k
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
key)) Sem r () -> Sem r MemUpdateAction -> Sem r MemUpdateAction
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MemUpdateAction -> Sem r MemUpdateAction
forall (m :: * -> *) a. Monad m => a -> m a
return MemUpdateAction
Deleted
Just ct :: ct
ct -> do
UTCTime
curTime <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
Time.getCurrentTime
let wct :: WithCacheTime Identity ct
wct = Maybe UTCTime -> Identity ct -> WithCacheTime Identity ct
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
curTime) (ct -> Identity ct
forall a. a -> Identity a
Identity ct
ct)
IO MemUpdateAction -> Sem r MemUpdateAction
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO MemUpdateAction -> Sem r MemUpdateAction)
-> IO MemUpdateAction -> Sem r MemUpdateAction
forall a b. (a -> b) -> a -> b
$ STM MemUpdateAction -> IO MemUpdateAction
forall a. STM a -> IO a
C.atomically (STM MemUpdateAction -> IO MemUpdateAction)
-> STM MemUpdateAction -> IO MemUpdateAction
forall a b. (a -> b) -> a -> b
$ do
Map k (TMVar (Maybe (WithCacheTime Identity ct)))
m <- AtomicMemCache k ct
-> STM (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
forall a. TVar a -> STM a
C.readTVar AtomicMemCache k ct
cache
case k
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Maybe (TMVar (Maybe (WithCacheTime Identity ct)))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
key Map k (TMVar (Maybe (WithCacheTime Identity ct)))
m of
Nothing -> do
TMVar (Maybe (WithCacheTime Identity ct))
newTMV <- Maybe (WithCacheTime Identity ct)
-> STM (TMVar (Maybe (WithCacheTime Identity ct)))
forall a. a -> STM (TMVar a)
C.newTMVar (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just WithCacheTime Identity ct
wct)
AtomicMemCache k ct
-> (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct))))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
C.modifyTVar AtomicMemCache k ct
cache (k
-> TMVar (Maybe (WithCacheTime Identity ct))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
key TMVar (Maybe (WithCacheTime Identity ct))
newTMV)
MemUpdateAction -> STM MemUpdateAction
forall (m :: * -> *) a. Monad m => a -> m a
return MemUpdateAction
Filled
Just tmvM :: TMVar (Maybe (WithCacheTime Identity ct))
tmvM -> do
Bool
wasEmptyTMVar <- TMVar (Maybe (WithCacheTime Identity ct))
-> Maybe (WithCacheTime Identity ct) -> STM Bool
forall a. TMVar a -> a -> STM Bool
C.tryPutTMVar TMVar (Maybe (WithCacheTime Identity ct))
tmvM (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just WithCacheTime Identity ct
wct)
if Bool
wasEmptyTMVar
then MemUpdateAction -> STM MemUpdateAction
forall (m :: * -> *) a. Monad m => a -> m a
return MemUpdateAction
Filled
else (TMVar (Maybe (WithCacheTime Identity ct))
-> Maybe (WithCacheTime Identity ct)
-> STM (Maybe (WithCacheTime Identity ct))
forall a. TMVar a -> a -> STM a
C.swapTMVar TMVar (Maybe (WithCacheTime Identity ct))
tmvM (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just WithCacheTime Identity ct
wct)) STM (Maybe (WithCacheTime Identity ct))
-> STM MemUpdateAction -> STM MemUpdateAction
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MemUpdateAction -> STM MemUpdateAction
forall (m :: * -> *) a. Monad m => a -> m a
return MemUpdateAction
Replaced
case MemUpdateAction
updateAction of
Deleted -> LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "deleted"
Replaced -> LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "replaced"
Filled -> LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "filled"
{-# INLINEABLE atomicMemUpdate #-}
runAtomicInMemoryCache :: (Ord k
, Show k
, P.Member (P.Embed IO) r
, K.LogWithPrefixesLE r
)
=> AtomicMemCache k ct
-> P.InterpreterFor (Cache k ct) r
runAtomicInMemoryCache :: AtomicMemCache k ct -> InterpreterFor (Cache k ct) r
runAtomicInMemoryCache cache :: AtomicMemCache k ct
cache =
(forall x (m :: * -> *). Cache k ct m x -> Sem r x)
-> Sem (Cache k ct : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret ((forall x (m :: * -> *). Cache k ct m x -> Sem r x)
-> Sem (Cache k ct : r) a -> Sem r a)
-> (forall x (m :: * -> *). Cache k ct m x -> Sem r x)
-> Sem (Cache k ct : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
CacheLookup key -> AtomicMemCache k ct
-> k -> Sem r (Maybe (WithCacheTime Identity ct))
forall k (r :: [(* -> *) -> * -> *]) ct.
(Ord k, Show k, Member (Embed IO) r, LogWithPrefixesLE r) =>
AtomicMemCache k ct
-> k -> Sem r (Maybe (WithCacheTime Identity ct))
atomicMemLookup AtomicMemCache k ct
cache k
key
CacheUpdate key mct -> AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
forall k (r :: [(* -> *) -> * -> *]) ct.
(Ord k, Show k, Member (Embed IO) r, LogWithPrefixesLE r) =>
AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
atomicMemUpdate AtomicMemCache k ct
cache k
key Maybe ct
mct
{-# INLINEABLE runAtomicInMemoryCache #-}
atomicMemLookupB :: (Ord k
, P.Members '[P.Embed IO, Cache k ct] r
, K.LogWithPrefixesLE r
, Show k
)
=> AtomicMemCache k ct
-> k
-> P.Sem r (Maybe (WithCacheTime Identity ct))
atomicMemLookupB :: AtomicMemCache k ct
-> k -> Sem r (Maybe (WithCacheTime Identity ct))
atomicMemLookupB cache :: AtomicMemCache k ct
cache key :: k
key = Text
-> Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "atomicMemLookupB" (Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct)))
-> Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ do
let keyText :: Text
keyText = "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": "
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "checking in mem cache..."
Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
x <- IO
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
-> Sem
r
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
-> Sem
r
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)))
-> IO
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
-> Sem
r
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
-> IO
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall a. STM a -> IO a
C.atomically (STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
-> IO
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)))
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
-> IO
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ do
Maybe (TMVar (Maybe (WithCacheTime Identity ct)))
mTMV <- k
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Maybe (TMVar (Maybe (WithCacheTime Identity ct)))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
key (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Maybe (TMVar (Maybe (WithCacheTime Identity ct))))
-> STM (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
-> STM (Maybe (TMVar (Maybe (WithCacheTime Identity ct))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AtomicMemCache k ct
-> STM (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
forall a. TVar a -> STM a
C.readTVar AtomicMemCache k ct
cache
case Maybe (TMVar (Maybe (WithCacheTime Identity ct)))
mTMV of
Just tmv :: TMVar (Maybe (WithCacheTime Identity ct))
tmv -> do
Maybe (WithCacheTime Identity ct)
mv <- TMVar (Maybe (WithCacheTime Identity ct))
-> STM (Maybe (WithCacheTime Identity ct))
forall a. TMVar a -> STM a
C.takeTMVar TMVar (Maybe (WithCacheTime Identity ct))
tmv
case Maybe (WithCacheTime Identity ct)
mv of
Just wct :: WithCacheTime Identity ct
wct -> do
TMVar (Maybe (WithCacheTime Identity ct))
-> Maybe (WithCacheTime Identity ct) -> STM ()
forall a. TMVar a -> a -> STM ()
C.putTMVar TMVar (Maybe (WithCacheTime Identity ct))
tmv (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just WithCacheTime Identity ct
wct)
Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)))
-> Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ WithCacheTime Identity ct
-> Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
forall a b. b -> Either a b
Right WithCacheTime Identity ct
wct
Nothing -> Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)))
-> Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (WithCacheTime Identity ct))
-> Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
forall a b. a -> Either a b
Left TMVar (Maybe (WithCacheTime Identity ct))
tmv
Nothing -> do
TMVar (Maybe (WithCacheTime Identity ct))
newTMV <- STM (TMVar (Maybe (WithCacheTime Identity ct)))
forall a. STM (TMVar a)
C.newEmptyTMVar
AtomicMemCache k ct
-> (Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct))))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
C.modifyTVar AtomicMemCache k ct
cache (k
-> TMVar (Maybe (WithCacheTime Identity ct))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> Map k (TMVar (Maybe (WithCacheTime Identity ct)))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
key TMVar (Maybe (WithCacheTime Identity ct))
newTMV)
Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)))
-> Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
-> STM
(Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (WithCacheTime Identity ct))
-> Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
forall a b. a -> Either a b
Left TMVar (Maybe (WithCacheTime Identity ct))
newTMV
case Either
(TMVar (Maybe (WithCacheTime Identity ct)))
(WithCacheTime Identity ct)
x of
Right wct :: WithCacheTime Identity ct
wct -> LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "found.") Sem r ()
-> Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (WithCacheTime Identity ct)
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just WithCacheTime Identity ct
wct)
Left emptyTMV :: TMVar (Maybe (WithCacheTime Identity ct))
emptyTMV -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "not found. Holding empty TMVar. Checking backup cache...")
Maybe (WithCacheTime Identity ct)
inOtherM <- k -> Sem r (Maybe (WithCacheTime Identity ct))
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Sem r (Maybe (WithCacheTime Identity v))
cacheLookup k
key
case Maybe (WithCacheTime Identity ct)
inOtherM of
Nothing -> LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "not found in backup cache.") Sem r ()
-> Sem r (Maybe (WithCacheTime Identity ct))
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (WithCacheTime Identity ct)
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WithCacheTime Identity ct)
forall a. Maybe a
Nothing
Just (WithCacheTime tM :: Maybe UTCTime
tM mct :: Identity ct
mct) -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Found in backup cache. Filling empty TMVar.")
let ct :: ct
ct = Identity ct -> ct
forall a. Identity a -> a
runIdentity Identity ct
mct
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
C.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe (WithCacheTime Identity ct))
-> Maybe (WithCacheTime Identity ct) -> STM ()
forall a. TMVar a -> a -> STM ()
C.putTMVar TMVar (Maybe (WithCacheTime Identity ct))
emptyTMV (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct))
-> WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> Identity ct -> WithCacheTime Identity ct
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
tM (ct -> Identity ct
forall a. a -> Identity a
Identity ct
ct))
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Returning")
Maybe (WithCacheTime Identity ct)
-> Sem r (Maybe (WithCacheTime Identity ct))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WithCacheTime Identity ct)
-> Sem r (Maybe (WithCacheTime Identity ct)))
-> Maybe (WithCacheTime Identity ct)
-> Sem r (Maybe (WithCacheTime Identity ct))
forall a b. (a -> b) -> a -> b
$ WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a. a -> Maybe a
Just (WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct))
-> WithCacheTime Identity ct -> Maybe (WithCacheTime Identity ct)
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> Identity ct -> WithCacheTime Identity ct
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime Maybe UTCTime
tM (ct -> Identity ct
forall (f :: * -> *) a. Applicative f => a -> f a
pure ct
ct)
{-# INLINEABLE atomicMemLookupB #-}
atomicMemUpdateB :: (Ord k
, Show k
, K.LogWithPrefixesLE r
, P.Members '[P.Embed IO, Cache k ct] r)
=> AtomicMemCache k ct
-> k
-> Maybe ct
-> P.Sem r ()
atomicMemUpdateB :: AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
atomicMemUpdateB cache :: AtomicMemCache k ct
cache key :: k
key mct :: Maybe ct
mct = Text -> Sem r () -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "atomicMemUpdateB" (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
let keyText :: Text
keyText = "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": "
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Calling atomicMemUpdate"
AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
forall k (r :: [(* -> *) -> * -> *]) ct.
(Ord k, Show k, Member (Embed IO) r, LogWithPrefixesLE r) =>
AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
atomicMemUpdate AtomicMemCache k ct
cache k
key Maybe ct
mct
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Calling cacheUpdate in backup cache."
k -> Maybe ct -> Sem r ()
forall k v (r :: [(* -> *) -> * -> *]).
MemberWithError (Cache k v) r =>
k -> Maybe v -> Sem r ()
cacheUpdate k
key Maybe ct
mct
{-# INLINEABLE atomicMemUpdateB #-}
runBackedAtomicInMemoryCache :: (Ord k
, Show k
, K.LogWithPrefixesLE r
, P.Members '[P.Embed IO, Cache k ct] r
)
=> AtomicMemCache k ct
-> P.InterpreterFor (Cache k ct) r
runBackedAtomicInMemoryCache :: AtomicMemCache k ct -> InterpreterFor (Cache k ct) r
runBackedAtomicInMemoryCache cache :: AtomicMemCache k ct
cache =
(forall x (m :: * -> *). Cache k ct m x -> Sem r x)
-> Sem (Cache k ct : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret ((forall x (m :: * -> *). Cache k ct m x -> Sem r x)
-> Sem (Cache k ct : r) a -> Sem r a)
-> (forall x (m :: * -> *). Cache k ct m x -> Sem r x)
-> Sem (Cache k ct : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
CacheLookup k -> AtomicMemCache k ct
-> k -> Sem r (Maybe (WithCacheTime Identity ct))
forall k ct (r :: [(* -> *) -> * -> *]).
(Ord k, Members '[Embed IO, Cache k ct] r, LogWithPrefixesLE r,
Show k) =>
AtomicMemCache k ct
-> k -> Sem r (Maybe (WithCacheTime Identity ct))
atomicMemLookupB AtomicMemCache k ct
cache k
k
CacheUpdate k mct -> AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
forall k (r :: [(* -> *) -> * -> *]) ct.
(Ord k, Show k, LogWithPrefixesLE r,
Members '[Embed IO, Cache k ct] r) =>
AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
atomicMemUpdateB AtomicMemCache k ct
cache k
k Maybe ct
mct
{-# INLINEABLE runBackedAtomicInMemoryCache #-}
backedAtomicInMemoryCache :: (Ord k
, Show k
, P.Member (P.Embed IO) r
, K.LogWithPrefixesLE r
)
=> AtomicMemCache k ct
-> P.Sem ((Cache k ct) ': r) a
-> P.Sem ((Cache k ct) ': r) a
backedAtomicInMemoryCache :: AtomicMemCache k ct
-> Sem (Cache k ct : r) a -> Sem (Cache k ct : r) a
backedAtomicInMemoryCache cache :: AtomicMemCache k ct
cache =
(forall (m :: * -> *) x. Cache k ct m x -> Sem (Cache k ct : r) x)
-> Sem (Cache k ct : r) a -> Sem (Cache k ct : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
(r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (m :: * -> *) x. e1 m x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret ((forall (m :: * -> *) x. Cache k ct m x -> Sem (Cache k ct : r) x)
-> Sem (Cache k ct : r) a -> Sem (Cache k ct : r) a)
-> (forall (m :: * -> *) x.
Cache k ct m x -> Sem (Cache k ct : r) x)
-> Sem (Cache k ct : r) a
-> Sem (Cache k ct : r) a
forall a b. (a -> b) -> a -> b
$ \case
CacheLookup k -> AtomicMemCache k ct
-> k -> Sem (Cache k ct : r) (Maybe (WithCacheTime Identity ct))
forall k ct (r :: [(* -> *) -> * -> *]).
(Ord k, Members '[Embed IO, Cache k ct] r, LogWithPrefixesLE r,
Show k) =>
AtomicMemCache k ct
-> k -> Sem r (Maybe (WithCacheTime Identity ct))
atomicMemLookupB AtomicMemCache k ct
cache k
k
CacheUpdate k mct -> AtomicMemCache k ct -> k -> Maybe ct -> Sem (Cache k ct : r) ()
forall k (r :: [(* -> *) -> * -> *]) ct.
(Ord k, Show k, LogWithPrefixesLE r,
Members '[Embed IO, Cache k ct] r) =>
AtomicMemCache k ct -> k -> Maybe ct -> Sem r ()
atomicMemUpdateB AtomicMemCache k ct
cache k
k Maybe ct
mct
{-# INLINEABLE backedAtomicInMemoryCache #-}
runPersistenceBackedAtomicInMemoryCache :: (Ord k
, Show k
, P.Member (P.Embed IO) r
, P.MemberWithError (P.Error CacheError) r
, K.LogWithPrefixesLE r
)
=> P.InterpreterFor (Cache k ct) r
-> AtomicMemCache k ct
-> P.InterpreterFor (Cache k ct) r
runPersistenceBackedAtomicInMemoryCache :: InterpreterFor (Cache k ct) r
-> AtomicMemCache k ct -> InterpreterFor (Cache k ct) r
runPersistenceBackedAtomicInMemoryCache runPersistentCache :: InterpreterFor (Cache k ct) r
runPersistentCache cache :: AtomicMemCache k ct
cache = Sem (Cache k ct : r) a -> Sem r a
InterpreterFor (Cache k ct) r
runPersistentCache (Sem (Cache k ct : r) a -> Sem r a)
-> (Sem (Cache k ct : r) a -> Sem (Cache k ct : r) a)
-> Sem (Cache k ct : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AtomicMemCache k ct
-> Sem (Cache k ct : r) a -> Sem (Cache k ct : r) a
forall k (r :: [(* -> *) -> * -> *]) ct a.
(Ord k, Show k, Member (Embed IO) r, LogWithPrefixesLE r) =>
AtomicMemCache k ct
-> Sem (Cache k ct : r) a -> Sem (Cache k ct : r) a
backedAtomicInMemoryCache AtomicMemCache k ct
cache
{-# INLINEABLE runPersistenceBackedAtomicInMemoryCache #-}
runPersistenceBackedAtomicInMemoryCache' :: (Ord k
, Show k
, P.Member (P.Embed IO) r
, P.MemberWithError (P.Error CacheError) r
, K.LogWithPrefixesLE r
)
=> P.InterpreterFor (Cache k ct) r
-> P.InterpreterFor (Cache k ct) r
runPersistenceBackedAtomicInMemoryCache' :: InterpreterFor (Cache k ct) r -> InterpreterFor (Cache k ct) r
runPersistenceBackedAtomicInMemoryCache' runPersistentCache :: InterpreterFor (Cache k ct) r
runPersistentCache x :: Sem (Cache k ct : r) a
x = do
TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
cache <- IO (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
-> Sem r (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
-> Sem
r (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct))))))
-> IO (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
-> Sem r (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
forall a b. (a -> b) -> a -> b
$ STM (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
-> IO (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
forall a. STM a -> IO a
C.atomically (STM (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
-> IO (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct))))))
-> STM (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
-> IO (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
forall a b. (a -> b) -> a -> b
$ Map k (TMVar (Maybe (WithCacheTime Identity ct)))
-> STM (TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct)))))
forall a. a -> STM (TVar a)
C.newTVar Map k (TMVar (Maybe (WithCacheTime Identity ct)))
forall a. Monoid a => a
mempty
InterpreterFor (Cache k ct) r
-> TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
-> Sem (Cache k ct : r) a
-> Sem r a
forall k (r :: [(* -> *) -> * -> *]) ct.
(Ord k, Show k, Member (Embed IO) r,
MemberWithError (Error CacheError) r, LogWithPrefixesLE r) =>
InterpreterFor (Cache k ct) r
-> AtomicMemCache k ct -> InterpreterFor (Cache k ct) r
runPersistenceBackedAtomicInMemoryCache InterpreterFor (Cache k ct) r
runPersistentCache TVar (Map k (TMVar (Maybe (WithCacheTime Identity ct))))
cache Sem (Cache k ct : r) a
x
{-# INLINEABLE runPersistenceBackedAtomicInMemoryCache' #-}
persistStreamlyByteArray
:: (Show k, P.Member (P.Embed IO) r, P.MemberWithError (P.Error CacheError) r, K.LogWithPrefixesLE r)
=> (k -> FilePath)
-> P.InterpreterFor (Cache k (Streamly.Array.Array Word.Word8)) r
persistStreamlyByteArray :: (k -> String) -> InterpreterFor (Cache k (Array Word8)) r
persistStreamlyByteArray keyToFilePath :: k -> String
keyToFilePath =
(forall x (m :: * -> *). Cache k (Array Word8) m x -> Sem r x)
-> Sem (Cache k (Array Word8) : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret ((forall x (m :: * -> *). Cache k (Array Word8) m x -> Sem r x)
-> Sem (Cache k (Array Word8) : r) a -> Sem r a)
-> (forall x (m :: * -> *). Cache k (Array Word8) m x -> Sem r x)
-> Sem (Cache k (Array Word8) : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
CacheLookup k -> Text
-> Sem r (Maybe (WithCacheTime Identity (Array Word8)))
-> Sem r (Maybe (WithCacheTime Identity (Array Word8)))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "persistAsByteArray.CacheLookup" (Sem r (Maybe (WithCacheTime Identity (Array Word8))) -> Sem r x)
-> Sem r (Maybe (WithCacheTime Identity (Array Word8))) -> Sem r x
forall a b. (a -> b) -> a -> b
$ do
let filePath :: String
filePath = k -> String
keyToFilePath k
k
(String -> IO (Array Word8))
-> String -> Sem r (Maybe (WithCacheTime Identity (Array Word8)))
forall (r :: [(* -> *) -> * -> *]) a.
(Members '[Embed IO] r, MemberWithError (Error CacheError) r,
LogWithPrefixesLE r) =>
(String -> IO a)
-> String -> Sem r (Maybe (WithCacheTime Identity a))
getContentsWithCacheTime (SerialT IO Word8 -> IO (Array Word8)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
SerialT m a -> m (Array a)
Streamly.Array.fromStream (SerialT IO Word8 -> IO (Array Word8))
-> (String -> SerialT IO Word8) -> String -> IO (Array Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SerialT IO Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(IsStream t, MonadCatch m, MonadIO m) =>
String -> t m Word8
Streamly.File.toBytes) String
filePath
CacheUpdate k mct -> Text -> Sem r () -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "persistAsByteStreamly.CacheUpdate" (Sem r () -> Sem r x) -> Sem r () -> Sem r x
forall a b. (a -> b) -> a -> b
$ do
let keyText :: Text
keyText = "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": "
case Maybe (Array Word8)
mct of
Nothing -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "called with Nothing. Deleting file."
IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
(Member (Embed IO) r, MemberWithError (Error CacheError) r) =>
IO a -> Sem r a
rethrowIOErrorAsCacheError (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
System.removeFile (k -> String
keyToFilePath k
k)
Just ct :: Array Word8
ct -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "called with content. Writing file."
let filePath :: String
filePath = (k -> String
keyToFilePath k
k)
(dirPath :: Text
dirPath, _) = Text -> Text -> (Text, Text)
T.breakOnEnd "/" (String -> Text
T.pack String
filePath)
()
_ <- Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(Members '[Embed IO] r, LogWithPrefixesLE r) =>
Text -> Sem r ()
createDirIfNecessary Text
dirPath
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity "Writing serialization to disk."
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Writing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Array Word8 -> Int
forall a. Storable a => Array a -> Int
Streamly.Array.length Array Word8
ct) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " bytes to disk."
IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
(Member (Embed IO) r, MemberWithError (Error CacheError) r) =>
IO a -> Sem r a
rethrowIOErrorAsCacheError (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> Array Word8 -> IO ()
forall a. Storable a => String -> Array a -> IO ()
Streamly.File.writeArray String
filePath Array Word8
ct
{-# INLINEABLE persistStreamlyByteArray #-}
persistStrictByteString
:: (P.Members '[P.Embed IO] r, P.MemberWithError (P.Error CacheError) r, K.LogWithPrefixesLE r, Show k)
=> (k -> FilePath)
-> P.InterpreterFor (Cache k BS.ByteString) r
persistStrictByteString :: (k -> String) -> InterpreterFor (Cache k ByteString) r
persistStrictByteString keyToFilePath :: k -> String
keyToFilePath =
(forall x (m :: * -> *). Cache k ByteString m x -> Sem r x)
-> Sem (Cache k ByteString : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret ((forall x (m :: * -> *). Cache k ByteString m x -> Sem r x)
-> Sem (Cache k ByteString : r) a -> Sem r a)
-> (forall x (m :: * -> *). Cache k ByteString m x -> Sem r x)
-> Sem (Cache k ByteString : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
CacheLookup k -> Text
-> Sem r (Maybe (WithCacheTime Identity ByteString))
-> Sem r (Maybe (WithCacheTime Identity ByteString))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "persistStrictByteString.CacheLookup" (Sem r (Maybe (WithCacheTime Identity ByteString)) -> Sem r x)
-> Sem r (Maybe (WithCacheTime Identity ByteString)) -> Sem r x
forall a b. (a -> b) -> a -> b
$ (String -> IO ByteString)
-> String -> Sem r (Maybe (WithCacheTime Identity ByteString))
forall (r :: [(* -> *) -> * -> *]) a.
(Members '[Embed IO] r, MemberWithError (Error CacheError) r,
LogWithPrefixesLE r) =>
(String -> IO a)
-> String -> Sem r (Maybe (WithCacheTime Identity a))
getContentsWithCacheTime String -> IO ByteString
BS.readFile (k -> String
keyToFilePath k
k)
CacheUpdate k mct -> Text -> Sem r () -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "persistStrictByteString.CacheUpdate" (Sem r () -> Sem r x) -> Sem r () -> Sem r x
forall a b. (a -> b) -> a -> b
$ do
let keyText :: Text
keyText = "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": "
case Maybe ByteString
mct of
Nothing -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "called with Nothing. Deleting file."
IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
(Member (Embed IO) r, MemberWithError (Error CacheError) r) =>
IO a -> Sem r a
rethrowIOErrorAsCacheError (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
System.removeFile (k -> String
keyToFilePath k
k)
Just ct :: ByteString
ct -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "called with content. Writing file."
let filePath :: String
filePath = (k -> String
keyToFilePath k
k)
(dirPath :: Text
dirPath, _) = Text -> Text -> (Text, Text)
T.breakOnEnd "/" (String -> Text
T.pack String
filePath)
()
_ <- Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(Members '[Embed IO] r, LogWithPrefixesLE r) =>
Text -> Sem r ()
createDirIfNecessary Text
dirPath
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Writing serialization to disk."
let bsLength :: Int
bsLength = ByteString -> Int
BS.length ByteString
ct
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Writing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
bsLength) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " bytes to disk."
IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
(Member (Embed IO) r, MemberWithError (Error CacheError) r) =>
IO a -> Sem r a
rethrowIOErrorAsCacheError (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
filePath ByteString
ct
{-# INLINEABLE persistStrictByteString #-}
persistLazyByteString
:: (P.Members '[P.Embed IO] r, P.MemberWithError (P.Error CacheError) r, K.LogWithPrefixesLE r, Show k)
=> (k -> FilePath)
-> P.InterpreterFor (Cache k BL.ByteString) r
persistLazyByteString :: (k -> String) -> InterpreterFor (Cache k ByteString) r
persistLazyByteString keyToFilePath :: k -> String
keyToFilePath =
(forall x (m :: * -> *). Cache k ByteString m x -> Sem r x)
-> Sem (Cache k ByteString : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret ((forall x (m :: * -> *). Cache k ByteString m x -> Sem r x)
-> Sem (Cache k ByteString : r) a -> Sem r a)
-> (forall x (m :: * -> *). Cache k ByteString m x -> Sem r x)
-> Sem (Cache k ByteString : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
CacheLookup k -> Text
-> Sem r (Maybe (WithCacheTime Identity ByteString))
-> Sem r (Maybe (WithCacheTime Identity ByteString))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "persistAsLazyByteString.CacheLookup" (Sem r (Maybe (WithCacheTime Identity ByteString)) -> Sem r x)
-> Sem r (Maybe (WithCacheTime Identity ByteString)) -> Sem r x
forall a b. (a -> b) -> a -> b
$ (String -> IO ByteString)
-> String -> Sem r (Maybe (WithCacheTime Identity ByteString))
forall (r :: [(* -> *) -> * -> *]) a.
(Members '[Embed IO] r, MemberWithError (Error CacheError) r,
LogWithPrefixesLE r) =>
(String -> IO a)
-> String -> Sem r (Maybe (WithCacheTime Identity a))
getContentsWithCacheTime String -> IO ByteString
BL.readFile (k -> String
keyToFilePath k
k)
CacheUpdate k mct -> Text -> Sem r () -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "persistAsLazyByteString.CacheUpdate" (Sem r () -> Sem r x) -> Sem r () -> Sem r x
forall a b. (a -> b) -> a -> b
$ do
let keyText :: Text
keyText = "key=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": "
case Maybe ByteString
mct of
Nothing -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "called with Nothing. Deleting file."
IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
(Member (Embed IO) r, MemberWithError (Error CacheError) r) =>
IO a -> Sem r a
rethrowIOErrorAsCacheError (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
System.removeFile (k -> String
keyToFilePath k
k)
Just ct :: ByteString
ct -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "called with content. Writing file."
let filePath :: String
filePath = (k -> String
keyToFilePath k
k)
(dirPath :: Text
dirPath, _) = Text -> Text -> (Text, Text)
T.breakOnEnd "/" (String -> Text
T.pack String
filePath)
()
_ <- Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(Members '[Embed IO] r, LogWithPrefixesLE r) =>
Text -> Sem r ()
createDirIfNecessary Text
dirPath
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity "Writing serialization to disk."
let bsLength :: Int64
bsLength = ByteString -> Int64
BL.length ByteString
ct
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Writing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
bsLength) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " bytes to disk."
IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
(Member (Embed IO) r, MemberWithError (Error CacheError) r) =>
IO a -> Sem r a
rethrowIOErrorAsCacheError (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BL.writeFile String
filePath ByteString
ct
{-# INLINEABLE persistLazyByteString #-}
createDirIfNecessary
:: (P.Members '[P.Embed IO] r, K.LogWithPrefixesLE r)
=> T.Text
-> P.Sem r ()
createDirIfNecessary :: Text -> Sem r ()
createDirIfNecessary dir :: Text
dir = Text -> Sem r () -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "createDirIfNecessary" (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Checking if cache path (\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\") exists."
Bool
existsB <- IO Bool -> Sem r Bool
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Bool -> Sem r Bool) -> IO Bool -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool
System.doesDirectoryExist (Text -> String
T.unpack Text
dir))
case Bool
existsB of
True -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Diagnostic (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" exists."
() -> Sem r ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
False -> do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
K.Info
(Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Cache directory (\""
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dir
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\") not found. Atttempting to create."
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed
(IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
System.createDirectoryIfMissing Bool
True (Text -> String
T.unpack Text
dir)
{-# INLINEABLE createDirIfNecessary #-}
getContentsWithCacheTime :: (P.Members '[P.Embed IO] r
, P.MemberWithError (P.Error CacheError) r
, K.LogWithPrefixesLE r)
=> (FilePath -> IO a)
-> FilePath
-> P.Sem r (Maybe (WithCacheTime Identity a))
getContentsWithCacheTime :: (String -> IO a)
-> String -> Sem r (Maybe (WithCacheTime Identity a))
getContentsWithCacheTime f :: String -> IO a
f fp :: String
fp = Text
-> Sem r (Maybe (WithCacheTime Identity a))
-> Sem r (Maybe (WithCacheTime Identity a))
forall (effs :: [(* -> *) -> * -> *]) a.
Member PrefixLog effs =>
Text -> Sem effs a -> Sem effs a
K.wrapPrefix "getContentsWithCacheTime" (Sem r (Maybe (WithCacheTime Identity a))
-> Sem r (Maybe (WithCacheTime Identity a)))
-> Sem r (Maybe (WithCacheTime Identity a))
-> Sem r (Maybe (WithCacheTime Identity a))
forall a b. (a -> b) -> a -> b
$ do
LogSeverity -> Text -> Sem r ()
forall (effs :: [(* -> *) -> * -> *]).
Member (Logger LogEntry) effs =>
LogSeverity -> Text -> Sem effs ()
K.logLE LogSeverity
debugLogSeverity (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Reading serialization from disk."
IO (Maybe (WithCacheTime Identity a))
-> Sem r (Maybe (WithCacheTime Identity a))
forall (r :: [(* -> *) -> * -> *]) a.
(Member (Embed IO) r, MemberWithError (Error CacheError) r) =>
IO a -> Sem r a
rethrowIOErrorAsCacheError (IO (Maybe (WithCacheTime Identity a))
-> Sem r (Maybe (WithCacheTime Identity a)))
-> IO (Maybe (WithCacheTime Identity a))
-> Sem r (Maybe (WithCacheTime Identity a))
forall a b. (a -> b) -> a -> b
$ IO (WithCacheTime Identity a)
-> IO (Maybe (WithCacheTime Identity a))
forall a. IO a -> IO (Maybe a)
fileNotFoundToMaybe (IO (WithCacheTime Identity a)
-> IO (Maybe (WithCacheTime Identity a)))
-> IO (WithCacheTime Identity a)
-> IO (Maybe (WithCacheTime Identity a))
forall a b. (a -> b) -> a -> b
$ do
a
ct <- String -> IO a
f String
fp
UTCTime
cTime <- String -> IO UTCTime
System.getModificationTime String
fp
WithCacheTime Identity a -> IO (WithCacheTime Identity a)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithCacheTime Identity a -> IO (WithCacheTime Identity a))
-> WithCacheTime Identity a -> IO (WithCacheTime Identity a)
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> Identity a -> WithCacheTime Identity a
forall k (m :: k -> *) (a :: k).
Maybe UTCTime -> m a -> WithCacheTime m a
WithCacheTime (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
cTime) (a -> Identity a
forall a. a -> Identity a
Identity a
ct)
{-# INLINE getContentsWithCacheTime #-}
fileNotFoundToEither :: IO a -> IO (Either () a)
fileNotFoundToEither :: IO a -> IO (Either () a)
fileNotFoundToEither x :: IO a
x = ((a -> Either () a) -> IO a -> IO (Either () a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either () a
forall a b. b -> Either a b
Right IO a
x) IO (Either () a)
-> (IOException -> IO (Either () a)) -> IO (Either () a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` IOException -> IO (Either () a)
forall a. IOException -> IO (Either () a)
f where
f :: Exception.IOException -> IO (Either () a)
f :: IOException -> IO (Either () a)
f e :: IOException
e = if IOException -> Bool
IO.Error.isDoesNotExistError IOException
e then Either () a -> IO (Either () a)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either () a
forall a b. a -> Either a b
Left ()) else IOException -> IO (Either () a)
forall a e. Exception e => e -> a
Exception.throw IOException
e
{-# INLINEABLE fileNotFoundToEither #-}
fileNotFoundToMaybe :: IO a -> IO (Maybe a)
fileNotFoundToMaybe :: IO a -> IO (Maybe a)
fileNotFoundToMaybe x :: IO a
x = ((a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
x) IO (Maybe a) -> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` IOException -> IO (Maybe a)
forall a. IOException -> IO (Maybe a)
f where
f :: Exception.IOException -> IO (Maybe a)
f :: IOException -> IO (Maybe a)
f e :: IOException
e = if IOException -> Bool
IO.Error.isDoesNotExistError IOException
e then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing else IOException -> IO (Maybe a)
forall a e. Exception e => e -> a
Exception.throw IOException
e
{-# INLINEABLE fileNotFoundToMaybe #-}
rethrowIOErrorAsCacheError :: (P.Member (P.Embed IO) r, P.MemberWithError (P.Error CacheError) r) => IO a -> P.Sem r a
rethrowIOErrorAsCacheError :: IO a -> Sem r a
rethrowIOErrorAsCacheError x :: IO a
x = (IOException -> CacheError) -> IO a -> Sem r a
forall exc err (r :: [(* -> *) -> * -> *]) a.
(Exception exc, Member (Error err) r, Member (Embed IO) r) =>
(exc -> err) -> IO a -> Sem r a
P.fromExceptionVia (\(IOException
e :: IO.Error.IOError) -> Text -> CacheError
PersistError (Text -> CacheError) -> Text -> CacheError
forall a b. (a -> b) -> a -> b
$ "IOError: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e)) IO a
x
{-# INLINEABLE rethrowIOErrorAsCacheError #-}