{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
module Data.Cache.Polling
(
MonadCache (..),
PollingCache,
CacheMiss (..),
CacheHit,
CacheResult,
FailureMode (..),
DelayMode (..),
ThreadDelay,
CacheOptions (delayMode, failureMode, delayFuzzing),
basicOptions,
newPollingCache,
cachedValue,
stopPolling,
)
where
import Control.Concurrent
import Control.Monad (unless)
import qualified Control.Monad.Catch as Exc
import Data.Cache.Internal
import Data.Functor ((<&>))
import Data.Time.Clock
import UnliftIO
data CacheMiss
=
NotYetLoaded
|
LoadFailed UTCTime
|
Stopped
deriving (CacheMiss -> CacheMiss -> Bool
(CacheMiss -> CacheMiss -> Bool)
-> (CacheMiss -> CacheMiss -> Bool) -> Eq CacheMiss
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheMiss -> CacheMiss -> Bool
$c/= :: CacheMiss -> CacheMiss -> Bool
== :: CacheMiss -> CacheMiss -> Bool
$c== :: CacheMiss -> CacheMiss -> Bool
Eq, Int -> CacheMiss -> ShowS
[CacheMiss] -> ShowS
CacheMiss -> String
(Int -> CacheMiss -> ShowS)
-> (CacheMiss -> String)
-> ([CacheMiss] -> ShowS)
-> Show CacheMiss
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheMiss] -> ShowS
$cshowList :: [CacheMiss] -> ShowS
show :: CacheMiss -> String
$cshow :: CacheMiss -> String
showsPrec :: Int -> CacheMiss -> ShowS
$cshowsPrec :: Int -> CacheMiss -> ShowS
Show)
type CacheHit a = (a, UTCTime)
type CacheResult a = Either CacheMiss (CacheHit a)
type CachePayload a = TVar (CacheResult a)
data PollingCache a = PollingCache
{ PollingCache a -> CachePayload a
mostRecentValues :: CachePayload a,
PollingCache a -> ThreadId
threadId :: ThreadId
}
type ThreadDelay = Int
isFailed :: CacheResult a -> Bool
isFailed :: CacheResult a -> Bool
isFailed (Left (LoadFailed UTCTime
_)) = Bool
True
isFailed CacheResult a
_ = Bool
False
writeCacheFailure :: MonadCache m => CachePayload a -> UTCTime -> m ()
writeCacheFailure :: CachePayload a -> UTCTime -> m ()
writeCacheFailure CachePayload a
payload = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> (UTCTime -> STM ()) -> UTCTime -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CachePayload a -> CacheResult a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar CachePayload a
payload (CacheResult a -> STM ())
-> (UTCTime -> CacheResult a) -> UTCTime -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheMiss -> CacheResult a
forall a b. a -> Either a b
Left (CacheMiss -> CacheResult a)
-> (UTCTime -> CacheMiss) -> UTCTime -> CacheResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> CacheMiss
LoadFailed
handleFailure :: MonadCache m => FailureMode -> CachePayload a -> m ()
handleFailure :: FailureMode -> CachePayload a -> m ()
handleFailure FailureMode
Ignore CachePayload a
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleFailure FailureMode
EvictImmediately CachePayload a
payload = do
UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadCache m => m UTCTime
currentTime
CacheResult a
current <- CachePayload a -> m (CacheResult a)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO CachePayload a
payload
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CacheResult a -> Bool
forall a. CacheResult a -> Bool
isFailed CacheResult a
current) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ CachePayload a -> UTCTime -> m ()
forall (m :: * -> *) a.
MonadCache m =>
CachePayload a -> UTCTime -> m ()
writeCacheFailure CachePayload a
payload UTCTime
now
handleFailure (EvictAfterTime NominalDiffTime
limit) CachePayload a
payload = do
CacheResult a
previousResult <- CachePayload a -> m (CacheResult a)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO CachePayload a
payload
UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadCache m => m UTCTime
currentTime
let failed :: Either CacheMiss Bool
failed = CacheResult a
previousResult CacheResult a
-> (CacheHit a -> UTCTime) -> Either CacheMiss UTCTime
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CacheHit a -> UTCTime
forall a b. (a, b) -> b
snd Either CacheMiss UTCTime
-> (UTCTime -> Bool) -> Either CacheMiss Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\UTCTime
prev -> UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
prev NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
limit)
case Either CacheMiss Bool
failed of
Right Bool
True -> CachePayload a -> UTCTime -> m ()
forall (m :: * -> *) a.
MonadCache m =>
CachePayload a -> UTCTime -> m ()
writeCacheFailure CachePayload a
payload UTCTime
now
Either CacheMiss Bool
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
clamp :: Int -> Int -> Int -> Int
clamp :: Int -> Int -> Int -> Int
clamp Int
mn Int
mx Int
val
| Int
val Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mn = Int
mn
| Int
val Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
mx = Int
mx
| Bool
otherwise = Int
val
handleDelay :: MonadCache m => DelayMode a -> Maybe Int -> Either SomeException a -> m ()
handleDelay :: DelayMode a -> Maybe Int -> Either SomeException a -> m ()
handleDelay DelayMode a
mode (Just Int
fuzz) Either SomeException a
res = do
Int
fuzzDelay <- (Int, Int) -> m Int
forall (m :: * -> *). MonadCache m => (Int, Int) -> m Int
randomize (Int
0, Int
fuzz)
Int -> m ()
forall (m :: * -> *). MonadCache m => Int -> m ()
delay Int
fuzzDelay
DelayMode a -> Either SomeException a -> m ()
forall (m :: * -> *) a.
MonadCache m =>
DelayMode a -> Either SomeException a -> m ()
handleDelay' DelayMode a
mode Either SomeException a
res
handleDelay DelayMode a
mode Maybe Int
Nothing Either SomeException a
res = DelayMode a -> Either SomeException a -> m ()
forall (m :: * -> *) a.
MonadCache m =>
DelayMode a -> Either SomeException a -> m ()
handleDelay' DelayMode a
mode Either SomeException a
res
handleDelay' :: MonadCache m => DelayMode a -> Either SomeException a -> m ()
handleDelay' :: DelayMode a -> Either SomeException a -> m ()
handleDelay' (DelayForMicroseconds Int
mics) Either SomeException a
_ = Int -> m ()
forall (m :: * -> *). MonadCache m => Int -> m ()
delay Int
mics
handleDelay' (DelayDynamically Either SomeException a -> Int
f) Either SomeException a
r = Int -> m ()
forall (m :: * -> *). MonadCache m => Int -> m ()
delay (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ Either SomeException a -> Int
f Either SomeException a
r
handleDelay' (DelayDynamicallyWithBounds (Int
mn, Int
mx) Either SomeException a -> Int
f) Either SomeException a
r =
Int -> m ()
forall (m :: * -> *). MonadCache m => Int -> m ()
delay (Int -> m ()) -> (Int -> Int) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int -> Int
clamp Int
mn Int
mx (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ Either SomeException a -> Int
f Either SomeException a
r
basicOptions :: DelayMode a -> FailureMode -> CacheOptions a
basicOptions :: DelayMode a -> FailureMode -> CacheOptions a
basicOptions DelayMode a
d FailureMode
f = DelayMode a -> FailureMode -> Maybe Int -> CacheOptions a
forall a. DelayMode a -> FailureMode -> Maybe Int -> CacheOptions a
CacheOptions DelayMode a
d FailureMode
f Maybe Int
forall a. Maybe a
Nothing
newPollingCache :: forall a m. MonadCache m => CacheOptions a -> m a -> m (PollingCache a)
newPollingCache :: CacheOptions a -> m a -> m (PollingCache a)
newPollingCache CacheOptions {Maybe Int
FailureMode
DelayMode a
delayFuzzing :: Maybe Int
failureMode :: FailureMode
delayMode :: DelayMode a
delayFuzzing :: forall a. CacheOptions a -> Maybe Int
failureMode :: forall a. CacheOptions a -> FailureMode
delayMode :: forall a. CacheOptions a -> DelayMode a
..} m a
generator = do
TVar (Either CacheMiss (CacheHit a))
tvar <- Either CacheMiss (CacheHit a)
-> m (TVar (Either CacheMiss (CacheHit a)))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Either CacheMiss (CacheHit a)
-> m (TVar (Either CacheMiss (CacheHit a))))
-> Either CacheMiss (CacheHit a)
-> m (TVar (Either CacheMiss (CacheHit a)))
forall a b. (a -> b) -> a -> b
$ CacheMiss -> Either CacheMiss (CacheHit a)
forall a b. a -> Either a b
Left CacheMiss
NotYetLoaded
ThreadId
tid <- m () -> m ThreadId
forall (m :: * -> *). MonadCache m => m () -> m ThreadId
newThread (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ TVar (Either CacheMiss (CacheHit a)) -> m ()
cacheThread TVar (Either CacheMiss (CacheHit a))
tvar
PollingCache a -> m (PollingCache a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PollingCache a -> m (PollingCache a))
-> PollingCache a -> m (PollingCache a)
forall a b. (a -> b) -> a -> b
$ TVar (Either CacheMiss (CacheHit a)) -> ThreadId -> PollingCache a
forall a. CachePayload a -> ThreadId -> PollingCache a
PollingCache TVar (Either CacheMiss (CacheHit a))
tvar ThreadId
tid
where
cacheThread :: CachePayload a -> m ()
cacheThread :: TVar (Either CacheMiss (CacheHit a)) -> m ()
cacheThread TVar (Either CacheMiss (CacheHit a))
tvar = m () -> m ()
forall (m :: * -> *). MonadCache m => m () -> m ()
repeatedly (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
(Either SomeException a
result :: Either SomeException a) <- m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Exc.try m a
generator
case Either SomeException a
result of
Left SomeException
_ -> FailureMode -> TVar (Either CacheMiss (CacheHit a)) -> m ()
forall (m :: * -> *) a.
MonadCache m =>
FailureMode -> CachePayload a -> m ()
handleFailure FailureMode
failureMode TVar (Either CacheMiss (CacheHit a))
tvar
Right a
value -> do
UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadCache m => m UTCTime
currentTime
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> (Either CacheMiss (CacheHit a) -> STM ())
-> Either CacheMiss (CacheHit a)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Either CacheMiss (CacheHit a))
-> Either CacheMiss (CacheHit a) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Either CacheMiss (CacheHit a))
tvar (Either CacheMiss (CacheHit a) -> m ())
-> Either CacheMiss (CacheHit a) -> m ()
forall a b. (a -> b) -> a -> b
$ CacheHit a -> Either CacheMiss (CacheHit a)
forall a b. b -> Either a b
Right (a
value, UTCTime
now)
DelayMode a -> Maybe Int -> Either SomeException a -> m ()
forall (m :: * -> *) a.
MonadCache m =>
DelayMode a -> Maybe Int -> Either SomeException a -> m ()
handleDelay DelayMode a
delayMode Maybe Int
delayFuzzing Either SomeException a
result
cachedValue :: MonadCache m => PollingCache a -> m (CacheResult a)
cachedValue :: PollingCache a -> m (CacheResult a)
cachedValue = TVar (CacheResult a) -> m (CacheResult a)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (CacheResult a) -> m (CacheResult a))
-> (PollingCache a -> TVar (CacheResult a))
-> PollingCache a
-> m (CacheResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PollingCache a -> TVar (CacheResult a)
forall a. PollingCache a -> CachePayload a
mostRecentValues
stopPolling :: MonadCache m => PollingCache a -> m ()
stopPolling :: PollingCache a -> m ()
stopPolling PollingCache {ThreadId
CachePayload a
threadId :: ThreadId
mostRecentValues :: CachePayload a
threadId :: forall a. PollingCache a -> ThreadId
mostRecentValues :: forall a. PollingCache a -> CachePayload a
..} = do
ThreadId -> m ()
forall (m :: * -> *). MonadCache m => ThreadId -> m ()
killCache ThreadId
threadId
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> (CacheResult a -> STM ()) -> CacheResult a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CachePayload a -> CacheResult a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar CachePayload a
mostRecentValues (CacheResult a -> m ()) -> CacheResult a -> m ()
forall a b. (a -> b) -> a -> b
$ CacheMiss -> CacheResult a
forall a b. a -> Either a b
Left CacheMiss
Stopped