{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}

-- | A cache implementation that periodically (and asynchronously) polls an external action for updated values.
module Data.Cache.Polling
  ( -- * Entry-point types and typeclasses
    MonadCache (..),
    PollingCache,

    -- * Types for working with cached results
    CacheMiss (..),
    CacheHit,
    CacheResult,

    -- * Types for cache creation
    FailureMode (..),
    DelayMode (..),
    ThreadDelay,
    CacheOptions (delayMode, failureMode, delayFuzzing),

    -- * Functions for creating and interacting with caches
    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

-- | The supported "empty" states for a 'PollingCache'.
--
-- See 'CacheResult' for a more in-depth explanation of why this is necessary.
data CacheMiss
  = -- | A value has never been loaded into the cache.
    NotYetLoaded
  | -- | The external action used to populate the cache threw an exception at some point in time.
    LoadFailed UTCTime
  | -- | The cache has been shut down and can no longer be used.
    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)

-- | A successfully cached value with the time at which it was generated.
type CacheHit a = (a, UTCTime)

-- | The result of reading a value from a 'PollingCache', including the possibility of failure.
--
-- Due to the asynchronous (and likely effectful) nature of executing external actions to populate
-- the cache, it's possible for the cache to be "empty" at any point in time. The possible empty
-- states are controlled by the 'FailureMode' selected by the user when creating the 'PollingCache'
-- instance.
type CacheResult a = Either CacheMiss (CacheHit a)

type CachePayload a = TVar (CacheResult a)

-- | An opaque type containing the internals necessary for background polling and caching.
--
-- Library functions will allow the user to create and interact with a 'PollingCache', but
-- the raw data is not exposed to users so that the library can maintain invariants.
data PollingCache a = PollingCache
  { PollingCache a -> CachePayload a
mostRecentValues :: CachePayload a,
    PollingCache a -> ThreadId
threadId :: ThreadId
  }

-- | The minimum amount of time (in microseconds) that should pass before a cache reload is attempted.
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

-- | Create a 'CacheOptions' with basic functionality enabled.
--
-- Record update syntax can be use to further customize options created using this function:
--
-- > basicOpts = basicOptions (DelayForMicroseconds 60000000) EvictImmediately
-- > customOpts = basicOpts { delayFuzzing = Just 100 }
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

-- | Creates a new 'PollingCache'.
--
-- The supplied action is used to generate values that are stored in the cache. The action is executed in the background
-- with its delay, failure, and fuzzing behavior controlled by the provided 'CacheOptions'.
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

-- | Retrieve the current values from a 'PollingCache'.
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

-- | Stops the background processing thread associated with a 'PollingCache'.
--
-- Calling this function will place the 'Stopped' value into the cache after stopping the processing thread,
-- ensuring that a 'PollingCache' that has been stopped can no longer be used to query stale values.
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