FreshCache.hs 2.57 KB
Newer Older
Christopher League's avatar
Christopher League committed
1
2
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
3
{-# LANGUAGE ScopedTypeVariables #-}
4
{-# LANGUAGE NoImplicitPrelude #-}
5

6
7
8
9
10
11
12
13
-- |
-- Module: FreshCache
-- Description: Cache the result of an expensive action
--
-- This utility caches the result of an expensive action for a specified
-- amount of time. If the result is requested again within that time, the
-- existing one is used. If it is requested after the time is expired, we
-- automatically refresh it. Should be thread-safe.
14
module FreshCache
Christopher League's avatar
Christopher League committed
15
16
17
18
  ( Cache,
    newCache,
    readCache,
    invalidateCache,
19
20
    cacheDemo,
  )
Christopher League's avatar
Christopher League committed
21
22
23
24
25
26
27
28
29
30
where

import ClassyPrelude.Yesod
import Control.Concurrent (threadDelay)
import Data.Time.Clock (NominalDiffTime, diffUTCTime)

data CacheData a
  = CacheData
      { value :: a,
        retrievedAt :: UTCTime
31
      }
Christopher League's avatar
Christopher League committed
32
33
34
35
36
37

data CacheMeta m a
  = CacheMeta
      { content :: Maybe (CacheData a),
        maxAge :: NominalDiffTime,
        refresh :: m a
38
      }
Christopher League's avatar
Christopher League committed
39

40
41
-- | The cache structure. Saves the value 'a' which can be refreshed or
-- accessed within the monad 'm'.
Christopher League's avatar
Christopher League committed
42
43
newtype Cache m a
  = Cache (MVar (CacheMeta m a))
44

45
46
-- | Create a new cache by running the action and saving it with a
-- timestamp.
Christopher League's avatar
Christopher League committed
47
48
49
50
newCache :: MonadIO m => NominalDiffTime -> m a -> m (Cache m a)
newCache maxAge refresh = Cache <$> newMVar CacheMeta {..}
  where
    content = Nothing
51

Christopher League's avatar
Christopher League committed
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
invalidateCache :: MonadUnliftIO m => Cache m a -> m ()
invalidateCache (Cache mvar) =
  modifyMVar_ mvar $ \meta -> return meta {content = Nothing}

-- | Retrieve the value from the cache if it's within the maximum age.
-- Otherwise, refresh it and return the new value.
readCache :: MonadUnliftIO m => Cache m a -> m a
readCache (Cache mvar) = do
  now <- liftIO getCurrentTime
  modifyMVar mvar $ \meta@CacheMeta {..} ->
    case content of
      Just CacheData {..}
        | now `diffUTCTime` retrievedAt < maxAge -> return (meta, value)
      _ -> do
        newValue <- refresh
        return (meta {content = Just (CacheData newValue now)}, newValue)
68

69
-- | A little concurrent test program using the cache.
70
71
72
73
74
75
cacheDemo :: IO ()
cacheDemo = do
  let w sec = threadDelay (sec * 1000 * 1000)
      pr :: Int -> Text -> IO ()
      pr i r = say (tshow i <> ": " <> r)
  k <-
Christopher League's avatar
Christopher League committed
76
    newCache 6 $ do
77
78
79
80
81
82
83
      say "Refreshing..."
      w 2
      say "Refreshing...done"
      return $ asText "OK"
  threads <-
    forM [1 .. 5] $ \i ->
      async $ do
Christopher League's avatar
Christopher League committed
84
        readCache k >>= pr i
85
        w (i + 1)
Christopher League's avatar
Christopher League committed
86
        readCache k >>= pr i
87
        w (i + 2)
Christopher League's avatar
Christopher League committed
88
        readCache k >>= pr i
89
90
  mapM_ waitAsync threads
  say "Now forcing an immediate refresh"
Christopher League's avatar
Christopher League committed
91
92
  invalidateCache k
  readCache k >>= pr 0