diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,23 @@ +# Changelog for `shared-resource-cache` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - 2026-03-22 + +### Added + +- Initial release +- `makeGlobalResourceCache` for caches that live for the lifetime of the program +- `makeResourceCache` for caches with a scoped lifetime managed via `resourcet` +- `getCacheableResource` to retrieve (and load if necessary) a cached resource +- `withCacheableResource` as a convenience wrapper around `getCacheableResource` +- `peekCacheableResource` to retrieve a cached resource without loading it if absent +- `withPeekCacheableResource` to peek at a cached resource within an STM transaction +- Background sweep thread to periodically evict expired, unused cache entries +- Reference counting via STM to track active sharers of each cached resource diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Gordon Martin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# shared-resource-cache + +A cache designed for guaranteeing that different threads can share the same reference to a resource. For example, it allows threads to communicate via a shared +[TChan broadcast channel](https://hackage.haskell.org/package/stm-2.5.3.1/docs/Control-Concurrent-STM-TChan.html). +Using [resourcet](https://hackage.haskell.org/package/resourcet), items are only removed from the cache after no 'sharers' are holding the +resource and the item has expired (according to the expiry configuration the cache was constructed with.) + +Note: an MVar is used to coordinate between threads that only one thread does the initial load of the resource with the given IO action if multiple +threads try and retrieve a resource that is not yet cached at the same time. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/shared-resource-cache.cabal b/shared-resource-cache.cabal new file mode 100644 --- /dev/null +++ b/shared-resource-cache.cabal @@ -0,0 +1,72 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.0. +-- +-- see: https://github.com/sol/hpack + +name: shared-resource-cache +version: 0.1.0.0 +synopsis: A thread-safe cache for sharing resources across threads with automatic expiry +description: A cache designed for guaranteeing that different threads can share the same reference to a resource. For example, it allows threads to communicate via a shared + <>. + Using <>, items are only removed from the cache after no 'sharers' are holding the + resource and the item has expired (according to the expiry configuration the cache was constructed with.) + . + Note: an MVar is used to coordinate between threads that only one thread does the initial load of the resource with the given IO action if multiple + threads try and retrieve a resource that is not yet cached at the same time. +category: Concurrency +homepage: https://github.com/happy0/shared-resource-cache#readme +bug-reports: https://github.com/happy0/shared-resource-cache/issues +author: Gordon Martin +maintainer: gordonhughmartin@gmail.com +copyright: 2026 Gordon Martin +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/happy0/shared-resource-cache + +library + exposed-modules: + Data.SharedResourceCache + other-modules: + Data.SharedResourceCache.Internal.CacheItem + Data.SharedResourceCache.Internal.Broom + Data.SharedResourceCache.Internal.ExpiringSharedResourceCache + Data.SharedResourceCache.Internal.Model + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , list-t ==1.0.* + , resourcet ==1.3.* + , stm >=2.4 && <2.6 + , stm-containers >=1.2 && <2 + , text >=2.0 && <2.2 + , time >=1.12 && <2 + default-language: Haskell2010 + +test-suite shared-resource-cache-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_shared_resource_cache + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , list-t ==1.0.* + , resourcet ==1.3.* + , shared-resource-cache + , stm >=2.4 && <2.6 + , stm-containers >=1.2 && <2 + , text >=2.0 && <2.2 + , time >=1.12 && <2 + default-language: Haskell2010 diff --git a/src/Data/SharedResourceCache.hs b/src/Data/SharedResourceCache.hs new file mode 100644 --- /dev/null +++ b/src/Data/SharedResourceCache.hs @@ -0,0 +1,137 @@ +{-# 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.Text ( Text ) +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(..)) + +-- | 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 + :: (Text -> IO (Either err a)) -- The action to load the given resource by ID + -> Maybe (a -> 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 err a) +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 :: (MonadResource m) => (Text -> IO (Either err a)) -> Maybe (a -> IO ()) -> CacheExpiryConfig -> m (ReleaseKey, SharedResourceCache err a) +makeSharedResourceCache loadResourceOp onRemoval cacheExpiryConfig = do + allocate (allocateResource loadResourceOp onRemoval) deallocateResource + where + allocateResource :: (Text -> IO (Either err a)) -> Maybe (a -> IO ()) -> IO (SharedResourceCache err a) + allocateResource loadOp removal = makeGlobalSharedResourceCache loadOp removal cacheExpiryConfig + + deallocateResource :: SharedResourceCache err a -> IO () + deallocateResource cache = do + let threadId = cacheCleanupThreadId cache + 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 :: SharedResourceCache err a -> Text -> (Either err a -> 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 +-- acquire a MVar will take ownership of loading it and signal to any other threads waiting for the resource that it has been loaded. +-- +-- 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 :: (MonadResource m) => SharedResourceCache err a -> Text -> m (ReleaseKey, Either err a) +getCacheableResource resourceCache resourceId = do + (releaseKey, cacheEntry) <- allocate (allocateResource resourceCache resourceId) (deAllocateResource resourceCache) + return (releaseKey, cacheItem <$> cacheEntry) + where + allocateResource :: SharedResourceCache err a -> Text -> IO (Either err (CacheItem a)) + allocateResource = loadCacheableResource + + deAllocateResource :: SharedResourceCache err a -> Either err (CacheItem a) -> 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 :: MonadResource m => SharedResourceCache err a -> Text -> m (ReleaseKey, Maybe a) +peekCacheableResource resourceCache resourceId = do + (releaseKey, cacheEntry) <- allocate (allocateResource resourceCache resourceId) (deAllocateResource resourceCache) + return (releaseKey, cacheItem <$> cacheEntry) + where + allocateResource :: SharedResourceCache err a -> Text -> IO (Maybe (CacheItem a)) + 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 err a -> Maybe (CacheItem a) -> 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 :: SharedResourceCache err a -> Text -> (Maybe a -> 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 diff --git a/src/Data/SharedResourceCache/Internal/Broom.hs b/src/Data/SharedResourceCache/Internal/Broom.hs new file mode 100644 --- /dev/null +++ b/src/Data/SharedResourceCache/Internal/Broom.hs @@ -0,0 +1,56 @@ +module Data.SharedResourceCache.Internal.Broom (startBroomLoop, removeIfStale, scheduleCacheCleanup, removeScheduledCleanup) where + import qualified StmContainers.Map as M + import Data.Text (Text) + import Data.Time.Clock (NominalDiffTime, UTCTime) + import Control.Concurrent.STM (STM) + import Control.Monad (forever, when) + import Control.Monad.STM (atomically) + import Data.SharedResourceCache.Internal.CacheItem (numberOfSharers, CacheItem (cacheItem)) + import Control.Concurrent (threadDelay) + import ListT (traverse_) + import Data.Time (addUTCTime, getCurrentTime) + import Data.SharedResourceCache.Internal.Model (CacheEntry (..), CacheExpiryConfig (..)) + + startBroomLoop :: M.Map Text (CacheEntry err a) -> M.Map Text UTCTime -> Maybe (a -> IO ()) -> Int -> IO () + startBroomLoop resourceCache cleanUpMap onRemove sweepIntervalSeconds = forever $ do + now <- getCurrentTime + -- We use 'listTNonAtomic since we do the removal itself atomically (followed by an IO action) and + -- if we miss an entry due to a stale view on the current iteration we can remove it in a later iteration + traverse_ (removeIfStale now resourceCache cleanUpMap onRemove) (M.listTNonAtomic cleanUpMap) + threadDelay (sweepIntervalSeconds * 1000000) + + removeIfStale :: UTCTime -> M.Map Text (CacheEntry err a) -> M.Map Text UTCTime -> Maybe (a -> IO ()) -> (Text, UTCTime) -> IO () + removeIfStale now cache cleanUpMap onRemove (resourceId, cacheExpiryTime) = + when (now >= cacheExpiryTime) $ do + removed <- atomically $ removeIfNoSharers cache cleanUpMap resourceId + case (removed, onRemove) of + (Just removedItem, Just onRemovalFunction) -> onRemovalFunction removedItem + _ -> return () + where + removeIfNoSharers :: M.Map Text (CacheEntry err a) -> M.Map Text UTCTime -> Text -> STM (Maybe a) + removeIfNoSharers cache cleanupMap resourceId = do + resource <- M.lookup resourceId cache + case resource of + Just (LoadedEntry cached) -> do + sharers <- numberOfSharers cached + + if sharers == 0 + then do + removeFromCache cache resourceId + removeScheduledCleanup cleanupMap resourceId + return (Just (cacheItem cached)) + else + return Nothing + _ -> pure Nothing + + removeFromCache :: M.Map Text (CacheEntry err a) -> Text -> STM () + removeFromCache resourceCache resourceId = M.delete resourceId resourceCache + + scheduleCacheCleanup :: M.Map Text UTCTime -> CacheExpiryConfig -> UTCTime -> Text -> STM () + scheduleCacheCleanup cleanUpMap (CacheExpiryConfig _ itemEligibleForRemovalAfterUnusedSeconds) now resourceId = do + let eligibleForRemovalSeconds = fromIntegral itemEligibleForRemovalAfterUnusedSeconds :: NominalDiffTime + M.insert (addUTCTime eligibleForRemovalSeconds now) resourceId cleanUpMap + + removeScheduledCleanup :: M.Map Text UTCTime -> Text -> STM () + removeScheduledCleanup cleanUpMap resourceId = M.delete resourceId cleanUpMap + diff --git a/src/Data/SharedResourceCache/Internal/CacheItem.hs b/src/Data/SharedResourceCache/Internal/CacheItem.hs new file mode 100644 --- /dev/null +++ b/src/Data/SharedResourceCache/Internal/CacheItem.hs @@ -0,0 +1,14 @@ +module Data.SharedResourceCache.Internal.CacheItem (CacheItem(..), increaseSharersByOne, decreaseSharersByOne, numberOfSharers) where + import Control.Concurrent.STM (TVar, STM, modifyTVar') + import Control.Concurrent.STM.TVar (readTVar) + + data CacheItem a = CacheItem {cacheItem :: a, connections :: TVar Int} + + increaseSharersByOne :: CacheItem a -> STM Int + increaseSharersByOne (CacheItem item connections) = modifyTVar' connections (+ 1) >> readTVar connections + + decreaseSharersByOne :: CacheItem a -> STM Int + decreaseSharersByOne (CacheItem item connections) = modifyTVar' connections (\item -> item - 1) >> readTVar connections + + numberOfSharers :: CacheItem a -> STM Int + numberOfSharers (CacheItem item connections) = readTVar connections diff --git a/src/Data/SharedResourceCache/Internal/ExpiringSharedResourceCache.hs b/src/Data/SharedResourceCache/Internal/ExpiringSharedResourceCache.hs new file mode 100644 --- /dev/null +++ b/src/Data/SharedResourceCache/Internal/ExpiringSharedResourceCache.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.SharedResourceCache.Internal.ExpiringSharedResourceCache (CacheEntry(..), SharedResourceCache(..), CacheExpiryConfig, loadCacheableResource, handleSharerLeave, handleSharerLeaveSTM, handlerSharerJoin) where + import Data.SharedResourceCache.Internal.CacheItem (CacheItem (CacheItem), decreaseSharersByOne, increaseSharersByOne) + import Control.Concurrent ( MVar, ThreadId, putMVar, readMVar ) + import qualified StmContainers.Map as M + import Data.Text (Text) + import Data.Time (UTCTime) + import Control.Concurrent.STM (STM) + import Control.Exception ( mask, + uninterruptibleMask_, finally ) + import Control.Monad.STM (atomically) + + import Control.Monad (void, when) + import Data.SharedResourceCache.Internal.Broom (scheduleCacheCleanup, removeScheduledCleanup) + import Data.SharedResourceCache.Internal.Model (CacheExpiryConfig, CacheEntry (..)) + import Data.Time.Clock (getCurrentTime) + import Control.Concurrent.MVar (newEmptyMVar) + import Control.Concurrent.STM.TVar (newTVar) + + -- | A cache of resources that can be shared between multiple threads (such as a TChan broadcast channel.) + -- + data SharedResourceCache err a = SharedResourceCache { + cache :: M.Map Text (CacheEntry err a), + cleanUpMap :: M.Map Text UTCTime, + loadResourceOp :: Text -> IO (Either err a), + onRemoval :: Maybe (a -> IO ()), + cacheCleanupThreadId :: ThreadId, + cacheExpiryConfig :: CacheExpiryConfig + } + + handlerSharerJoin :: SharedResourceCache err a -> CacheItem a -> Text -> STM () + handlerSharerJoin cache cacheItem resourceId = do + void $ increaseSharersByOne cacheItem + removeScheduledCleanup (cleanUpMap cache) resourceId + + handleSharerLeave :: SharedResourceCache err a -> CacheItem a -> Text -> IO () + handleSharerLeave cache cacheItem resourceId = do + now <- getCurrentTime + atomically (handleSharerLeaveSTM cache cacheItem resourceId now) + + handleSharerLeaveSTM :: SharedResourceCache err a -> CacheItem a -> Text -> UTCTime -> STM () + handleSharerLeaveSTM (SharedResourceCache cache cleanUpMap _ _ _ config) cacheItem resourceId now = do + newSharerCount <- decreaseSharersByOne cacheItem + when (newSharerCount == 0) $ void (scheduleCacheCleanup cleanUpMap config now resourceId) + + loadCacheableResource :: SharedResourceCache err a -> Text -> IO (Either err (CacheItem a)) + loadCacheableResource resourceCache@(SharedResourceCache cache _ loadResourceOp _ _ _) resourceId = do + existingItem <- atomically $ do + item <- M.lookup resourceId cache + case item of + Nothing -> pure Nothing + Just result@(LoadingEntry loadingMVar) -> pure (Just result) + Just result@(LoadedEntry resource) -> do + handlerSharerJoin resourceCache resource resourceId + pure (Just result) + + case existingItem of + Just (LoadedEntry item) -> pure $ Right item + Just (LoadingEntry loadedSignalMVar) -> do + -- Wait the for the other thread that is already loading the resource to signal that it has loaded the item + -- into the cache then recursively start again + readMVar loadedSignalMVar + loadCacheableResource resourceCache resourceId + Nothing -> loadFreshlyIntoCache resourceCache resourceId + + loadFreshlyIntoCache :: SharedResourceCache err a -> Text -> IO (Either err (CacheItem a)) + loadFreshlyIntoCache resourceCache@(SharedResourceCache cache _ loadResourceOp _ _ _) resourceId = + -- We run this operation in mask so that we aren't left with a permanent loading claim in the cache if the thread is interrupted + mask $ (\restore -> do + maybeSemaphore <- takeOwnershipOfLoad resourceCache resourceId + + case maybeSemaphore of + -- Already loaded or loading in another thread, recursively start again + Nothing -> restore $ loadCacheableResource resourceCache resourceId + + -- We've claimed ownership of loading the item into the cache + Just semaphore -> + restore (loadIntoCache resourceCache resourceId semaphore) + `finally` uninterruptibleMask_ (removeLoadingClaim resourceCache resourceId >> signalCacheLoaded semaphore) + ) + + where + signalCacheLoaded semaphore = putMVar semaphore () + + -- Returns a Just if we took ownership and Nothing if a thread is already loading the item or it has already been fully loaded + takeOwnershipOfLoad :: SharedResourceCache err a -> Text -> IO (Maybe (MVar ())) + takeOwnershipOfLoad resourceCache@(SharedResourceCache cache _ loadResourceOp _ _ _) resourceId = do + signal <- newEmptyMVar + atomically $ do + cachedItem <- M.lookup resourceId cache + case cachedItem of + Nothing -> do + let entry = LoadingEntry signal + M.insert entry resourceId cache + pure (Just signal) + _ -> pure Nothing + + loadIntoCache :: SharedResourceCache err a -> Text -> MVar () -> IO (Either err (CacheItem a)) + loadIntoCache resourceCache@(SharedResourceCache cache _ loadResourceOp _ _ _) resourceId _ = do + resourceLoadResult <- loadResourceOp resourceId + case resourceLoadResult of + Right resource -> putIntoCache resourceCache resourceId resource + Left err -> pure (Left err) + + putIntoCache :: SharedResourceCache err a -> Text -> a -> IO (Either err (CacheItem a)) + putIntoCache resourceCache@(SharedResourceCache cache _ loadResourceOp _ _ _) resourceId resource = do + atomically $ do + connections <- newTVar 0 + let entry = CacheItem resource connections + handlerSharerJoin resourceCache entry resourceId + M.insert (LoadedEntry entry) resourceId cache + pure (Right entry) + + removeLoadingClaim :: SharedResourceCache err a -> Text -> IO () + removeLoadingClaim resourceCache@(SharedResourceCache cache _ _ _ _ _) resourceId = atomically $ do + result <- M.lookup resourceId cache + + case result of + Just (LoadingEntry _) -> void (M.delete resourceId cache) + _ -> pure () diff --git a/src/Data/SharedResourceCache/Internal/Model.hs b/src/Data/SharedResourceCache/Internal/Model.hs new file mode 100644 --- /dev/null +++ b/src/Data/SharedResourceCache/Internal/Model.hs @@ -0,0 +1,14 @@ +module Data.SharedResourceCache.Internal.Model(CacheExpiryConfig(..), CacheEntry(..)) where + + import Control.Concurrent (MVar) + import Data.SharedResourceCache.Internal.CacheItem (CacheItem) + + -- | Configuration for managing when items can be removed from the cache when there are no more sharers + data CacheExpiryConfig = CacheExpiryConfig { + sweepIntervalSeconds :: Int, + -- ^ How often the cache's sweeper background thread should sweep the cache for expired entries with no sharers that are eligible for removal, in seconds + itemEligibleForRemovalAfterUnusedSeconds :: Int + -- ^ How long after a cache entry has had no sharers that it is eligible for removal from the cache by the sweeper background thread + } + + data CacheEntry err a = LoadedEntry (CacheItem a) | LoadingEntry (MVar ()) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"