module Control.Concurrent.CachedIO (
cachedIO,
cachedIOWith
) where
import Control.Concurrent.STM (atomically, newTVar, readTVar, writeTVar, retry)
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Time.Clock (NominalDiffTime, addUTCTime, getCurrentTime, UTCTime)
data State = Uninitialized | Initializing
cachedIO :: (MonadIO m)
=> NominalDiffTime
-> m a
-> m (m a)
cachedIO interval = cachedIOWith (secondsPassed interval)
secondsPassed :: NominalDiffTime
-> UTCTime
-> UTCTime
-> Bool
secondsPassed interval start end = addUTCTime interval start > end
cachedIOWith :: (MonadIO m)
=> (UTCTime -> UTCTime -> Bool)
-> m a
-> m (m a)
cachedIOWith isCacheStillFresh io = do
initTime <- liftIO getCurrentTime
cachedT <- liftIO (atomically (newTVar (initTime, Left Uninitialized)))
return $ do
now <- liftIO getCurrentTime
join . liftIO . atomically $ do
cached <- readTVar cachedT
case cached of
(lastUpdated, Right value) | isCacheStillFresh lastUpdated now ->
return (return value)
(_, Right value) -> do
writeTVar cachedT (now, Right value)
return $ refreshCache now cachedT
(_, Left Uninitialized) -> do
writeTVar cachedT (now, Left Initializing)
return $ refreshCache now cachedT
(_, Left Initializing) -> retry
where
refreshCache now cachedT = do
newValue <- io
liftIO (atomically (writeTVar cachedT (now, Right newValue)))
liftIO (return newValue)