{-# LANGUAGE ScopedTypeVariables #-}
-- | A cache that holds items (resources) while there are multiple threads using the
-- resource or until the item is eligible for removal with respect to the given cache
-- expiry configuration.
--
-- It is general purpose, but it is designed with the use case in mind where it is important that
-- different threads need to share the same resource instance (such as a TChan used for broadcasting messages
-- between threads)
module Data.SharedResourceCache (
makeSharedResourceCache,
makeGlobalSharedResourceCache,
withCacheableResource,
getCacheableResource,
SharedResourceCache,
peekCacheableResource,
withPeekCacheableResource,
CacheExpiryConfig(..)) where
import Control.Concurrent ( forkIO, killThread )
import Control.Concurrent.STM.TVar ()
import Control.Monad.STM ( STM, atomically )
import Data.Hashable (Hashable)
import Data.Time ( UTCTime )
import qualified StmContainers.Map as M
import Prelude
import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, runResourceT, allocate)
import Control.Monad.IO.Class (liftIO)
import Data.SharedResourceCache.Internal.CacheItem (CacheItem(..))
import Data.SharedResourceCache.Internal.ExpiringSharedResourceCache (CacheEntry(..), SharedResourceCache (..), CacheExpiryConfig, loadCacheableResource, handleSharerLeave, handlerSharerJoin, handleSharerLeaveSTM)
import Data.SharedResourceCache.Internal.Broom (startBroomLoop)
import Data.SharedResourceCache.Internal.Model (CacheExpiryConfig(..))
import Control.Exception (uninterruptibleMask_)
-- | Constructs a resource cache that is expected to be used for the lifetime of the program. Internally, it forks a thread to
-- manage periodically removing cache entries that have expired (as per the cache expiry configuration.)
makeGlobalSharedResourceCache
:: Hashable key
=> (key -> IO (Either err value)) -- ^ The action to load the given resource by ID. If the 'Either' result is a 'Left' or the IO action throws, the result is not stored in the cache
-> Maybe (value -> IO ()) -- ^ An action to be executed when the item is removed from the cache
-> CacheExpiryConfig -- ^ The configuration for when the cache item should be marked as expired and be eligible for removal from the cache
-> IO (SharedResourceCache key value err)
makeGlobalSharedResourceCache loadResourceOp onRemoval cacheExpiryConfig@(CacheExpiryConfig sweepIntervalSeconds _) = do
resourceCache <- M.newIO
cleanUpMap <- M.newIO
threadId <- forkIO $ startBroomLoop resourceCache cleanUpMap onRemoval sweepIntervalSeconds
pure $ SharedResourceCache resourceCache cleanUpMap loadResourceOp onRemoval threadId cacheExpiryConfig
-- | The same as 'makeGlobalSharedResourceCache' but intended for cases where the cache doesn't live for the lifetime of the program.
-- When the resource is freed (via MonadResource) the forked thread for cleaning the resource cache is killed.
makeSharedResourceCache :: forall key value err m. (MonadResource m, Hashable key) => (key -> IO (Either err value)) -> Maybe (value -> IO ()) -> CacheExpiryConfig -> m (ReleaseKey, SharedResourceCache key value err)
makeSharedResourceCache loadResourceOp onRemoval cacheExpiryConfig = do
allocate (allocateResource loadResourceOp onRemoval) deallocateResource
where
allocateResource :: (key -> IO (Either err value)) -> Maybe (value -> IO ()) -> IO (SharedResourceCache key value err)
allocateResource loadOp removal = makeGlobalSharedResourceCache loadOp removal cacheExpiryConfig
deallocateResource :: SharedResourceCache key value err -> IO ()
deallocateResource cache = do
let threadId = cacheCleanupThreadId cache
uninterruptibleMask_ (killThread threadId)
-- | Executes the given action using the resource with the given ID. This function is a wrapper around the 'getCacheableResource' function,
-- where the resource is freed at the end of the supplied action
withCacheableResource :: Hashable key => SharedResourceCache key value err -> key -> (Either err value -> IO ()) -> IO ()
withCacheableResource cache resourceId op =
runResourceT $ do
(_, cachedResource) <- getCacheableResource cache resourceId
liftIO $ op cachedResource
-- | Retrieves a cacheable resource with the given resource ID using the IO action configured
-- when the cache was constructed.
--
-- If the item is already loaded into the cache, it is returned. If it is not yet loaded, the first thread requesting this resource to
-- insert an MVar into the cache will take ownership of loading it and signal to any other threads waiting for the resource that it has been loaded
-- (or an error occurred.)
--
-- If the IO action throws an error or results a 'Left', the MVar is removed from the cache and another waiting thread (or a future call if there are
-- no current calls) can insert a new MVar to try to load the resource
--
-- This action is executed in the 'MonadResource' monad typeclass
-- context so that when the resource is freed, the cache can mark the cache item as having one less sharer.
--
-- When there are no sharers remaining, the cache item is scheduled for eviction according to the configuration that was used at cache
-- construction time
--
getCacheableResource :: forall key value err m. (MonadResource m, Hashable key) =>
SharedResourceCache key value err -> -- ^ The shared resource cache
key -> -- ^ The key of the resource to be loaded
m (ReleaseKey, Either err value) -- ^ The result of loading the resource and a release key to release the 'sharer' of the cache item early by calling 'Control.Monad.Trans.Resource.release' (this should be used with care to avoid an orphaned reference to a cache item that is no longer visible to other sharers.)
getCacheableResource resourceCache resourceId = do
(releaseKey, cacheEntry) <- allocate (allocateResource resourceCache resourceId) (deAllocateResource resourceCache)
return (releaseKey, cacheItem <$> cacheEntry)
where
allocateResource :: SharedResourceCache key value err -> key -> IO (Either err (CacheItem value))
allocateResource = loadCacheableResource
deAllocateResource :: SharedResourceCache key value err -> Either err (CacheItem value) -> IO ()
deAllocateResource resourceCache resource = do
case resource of
Left _ -> pure ()
Right sharedResource -> handleSharerLeave resourceCache sharedResource resourceId
-- | Returns the item if it's in the cache but does not load it into the cache if it is not present.
--
-- If there are no other sharers of the resource once the resource action has been run to completion
-- or the 'release key' is used to free it early then the item is scheduled for eviction from the cache.
peekCacheableResource :: forall key value err m. (MonadResource m, Hashable key) => SharedResourceCache key value err -> key -> m (ReleaseKey, Maybe value)
peekCacheableResource resourceCache resourceId = do
(releaseKey, cacheEntry) <- allocate (allocateResource resourceCache resourceId) (deAllocateResource resourceCache)
return (releaseKey, cacheItem <$> cacheEntry)
where
allocateResource :: SharedResourceCache key value err -> key -> IO (Maybe (CacheItem value))
allocateResource resourceCache resourceId = atomically $ do
item <- M.lookup resourceId (cache resourceCache)
case item of
Just (LoadedEntry cachedItem) -> do
handlerSharerJoin resourceCache cachedItem resourceId
pure (Just cachedItem)
_ -> pure Nothing
deAllocateResource :: SharedResourceCache key value err -> Maybe (CacheItem value) -> IO ()
deAllocateResource resourceCache resource =
case resource of
Nothing -> pure ()
Just sharedResource -> handleSharerLeave resourceCache sharedResource resourceId
-- | Executes the given action with a 'Just' if an item with the given resourceID is present in the cache,
-- otherwise executes it with Nothing
--
-- If there are no other sharers of the resource once the action is complete then the item is scheduled
-- for eviction
--
-- The 'now' parameter is used to schedule the item for eviction from the cache according to the
-- expiry config and should be the current time. It is required to be passed in as getting the current time
-- is an IO action that cannot be performed in an STM transaction.
withPeekCacheableResource :: Hashable key => SharedResourceCache key value err -> key -> (Maybe value -> STM b) -> UTCTime -> STM b
withPeekCacheableResource resourceCache resourceId action now = do
resource <- M.lookup resourceId (cache resourceCache)
case resource of
Just (LoadedEntry item) -> do
handlerSharerJoin resourceCache item resourceId
result <- action (Just (cacheItem item))
handleSharerLeaveSTM resourceCache item resourceId now
pure result
_ -> action Nothing