From db676c0e481295a9d6d722011c9e312fea0ca573 Mon Sep 17 00:00:00 2001 From: Hugh Davidson Date: Tue, 19 Sep 2023 10:31:20 +1000 Subject: [PATCH] Add Cached newtype --- CHANGELOG.md | 4 ++++ cached-io.cabal | 2 +- src/Control/Concurrent/CachedIO.hs | 25 ++++++++++++++++--------- test/test-cachedIO.hs | 8 ++++---- 4 files changed, 25 insertions(+), 14 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9d38923..f1750c5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for cached-io +## 1.3.0.0 + +- 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 harder to do this. + ## 1.2.0.0 Thank you [glasserc](https://github.com/glasserc) for your work on previous versions, and a special thanks to diff --git a/cached-io.cabal b/cached-io.cabal index 2787005..52093e9 100644 --- a/cached-io.cabal +++ b/cached-io.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cached-io -version: 1.2.0.0 +version: 1.3.0.0 synopsis: A simple library to cache IO actions description: Provides functions that convert an IO action into a cached one by storing the diff --git a/src/Control/Concurrent/CachedIO.hs b/src/Control/Concurrent/CachedIO.hs index e20d015..5d8ba64 100644 --- a/src/Control/Concurrent/CachedIO.hs +++ b/src/Control/Concurrent/CachedIO.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} -- | Example usage: -- -- > -- Downloads a large payload from an external data store. -- > downloadData :: IO ByteString -- > --- > cachedDownloadData :: IO ByteString +-- > cachedDownloadData :: IO (Cached IO ByteString) -- > cachedDownloadData = cachedIO (secondsToNominalDiffTime 600) downloadData -- -- The first time @cachedDownloadData@ is called, it calls @downloadData@, @@ -14,6 +15,7 @@ -- result again. -- module Control.Concurrent.CachedIO ( + Cached(..), cachedIO, cachedIOWith, cachedIO', @@ -26,6 +28,11 @@ import Control.Monad.Catch (MonadCatch, onException) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Time.Clock (NominalDiffTime, addUTCTime, getCurrentTime, UTCTime) +-- | A cached IO action in some monad @m@. Use 'runCached' to extract the action when you want to query it. +-- +-- This newtype is intended to make it harder to accidentally 'Control.Monad.join' (and defeat all caching) when the fetch action and the outer monad are the same. +newtype Cached t a = Cached {runCached :: t 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 @@ -37,7 +44,7 @@ data State a = Uninitialized | Initializing | Updating a | Fresh UTCTime a cachedIO :: (MonadIO m, MonadIO t, MonadCatch t) => NominalDiffTime -- ^ Number of seconds before refreshing cache -> t a -- ^ IO action to cache - -> m (t a) + -> m (Cached t a) cachedIO interval = cachedIOWith (secondsPassed interval) -- | Cache an IO action, producing a version of this IO action that is cached @@ -50,7 +57,7 @@ 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) + -> m (Cached t a) cachedIO' interval = cachedIOWith' (secondsPassed interval) -- | Check if @starting time@ + @seconds@ is after @end time@ @@ -70,7 +77,7 @@ cachedIOWith -- If 'isCacheStillFresh' 'lastUpdated' 'now' returns 'True' -- the cache is considered still fresh and returns the cached IO action -> t a -- ^ action to cache. - -> m (t a) + -> m (Cached t a) cachedIOWith f io = cachedIOWith' f (const io) -- | Cache an IO action, The cache begins uninitialized. @@ -84,10 +91,10 @@ cachedIOWith' -- 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) + -> m (Cached t a) cachedIOWith' isCacheStillFresh io = do cachedT <- liftIO (atomically (newTVar Uninitialized)) - return $ do + pure . Cached $ do now <- liftIO getCurrentTime join . liftIO . atomically $ do cached <- readTVar cachedT @@ -100,12 +107,12 @@ cachedIOWith' isCacheStillFresh io = do -- thread will get the stale data instead. | otherwise -> do writeTVar cachedT (Updating value) - return $ refreshCache previousState cachedT + pure (refreshCache previousState cachedT) -- Another thread is already updating the cache, just return the stale value - Updating value -> return (return value) + Updating value -> pure (pure value) -- The cache is uninitialized. Mark the cache as initializing to block other -- threads. Initialize and return. - Uninitialized -> return $ refreshCache Uninitialized cachedT + Uninitialized -> pure (refreshCache Uninitialized cachedT) -- The cache is uninitialized and another thread is already attempting to -- initialize it. Block. Initializing -> retry diff --git a/test/test-cachedIO.hs b/test/test-cachedIO.hs index 321d392..f1de6e4 100644 --- a/test/test-cachedIO.hs +++ b/test/test-cachedIO.hs @@ -2,7 +2,7 @@ module Main ( main ) where -import Control.Concurrent.CachedIO (cachedIO) +import Control.Concurrent.CachedIO (cachedIO, Cached(..)) import Data.List (isInfixOf) crawlTheInternet :: IO [String] @@ -13,10 +13,10 @@ crawlTheInternet = do return ["website about Haskell", "website about Ruby", "slashdot.org", "The Monad.Reader", "haskellwiki"] -searchEngine :: String -> IO [String] -> IO [String] +searchEngine :: String -> Cached IO [String] -> IO [String] searchEngine query internet = do - pages <- internet - return $ filter (query `isInfixOf`) pages + pages <- runCached internet + return $ filter ( query `isInfixOf`) pages main :: IO () main = do