diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,16 @@ +# Revision history for cached-io + +## 1.2.0.0 + +Thank you [glasserc](https://github.com/glasserc) for your work on previous versions, and a special thanks to +[Arguggi](https://github.com/Arguggi) for contributing many of the improvements incorporated into this +version. + +- [Bellroy](https://github.com/bellroy) is the new maintainer of this package. See https://github.com/glasserc/haskell-cached-io/pull/1. +- New `cachedIO'` and `cachedIOWith'` support generating an action depending on the most recent cached value and its timestamp, if there was one. +- `cachedIO ttl f` can now be run in a different monad to `f`. Similarly for `cachedIO'`, `cachedIOWith`, `cachedIOWith'`. +- Fixes uncaught exceptions leaving the cache in a deadlocked state and other problems. + +## 1.1.0.0 and prior + +These versions were published by [glasserc](https://github.com/glasserc). diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# cached-io: cache a single IO action + +Sometimes you have an action that does something really expensive +whose results don't change that much. This is a simple library that +lets you cache the output of that expensive action for a +developer-specified length of time. + +`test/test-cachedIO.hs` shows a very basic usage example. + +## Developing this library + +All standardised tooling is provided by `flake.nix`. + +```shell +nix develop +``` + +### Formatting code + +| To format | use | +| --------- | -------------------------------------------------------------------------------------------- | +| `*.cabal` | [`cabal-fmt`](https://hackage.haskell.org/package/cabal-fmt) (`cabal-fmt --inplace *.cabal`) | +| `*.nix` | [`nixpkgs-fmt`](https://github.com/nix-community/nixpkgs-fmt) (`nixpkgs-fmt *.nix`) | + +We have not yet chosen a formatter for Haskell source. For now, try to follow +the style of surrounding code. + +### CI + +The GitHub Actions CI workflow for this repo is generated by [`haskell-ci`](https://github.com/haskell-CI/haskell-ci): + +```shell +haskell-ci regenerate +``` diff --git a/cached-io.cabal b/cached-io.cabal --- a/cached-io.cabal +++ b/cached-io.cabal @@ -1,60 +1,59 @@ --- Initial cached-io.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: cached-io -version: 1.1.0.0 -synopsis: - A simple library to cache a single IO action with timeout +cabal-version: 2.2 +name: cached-io +version: 1.2.0.0 +synopsis: A simple library to cache IO actions description: - A simple library that caches an expensive IO action. This produces an IO - action that, when run, either runs the expensive action and saves its result - for a period of time, or re-uses the saved value. This amortizes the cost of - the expensive IO action without a lot of complexity. + Provides functions that convert an IO action into a cached one by storing the + original result for a period of time, or until some condition is met. - See the test program for an example of how to use it. -license: Apache-2.0 -license-file: LICENSE -author: SumAll, Inc. -maintainer: eglassercamp@sumall.com --- copyright: -category: Development -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 +license: Apache-2.0 +license-file: LICENSE +author: SumAll, Inc. +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 +extra-source-files: + CHANGELOG.md + README.md source-repository head - type: git - location: git://github.com:SumAll/haskell-cached-io.git + type: git + location: https://github.com/bellroy/haskell-cached-io.git +common deps + build-depends: base >=4.13.0.0 && <4.18 + library - exposed-modules: Control.Concurrent.CachedIO - -- other-modules: - -- other-extensions: + import: deps + exposed-modules: Control.Concurrent.CachedIO build-depends: - base >= 4.8 && < 5.0, - stm, - transformers, - time - hs-source-dirs: src/ - default-language: Haskell2010 - ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind + , exceptions >=0.10.4 && <0.11 + , stm >=2.5 && <2.6 + , time >=1.9.3 && <1.13 + , transformers >=0.5.6.2 && <0.7 + + hs-source-dirs: src/ + default-language: Haskell2010 + ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind + if flag(developer) ghc-options: -Werror flag developer - manual: True - default: False - description: - compile with -Werror to make warnings fatal + manual: True + default: False + description: compile with -Werror to make warnings fatal executable test-cachedIO - main-is: test-cachedIO.hs - build-depends: - base >=4.8 && <5.0, - cached-io - hs-source-dirs: test/ - default-language: Haskell2010 - ghc-options: -threaded -rtsopts -fwarn-unused-imports -Wall + import: deps + main-is: test-cachedIO.hs + build-depends: cached-io + hs-source-dirs: test/ + default-language: Haskell2010 + ghc-options: + -threaded -rtsopts -fwarn-unused-imports -Wall -fno-warn-unused-do-bind + if flag(developer) ghc-options: -Werror diff --git a/src/Control/Concurrent/CachedIO.hs b/src/Control/Concurrent/CachedIO.hs --- a/src/Control/Concurrent/CachedIO.hs +++ b/src/Control/Concurrent/CachedIO.hs @@ -1,14 +1,32 @@ +-- | Example usage: +-- +-- > -- Downloads a large payload from an external data store. +-- > downloadData :: IO ByteString +-- > +-- > cachedDownloadData :: IO ByteString +-- > cachedDownloadData = cachedIO (secondsToNominalDiffTime 600) downloadData +-- +-- The first time @cachedDownloadData@ is called, it calls @downloadData@, +-- stores the result, and returns it. If it is called again: +-- +-- * before 10 minutes have passed, it returns the stored value. +-- * after 10 minutes have passed, it calls @downloadData@ and stores the +-- result again. +-- module Control.Concurrent.CachedIO ( cachedIO, - cachedIOWith + cachedIOWith, + cachedIO', + cachedIOWith' ) where -import Control.Concurrent.STM (atomically, newTVar, readTVar, writeTVar, retry) +import Control.Concurrent.STM (atomically, newTVar, readTVar, writeTVar, retry, TVar) import Control.Monad (join) +import Control.Monad.Catch (MonadCatch, onException) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Time.Clock (NominalDiffTime, addUTCTime, getCurrentTime, UTCTime) -data State = Uninitialized | Initializing +data State a = Uninitialized | Initializing | Updating a | Fresh UTCTime a -- | Cache an IO action, producing a version of this IO action that is cached -- for 'interval' seconds. The cache begins uninitialized. @@ -16,12 +34,25 @@ -- The outer IO is responsible for setting up the cache. Use the inner one to -- either get the cached value or refresh, if the cache is older than 'interval' -- seconds. -cachedIO :: (MonadIO m) +cachedIO :: (MonadIO m, MonadIO t, MonadCatch t) => NominalDiffTime -- ^ Number of seconds before refreshing cache - -> m a -- ^ IO action to cache - -> m (m a) + -> t a -- ^ IO action to cache + -> m (t a) cachedIO interval = cachedIOWith (secondsPassed interval) +-- | Cache an IO action, producing a version of this IO action that is cached +-- for 'interval' seconds. The cache begins uninitialized. +-- +-- The outer IO is responsible for setting up the cache. Use the inner one to +-- either get the cached value or refresh, if the cache is older than 'interval' +-- seconds. +cachedIO' :: (MonadIO m, MonadIO t, MonadCatch t) + => NominalDiffTime -- ^ Number of seconds before refreshing cache + -> (Maybe (UTCTime, a) -> t a) -- ^ action to cache. The stale value and its refresh date + -- are passed so that the action can perform external staleness checks + -> m (t a) +cachedIO' interval = cachedIOWith' (secondsPassed interval) + -- | Check if @starting time@ + @seconds@ is after @end time@ secondsPassed :: NominalDiffTime -- ^ Seconds -> UTCTime -- ^ Start time @@ -33,39 +64,60 @@ -- -- The outer IO is responsible for setting up the cache. Use the inner one to -- either get the cached value or refresh -cachedIOWith :: (MonadIO m) +cachedIOWith + :: (MonadIO m, MonadIO t, MonadCatch t) => (UTCTime -> UTCTime -> Bool) -- ^ Test function: -- If 'isCacheStillFresh' 'lastUpdated' 'now' returns 'True' -- the cache is considered still fresh and returns the cached IO action - -> m a -- ^ action to cache - -> m (m a) -cachedIOWith isCacheStillFresh io = do - initTime <- liftIO getCurrentTime - cachedT <- liftIO (atomically (newTVar (initTime, Left Uninitialized))) + -> t a -- ^ action to cache. + -> m (t a) +cachedIOWith f io = cachedIOWith' f (const io) + +-- | Cache an IO action, The cache begins uninitialized. +-- +-- The outer IO is responsible for setting up the cache. Use the inner one to +-- either get the cached value or refresh +cachedIOWith' + :: (MonadIO m, MonadIO t, MonadCatch t) + => (UTCTime -> UTCTime -> Bool) -- ^ Test function: + -- If 'isCacheStillFresh' 'lastUpdated' 'now' returns 'True' + -- the cache is considered still fresh and returns the cached IO action + -> (Maybe (UTCTime, a) -> t a) -- ^ action to cache. The stale value and its refresh date + -- are passed so that the action can perform external staleness checks + -> m (t a) +cachedIOWith' isCacheStillFresh io = do + cachedT <- liftIO (atomically (newTVar Uninitialized)) return $ do now <- liftIO getCurrentTime join . liftIO . atomically $ do cached <- readTVar cachedT case cached of + previousState@(Fresh lastUpdated value) -- There's data in the cache and it's recent. Just return. - (lastUpdated, Right value) | isCacheStillFresh lastUpdated now -> - return (return value) - -- There's data in the cache, but it's stale. Update the cache timestamp - -- to prevent a second thread from also executing the IO action. The second - -- thread would get the stale data instead. Refresh the cache and return. - (_, Right value) -> do - writeTVar cachedT (now, Right value) - return $ refreshCache now cachedT + | isCacheStillFresh lastUpdated now -> return (return value) + -- There's data in the cache, but it's stale. Update the cache state + -- to prevent a second thread from also executing the action. The second + -- thread will get the stale data instead. + | otherwise -> do + writeTVar cachedT (Updating value) + return $ refreshCache previousState cachedT + -- Another thread is already updating the cache, just return the stale value + Updating value -> return (return value) -- The cache is uninitialized. Mark the cache as initializing to block other -- threads. Initialize and return. - (_, Left Uninitialized) -> do - writeTVar cachedT (now, Left Initializing) - return $ refreshCache now cachedT + Uninitialized -> return $ refreshCache Uninitialized cachedT -- The cache is uninitialized and another thread is already attempting to -- initialize it. Block. - (_, Left Initializing) -> retry + Initializing -> retry where - refreshCache now cachedT = do - newValue <- io - liftIO (atomically (writeTVar cachedT (now, Right newValue))) + refreshCache previousState cachedT = do + let previous = case previousState of + Fresh lastUpdated value -> Just (lastUpdated, value) + _ -> Nothing + newValue <- io previous `onException` restoreState previousState cachedT + now <- liftIO getCurrentTime + liftIO (atomically (writeTVar cachedT (Fresh now newValue))) liftIO (return newValue) + +restoreState :: (MonadIO m) => State a -> TVar (State a) -> m () +restoreState previousState cachedT = liftIO (atomically (writeTVar cachedT previousState))