cached-io 1.3.0.0 → 1.3.1.0

raw patch · 4 files changed

+229/−99 lines, 4 filesdep +tastydep +tasty-hunitdep −transformersdep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: tasty, tasty-hunit

Dependencies removed: transformers

Dependency ranges changed: time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• cached-io.cabal +30/−17
• src/Control/Concurrent/CachedIO.hs +150/−62
• test/test-cachedIO.hs +43/−20

@@ -1,5 +1,11 @@ # Revision history for cached-io +## 1.3.1.0++- Add `cachedSTM` versions of all bindings.+- Correctly transition the internal state to `Initializing` when filling the cache for the first time.+- Remove unused `transformer` dependency+ ## 1.3.0.0  - **Breaking** Caching functions previously returned `m (t a)`, but it was easy to accidentally use `join` when `m` and `t` were the same monad (eg. `IO (IO a)`), and not get any caching at all. These functions now use a `Cached` newtype for `t a` to make it more difficult to misuse.

@@ -1,18 +1,27 @@-cabal-version:      2.2-name:               cached-io-version:            1.3.0.0-synopsis:           A simple library to cache IO actions+cabal-version:   2.2+name:            cached-io+version:         1.3.1.0+synopsis:        A simple library to cache IO actions description:   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. -license:            Apache-2.0-license-file:       LICENSE-author:             SumAll, Inc.-maintainer:         Bellroy Tech Team <haskell@bellroy.com>-category:           Development-build-type:         Simple-tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.5 || ==9.6.2 || ==9.8.1+license:         Apache-2.0+license-file:    LICENSE+author:          SumAll, Inc.+maintainer:      Bellroy Tech Team <haskell@bellroy.com>+category:        Development+build-type:      Simple+tested-with:+  GHC ==8.10.7+   || ==9.0.2+   || ==9.2.4+   || ==9.4.5+   || ==9.6.6+   || ==9.8.2+   || ==9.10.1+   || ==9.12.1+ extra-doc-files:   CHANGELOG.md   README.md@@ -22,16 +31,15 @@   location: https://github.com/bellroy/haskell-cached-io.git  common deps-  build-depends: base >=4.13.0.0 && <4.20+  build-depends: base >=4.13.0.0 && <4.22  library   import:           deps   exposed-modules:  Control.Concurrent.CachedIO   build-depends:-    , exceptions    >=0.10.4  && <0.11-    , stm           >=2.5     && <2.6-    , time          >=1.9.3   && <1.15-    , transformers  >=0.5.6.2 && <0.7+    , exceptions  >=0.10.4 && <0.11+    , stm         >=2.5    && <2.6+    , time        >=1.9.3  && <1.16    hs-source-dirs:   src/   default-language: Haskell2010@@ -45,8 +53,9 @@   default:     False   description: compile with -Werror to make warnings fatal -executable test-cachedIO+test-suite test-cachedIO   import:           deps+  type:             exitcode-stdio-1.0   main-is:          test-cachedIO.hs   build-depends:    cached-io   hs-source-dirs:   test/@@ -57,3 +66,7 @@    if flag(developer)     ghc-options: -Werror++  build-depends:+    , tasty        ^>=1.5+    , tasty-hunit  ^>=0.10.0.3

@@ -11,28 +11,46 @@ -- -- * 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 (-    Cached(..),+--   result again.+-- * @downloadData@ will not be called if a different thread is already calling+--   it. In that case, the stored value will be returned in the meantime.+module Control.Concurrent.CachedIO+  ( Cached (..),++    -- * IO     cachedIO,     cachedIOWith,     cachedIO',-    cachedIOWith'-    ) where+    cachedIOWith', -import Control.Concurrent.STM (atomically, newTVar, readTVar, writeTVar, retry, TVar)+    -- * STM+    -- $stm+    cachedSTM,+    cachedSTMWith,+    cachedSTM',+    cachedSTMWith',+  )+where++import Control.Concurrent.STM+  ( STM,+    atomically,+    newTVar,+    readTVar,+    retry,+    writeTVar,+  ) 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)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)  -- | A cached IO action in some monad @m@. Use 'runCached' to extract the action when you want to query it. -- -- Note that using 'Control.Monad.join' when the cached action and the outer monad are the same will ignore caching. newtype Cached m a = Cached {runCached :: m a} -data State a  = Uninitialized | Initializing | Updating a | Fresh UTCTime a+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.@@ -40,11 +58,14 @@ -- 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-         -> t a             -- ^ IO action to cache-         -> m (Cached t a)-cachedIO interval = cachedIOWith (secondsPassed interval)+cachedIO ::+  (MonadIO m, MonadIO t, MonadCatch t) =>+  -- | Number of seconds before refreshing cache+  NominalDiffTime ->+  -- | IO action to cache+  t a ->+  m (Cached t a)+cachedIO = cachedIOWith . secondsPassed  -- | Cache an IO action, producing a version of this IO action that is cached -- for 'interval' seconds. The cache begins uninitialized.@@ -52,66 +73,122 @@ -- 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 (Cached t a)-cachedIO' interval = cachedIOWith' (secondsPassed interval)---- | Check if @starting time@ + @seconds@ is after @end time@-secondsPassed :: NominalDiffTime  -- ^ Seconds-               -> UTCTime         -- ^ Start time-               -> UTCTime         -- ^ End time-               -> Bool-secondsPassed interval start end = addUTCTime interval start > end+cachedIO' ::+  (MonadIO m, MonadIO t, MonadCatch t) =>+  -- | Number of seconds before refreshing cache+  NominalDiffTime ->+  -- | action to cache. The stale value and its refresh date+  -- are passed so that the action can perform external staleness checks+  (Maybe (UTCTime, a) -> t a) ->+  m (Cached t a)+cachedIO' = cachedIOWith' . secondsPassed  -- | 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-    -> t a -- ^ action to cache.-    -> m (Cached t a)-cachedIOWith f io = cachedIOWith' f (const io)+cachedIOWith ::+  (MonadIO m, MonadIO t, MonadCatch t) =>+  -- | Test function:+  -- If @isCacheStillFresh lastUpdated now@ returns 'True',+  -- the cache is considered still fresh and returns the cached IO action+  (UTCTime -> UTCTime -> Bool) ->+  -- | Action to cache.+  t a ->+  m (Cached t a)+cachedIOWith f = cachedIOWith' f . const --- | Cache an IO action, The cache begins uninitialized.+-- | 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 (Cached t a)-cachedIOWith' isCacheStillFresh io = do-  cachedT <- liftIO (atomically (newTVar Uninitialized))+cachedIOWith' ::+  (MonadIO m, MonadIO t, MonadCatch t) =>+  -- | Test function:+  -- If 'isCacheStillFresh' 'lastUpdated' 'now' returns 'True'+  -- the cache is considered still fresh and returns the cached IO action+  (UTCTime -> UTCTime -> Bool) ->+  -- | Action to cache. The stale value and its refresh date+  -- are passed so that the action can perform external staleness checks+  (Maybe (UTCTime, a) -> t a) ->+  m (Cached t a)+cachedIOWith' isCacheStillFresh refreshAction =+  liftIO . atomically $ cachedSTMWith' isCacheStillFresh refreshAction++-- $stm+--+-- The following actions are the exactly same as the 'cachedIO' versions, except+-- that they do not leave the 'STM' monad during construction.++-- | Set up a cached IO action in a transaction; producing a version of this IO+-- action that is cached for 'interval' seconds. The cache begins uninitialized.+cachedSTM ::+  (MonadIO m, MonadCatch m) =>+  -- | Number of seconds before refreshing cache+  NominalDiffTime ->+  -- | IO action to cache+  m a ->+  STM (Cached m a)+cachedSTM = cachedSTMWith . secondsPassed++-- | Set up a cached IO action in a transaction; producing a version of this IO+-- action that is cached for 'interval' seconds. The cache begins uninitialized.+cachedSTM' ::+  (MonadIO m, MonadCatch m) =>+  -- | Number of seconds before refreshing cache+  NominalDiffTime ->+  -- | action to cache. The stale value and its refresh date+  -- are passed so that the action can perform external staleness checks+  (Maybe (UTCTime, a) -> m a) ->+  STM (Cached m a)+cachedSTM' = cachedSTMWith' . secondsPassed++-- | Set up a cached IO action in a transaction; The cache begins uninitialized.+cachedSTMWith ::+  (MonadIO m, MonadCatch m) =>+  -- | Test function:+  -- If @isCacheStillFresh lastUpdated now@ returns 'True',+  -- the cache is considered still fresh and returns the cached IO action+  (UTCTime -> UTCTime -> Bool) ->+  -- | Action to cache.+  m a ->+  STM (Cached m a)+cachedSTMWith f = cachedSTMWith' f . const++-- | Set up a cached IO action in a transaction; the cache begins uninitialized.+cachedSTMWith' ::+  (MonadIO m, MonadCatch m) =>+  -- | Test function:+  -- If @'isCacheStillFresh' lastUpdated now@ returns 'True'+  -- the cache is considered still fresh and returns the cached IO action+  (UTCTime -> UTCTime -> Bool) ->+  -- | Action to cache. The stale value and its refresh date+  -- are passed so that the action can perform external staleness checks+  (Maybe (UTCTime, a) -> m a) ->+  STM (Cached m a)+cachedSTMWith' isCacheStillFresh refreshAction = do+  cachedT <- newTVar Uninitialized   pure . Cached $ 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.-          | 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.+          -- There's data in the cache and it's recent. Just return.+          | isCacheStillFresh lastUpdated now -> pure (pure 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)-            pure (refreshCache previousState cachedT)+              writeTVar cachedT (Updating value)+              pure (refreshCache previousState cachedT)         -- Another thread is already updating the cache, just return the stale value         Updating value -> pure (pure value)         -- The cache is uninitialized. Mark the cache as initializing to block other         -- threads. Initialize and return.-        Uninitialized -> pure (refreshCache Uninitialized cachedT)+        Uninitialized -> do+          writeTVar cachedT Initializing+          pure (refreshCache Uninitialized cachedT)         -- The cache is uninitialized and another thread is already attempting to         -- initialize it. Block.         Initializing -> retry@@ -119,11 +196,22 @@     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)+            _ -> Nothing+      newValue <-+        refreshAction previous+          `onException` liftIO (atomically (writeTVar cachedT previousState))+      liftIO $ do+        now <- getCurrentTime+        atomically (writeTVar cachedT (Fresh now newValue))+        pure newValue -restoreState :: (MonadIO m) => State a -> TVar (State a) -> m ()-restoreState previousState cachedT = liftIO (atomically (writeTVar cachedT previousState))+-- | Check if @starting time@ + @seconds@ is after @end time@+secondsPassed ::+  -- | Seconds+  NominalDiffTime ->+  -- | Start time+  UTCTime ->+  -- | End time+  UTCTime ->+  Bool+secondsPassed interval start end = addUTCTime interval start > end

@@ -1,25 +1,48 @@-module Main (-    main-    ) where+module Main (main) where -import Control.Concurrent.CachedIO (cachedIO, Cached(..))-import Data.List (isInfixOf)+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.CachedIO (Cached (..), cachedIO)+import Data.Functor (void)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) -crawlTheInternet :: IO [String]-crawlTheInternet = do-    putStrLn "Scanning pages.."-    putStrLn "Parsing HTML.."-    putStrLn "Following links.."-    return ["website about Haskell", "website about Ruby", "slashdot.org",-            "The Monad.Reader", "haskellwiki"]+tests :: TestTree+tests =+  testGroup+    "Control.Concurrent.CachedIO"+    [ testCase "Action is not called until first use" $ do+        ref <- newIORef 0+        Cached {} <- cachedIO (5 * 60) $ increment ref+        count <- readIORef ref+        count @?= 0,+      testCase "Action is not called if value is fresh" $ do+        ref <- newIORef 0+        Cached action <- cachedIO (5 * 60) $ increment ref+        void action+        void action+        count <- readIORef ref+        count @?= 1,+      testCase "Action is not called if cache is initializing" $ do+        ref <- newIORef 0+        Cached action <- cachedIO (5 * 60) $ incrementSlow ref+        void . forkIO $ void action+        void action+        count <- readIORef ref+        count @?= 1+    ] -searchEngine :: String -> Cached IO [String] -> IO [String]-searchEngine query internet = do-    pages <- runCached internet-    return $ filter (query `isInfixOf`) pages+increment :: IORef Int -> IO Int+increment ref = atomicModifyIORef' ref (\i -> (succ i, i)) +incrementSlow :: IORef Int -> IO Int+incrementSlow ref = do+  res <- atomicModifyIORef' ref (\i -> (succ i, i))+  -- waiting AFTER the increase will show that Initialized is necessary+  -- because forking a thread takes enough time that the "action >> readIORef"+  -- are done before the forked thread has the chance to increment the counter.+  threadDelay $ 100 * 1000 -- 100 ms+  pure res+ main :: IO ()-main = do-    cachedInternet <- cachedIO 600 crawlTheInternet   -- 10 minute cache-    print =<< searchEngine "Haskell" cachedInternet-    print =<< searchEngine "C#" cachedInternet+main = defaultMain tests