{-# 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 #-} -- for Streamly
{-|
Module      : Knit.Effect.AtomicCache
Description : Effect for managing a persistent cache of serializable things to avoid redoing computations
Copyright   : (c) Adam Conner-Sax 2019
License     : BSD-3-Clause
Maintainer  : adam_conner_sax@yahoo.com
Stability   : experimental

This module defines a key/value store (Polysemy) effect. Rather than return the usual @Maybe v@ from a lookup,
the cache returns a @Maybe (WithCacheTime v)@, where @WithCacheTime a@ wraps a value of type a along with a
time-stamp (of type @UTCTime@). This module provides a thread-safe in-memory implementation as well as
a disk-based persistent implementation and a combination of the two, where the disk-based layer sits behind the
in-memory layer.  In our use case, the stored values will be arrays of bytes, the result of serializing
whatever data we wish to cache.

@WithCacheTime@ is intended to simplify tracking dependencies among cached computations.  For example, imagine
you have two long running computations which you wish to cache so you need only run those computations once:

@
computeA :: m a
computeA = ...

computeB :: m b
computeB = ...

cachedA :: WithCacheTime m a 
cachedA :: retrieveOrMake serialize "a.bin" (pure ()) (const computeA)

cachedB :: WithCacheTime m b
cachedB = retrieveOrMake serialize "b.bin" (pure ()) (const computeB)
@

and you have a computation which depends on @a@ and @b@ and should also be cached, but we
want to make sure it gets recomputed if either @a@ or @b@ do. We use the applicative instance of
@WithCacheTime@ to combine cached results into and inject them into later computations while
taking into account the newest time-stamp among the dependencies:

@
computeC :: a -> b -> m c
computeC a b = ...

cDeps :: WithCachedTime m (a, b)
cDeps = (,) <$> cachedA \<*\> cachedB

cachedC :: WithCacheTime m c
cachedC = retrieveOrMake serialize "c.bin" cDeps $ \\(a, b) -> computeC a b
@

As with @cachedA@ and @cachedB@, @cachedC@ will run the computation if the key, "c.bin" in this case,
is absent from the cache.
In addition, @cachedC@ will be recomputed even if it is in the cache, if the time-stamp of the cached value
is older than either the time stamp of @cachedA@ or @cachedB@.

@WithCacheTime m a@ holds the time-stamp and a monadic computation which will produce an @a@. This allows
deferral of the deserialization of cached data until we know that we need to use it.  In the example above,
suppose @a@ is retrieved from cache, and @b@ is computed fresh.  @cachedA@ holds a timestamp
(the modification time of the file in cache or the time a was cached in memory) and a monadic
computation which will deserialize the cached byte array retrieved for a.  @cachedB@ holds a time-stamp
(the time the computation of b completes) and the trivial monadic action @return b@.  Since @b@ was
just computed, the cached @c@ is outdated and will be recomputed.  At that point @a@ is deserialized, @b@
is unwrapped and thse are given to the function to compute @c@, which is then 
stored in cache as well as returned in the @WithCacheTime m c@, holding a new time-stamp.

If multiple threads attempt to lookup or 'retrieveOrMake' at the same key
at close to the same time, the first request will proceed,
loading from cache if possible, and the other threads will block until
the in-memory cache is populated or the first thread fails to fill in data.

This is intended to save CPU in the relatively common case that, e.g., several threads
are launched to analyze the same data.  The functions which load that data
from on-disk-cache or produce it from other analyses need only be run once.  Using the cache
to facilitate this sharing still requires each thread to deserialize the data.  If that cost is
significant, you may want to compute the data before launching the threads.

NB: Should the action given to create the data, the @(b -> m a)@ argument of 'retrieveOrMake' somehow
fail, this may lead to a situation where it runs on the first thread, fails, then runs on all the other threads
simultaneously, presumably failing all those times as well.  

<https://github.com/adamConnerSax/knit-haskell/tree/master/examples Examples> are available, and might be useful for seeing how all this works.
-}
module Knit.Effect.AtomicCache
  (
    -- * Effect
    Cache
    -- * Time Stamps
    -- ** Types
  , WithCacheTime
  , ActionWithCacheTime
    -- ** Constructors
  , withCacheTime
  , onlyCacheTime
    -- ** Combinators
  , ignoreCacheTime
  , ignoreCacheTimeM
  , cacheTime
    -- ** Utilities
  , wctMapAction  
    -- ** Cache Actions
  , encodeAndStore
  , retrieveAndDecode
  , lookupAndDecode
  , retrieveOrMake
  , clear
  , clearIfPresent
    -- * Effect Interpretations
    -- ** Persist To Disk
  , persistStreamlyByteArray
  , persistLazyByteString
  , persistStrictByteString
    -- ** Thread-safe Map
  , AtomicMemCache
  , runAtomicInMemoryCache
    -- ** Combined Map/Disk
  , runBackedAtomicInMemoryCache
  , runPersistenceBackedAtomicInMemoryCache
  , runPersistenceBackedAtomicInMemoryCache'
    -- * Exceptions
  , 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


{- TODO:
1. Can this design be simplified, part 1. The Maybe in the TMVar seems like it should be uneccessary.
2. It'd be nice to make sure we can't leave the empty TMVar. Can this be done in a way so that it must be filled?
3. We should be able to factor out some things around handling the returned TMVar
-}
-- | Error Type for Cache errors.  Simplifies catching and reporting them.
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)

-- | Wrapper to hold (deserializable, if necessary) content and a timestamp.
-- The stamp must be at or after the time the data was constructed
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 (<*>) #-}
{-
NB: The applicative instance allows merging dependencies
for passing to things which need them
as in:
let cachedDeps = (,,) <$> cached1 <*> cached2 <*> cached3

NB: There is no Monad instance for WithCacheTime.  We would need
'join :: WithCacheTime t1M (m (WithCacheTime t2M (m b)) -> WithCacheTime (max t1M t2M) (m b)
but we cannot get t2M "outside" m.
-}

-- | Specialize `WithCacheTime` for use with a Polysemy effects stack.
type ActionWithCacheTime r a = WithCacheTime (P.Sem r) a

-- | Construct a WithCacheTime with a time and no action.  
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 #-}

-- | Construct a WithCacheTime from a @Maybe Time.UTCTime@ and an action.
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 #-}

-- | Map one type of action to another via a natural transformation.
-- Specifically useful for mapping from @WithCacheTime Identity a@
-- to @WithCacheTime m a@
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 #-}

-- | Map one type of action to another.  NB: 'WithCacheTime m' is a functor
-- (as long as @m@ is), so if @m@ is not changing, you should prefer 'fmap'
-- to this function.  
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 #-}

-- | natural transformation which is useful for interoperation between
-- the cache storage and the values returned to the user.
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 #-}

-- | Access the computation part of a @WithCacheTime a@. This or
-- 'ignoreCacheTimeM' is required to use the cached value as anything but input
-- to another cached computation.
ignoreCacheTime :: WithCacheTime m a -> m a
ignoreCacheTime :: WithCacheTime m a -> m a
ignoreCacheTime (WithCacheTime _ ma :: m a
ma) = m a
ma
{-# INLINEABLE ignoreCacheTime #-}

-- | Access the computation part of an @m (WithCacheTime a)@. This or
-- 'ignoreCacheTime' is required to use the cached value as anything but input
-- to another cached computation.
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 #-}

-- | Access the @Maybe Time.UTCTime@ part of a 'WithCacheTime'
cacheTime :: WithCacheTime m a -> Maybe Time.UTCTime
cacheTime :: WithCacheTime m a -> Maybe UTCTime
cacheTime (WithCacheTime tM :: Maybe UTCTime
tM _) = Maybe UTCTime
tM
{-# INLINEABLE cacheTime #-}

-- | Key/Value store effect requiring its implementation to return values with time-stamps.
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 () -- NB: this requires some way to attach a cache time during update
  
P.makeSem ''Cache

debugLogSeverity :: K.LogSeverity
debugLogSeverity :: LogSeverity
debugLogSeverity  = Int -> LogSeverity
K.Debug 3
{-# INLINE debugLogSeverity #-}

-- | Combine the action of serializing and caching
encodeAndStore
  :: ( Show k
     , P.Member (Cache k ct) r
     , K.LogWithPrefixesLE r
     )
  => KS.Serialize CacheError r a ct -- ^ Record-Of-Functions for serialization/deserialization
  -> k                              -- ^ Key
  -> a                              -- ^ Data to encode and cache
  -> 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 #-}

-- | Lookup key and, if that fails, run an action to update the cache.
-- Further, if the item is in cache, but older than time-stamp of the
-- supplied 'ActionWithCacheTime r b', this function calls the given
-- @b -> P.Sem r (Maybe a)@ with the cached value from the supplied
-- 'ActionWithCacheTime m b'.

-- TODO: We need some exception handling here to make sure, in the case of an Atomic cache,
-- the TMVar gets filled somehow and the key deleted from cache.
-- NB: This returns an action with the cache time and another action to get the data.  This allows us
-- to defer deserialization (and maybe loading??) until we actually want to use the data...

-- IDEA: when too old, make new, retrieve old and compare?  If same, use older date? Costs time, but saves downstream rebuilds.
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            -- ^ Record-Of-Functions for serialization/deserialization
  -> (b -> P.Sem r (Maybe a))                  -- ^ Computation to run to make @a@ if cache is empty or expired.
  -> k                                         -- ^ Key
  -> ActionWithCacheTime r b                   -- ^ Cached dependencies of the computation.
  -> P.Sem r (Maybe (ActionWithCacheTime r a)) -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'. Returns 'Nothing" if lookup fails.
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 -- a' is the buffered version of a (if necessary)
            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 -- Should this come from the cache so the times are the same?  Or is it safe enough that this is later?
            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 --maybe True (\newest -> cTimeM > newest) newestM
          then do
            let ct :: ct
ct = Identity ct -> ct
forall a. Identity a -> a
runIdentity Identity ct
mct -- we do this out here only because we want the length.  We could defer this unpacking to the decodeAction
            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 -- a <- mct >>= decode
                   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 #-}  

-- | Combine the action of retrieving from cache and deserializing.
-- | Throws if item not found or any other error during retrieval
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    -- ^ Record-Of-Functions for serialization/deserialization
  -> k                                 -- ^ Key
  -> Maybe Time.UTCTime                -- ^ 'Time.UTCTime' which cached data must be newer than.  Use 'Nothing' if any cached data is acceptable.
  -> P.Sem r (ActionWithCacheTime r a) -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'. Throws 'CacheError' if lookup fails.
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 #-}

-- | Combine the action of retrieving from cache and deserializing.
-- | Returns @Nothing@ if item not found, and throws on any other error.
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            -- ^ Record-Of-Functions for serialization/deserialization
  -> k                                         -- ^ Key
  -> Maybe Time.UTCTime                        -- ^ 'Time.UTCTime' which cached data must be newer than.  Use 'Nothing' if any cached data is acceptable.
  -> P.Sem r (Maybe (ActionWithCacheTime r a)) -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'. Returns 'Nothing" if lookup fails.
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 #-}

-- | Lookup key and, if that fails, run an action to update the cache.
-- Further, if the item is in cache, but older than time-stamp of the
-- supplied 'ActionWithCacheTime r b', this function calls the given
-- @b -> P.Sem r (Maybe a)@ with the cached value from the supplied
-- 'ActionWithCacheTime m b'.
--  Throws if item not found *and* making fails.
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      -- ^ Record-Of-Functions for serialization/deserialization
  -> k                                   -- ^ Key 
  -> ActionWithCacheTime r b             -- ^ Cached Dependencies
  -> (b -> P.Sem r a)                    -- ^ Computation to produce @a@ if lookup fails.
  -> P.Sem r (ActionWithCacheTime r a)   -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'
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 the cache at a given key.  Throws an exception if item is not present.
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 #-}

-- | Clear the cache at a given key.  Doesn't throw if item is missing.
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 #-}

-- structure for in-memory atomic cache
-- outer TVar so only one thread can get the inner TMVar at a time
-- TMVar so we can block if mulitple threads are trying to read or update
-- the @Maybe@ inside so we can notify waiting threads that whatever they were waiting on
-- to fill the TMVar failed.

-- | Specific type of in-memory cache.  
type AtomicMemCache k v = C.TVar (M.Map k (C.TMVar (Maybe (WithCacheTime Identity v))))

-- | lookup combinator for in-memory AtomicMemCache
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 type to simplify logging in AtomicMemCache updates
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)

-- | update combinator for in-memory AtomicMemCache
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 #-}

-- | Interpreter for in-memory only AtomicMemCache
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 #-}


-- Backed by Another Cache
-- lookup is the hard case.  If we don't find it, we want to check the backup cache
-- and fill in this cache from there, if possible
-- | lookup for an AtomicMemCache which is backed by some other cache, probably a persistence layer.
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 -- in cache with value (and time)
            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  -- in cache but set to Nothing
      Nothing -> do -- not found
        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 #-}

-- | update for an AtomicMemCache which is backed by some other cache, probably a persistence layer.
-- This just does the update in both caches
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 #-}

-- | interpret Cache via a different-Cache-backed AtomicMemCache
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 #-}

-- | re-interpret Cache, using AtomicMemCache for in-memory store, into another cache, usually a persistent store.
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 #-} 


-- | Interpret Cache via AtomicMemCache and an interpreter for a backing cache,
-- usually a persistence layer.
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 -- persistence layer interpreter
                                        -> 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 #-}

-- | Interpret Cache via AtomicMemCache and an interpreter for a backing cache,
-- usually a persistence layer.  Create a new, empty, AtomicMemCache to begin.
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' #-}

-- | Interpreter for Cache via persistence to disk as a Streamly Memory.Array (Contiguous storage of Storables) of Bytes (Word8)
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 #-}

-- | Interpreter for Cache via persistence to disk as a strict ByteString
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  -- maybe we should do this in another thread?
{-# INLINEABLE persistStrictByteString #-}

-- | Interpreter for Cache via persistence to disk as a lazy ByteString
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  -- maybe we should do this in another thread?
{-# 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 #-}