Merge pull request #1573 from yesodweb/getSetCache

Add functions to get and set values in the per-request caches

yesod-core/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-core
 
+## 1.6.10
+
+* Adds functions to get and set values in the per-request caches. [#1573](https://github.com/yesodweb/yesod/pull/1573)
+
 ## 1.6.9
 
 * Add `sendResponseNoContent` [#1565](https://github.com/yesodweb/yesod/pull/1565)

yesod-core/Yesod/Core/Handler.hs

@@ -168,7 +168,11 @@ module Yesod.Core.Handler
     , getMessageRender
       -- * Per-request caching
     , cached
+    , cacheGet
+    , cacheSet
     , cachedBy
+    , cacheByGet
+    , cacheBySet
       -- * AJAX CSRF protection
 
       -- $ajaxCSRFOverview
@@ -1134,6 +1138,27 @@ cached action = do
           put $ gs { ghsCache = merged }
           return res
 
+-- | Retrieves a value from the cache used by 'cached'.
+--
+-- @since 1.6.10
+cacheGet :: (MonadHandler m, Typeable a)
+         => m (Maybe a)
+cacheGet = do
+  cache <- ghsCache <$> get
+  pure $ Cache.cacheGet cache
+
+-- | Sets a value in the cache used by 'cached'.
+--
+-- @since 1.6.10
+cacheSet :: (MonadHandler m, Typeable a)
+         => a
+         -> m ()
+cacheSet value = do
+  gs <- get
+  let cache = ghsCache gs
+      newCache = Cache.cacheSet value cache
+  put $ gs { ghsCache = newCache }
+
 -- | a per-request cache. just like 'cached'.
 -- 'cached' can only cache a single value per type.
 -- 'cachedBy' stores multiple values per type by usage of a ByteString key
@@ -1156,6 +1181,29 @@ cachedBy k action = do
           put $ gs { ghsCacheBy = merged }
           return res
 
+-- | Retrieves a value from the cache used by 'cachedBy'.
+--
+-- @since 1.6.10
+cacheByGet :: (MonadHandler m, Typeable a)
+           => S.ByteString
+           -> m (Maybe a)
+cacheByGet key = do
+  cache <- ghsCacheBy <$> get
+  pure $ Cache.cacheByGet key cache
+
+-- | Sets a value in the cache used by 'cachedBy'.
+--
+-- @since 1.6.10
+cacheBySet :: (MonadHandler m, Typeable a)
+           => S.ByteString
+           -> a
+           -> m ()
+cacheBySet key value = do
+  gs <- get
+  let cache = ghsCacheBy gs
+      newCache = Cache.cacheBySet key value cache
+  put $ gs { ghsCacheBy = newCache }
+
 -- | Get the list of supported languages supplied by the user.
 --
 -- Languages are determined based on the following (in descending order

yesod-core/Yesod/Core/TypeCache.hs

@@ -7,7 +7,7 @@
 -- Note that a TypeRep is unique to a module in a package, so types from different modules will not conflict if they have the same name.
 --
 -- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy'
-module Yesod.Core.TypeCache (cached, cachedBy, TypeMap, KeyedTypeMap) where
+module Yesod.Core.TypeCache (cached, cacheGet, cacheSet, cachedBy, cacheByGet, cacheBySet, TypeMap, KeyedTypeMap) where
 
 import           Prelude hiding (lookup)
 import           Data.Typeable                      (Typeable, TypeRep, typeOf)
@@ -33,22 +33,30 @@ cached :: (Monad m, Typeable a)
        => TypeMap
        -> m a                       -- ^ cache the result of this action
        -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
-cached cache action = case clookup cache of
+cached cache action = case cacheGet cache of
     Just val -> return $ Right val
     Nothing -> do
         val <- action
-        return $ Left (cinsert val cache, val)
+        return $ Left (cacheSet val cache, val)
-  where
-    clookup :: Typeable a => TypeMap -> Maybe a
-    clookup c =
-        res
-      where
-        res = lookup (typeOf $ fromJust res) c >>= fromDynamic
-        fromJust :: Maybe a -> a
-        fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
 
-    cinsert :: Typeable a => a -> TypeMap -> TypeMap
+-- | Retrieves a value from the cache
-    cinsert v = insert (typeOf v) (toDyn v)
+--
+-- @since 1.6.10
+cacheGet :: Typeable a => TypeMap -> Maybe a
+cacheGet cache = res
+  where
+    res = lookup (typeOf $ fromJust res) cache >>= fromDynamic
+    fromJust :: Maybe a -> a
+    fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
+
+-- | Sets a value in the cache
+--
+-- @since 1.6.10
+cacheSet :: (Typeable a)
+         => a
+         -> TypeMap
+         -> TypeMap
+cacheSet v cache = insert (typeOf v) (toDyn v) cache
 
 -- | similar to 'cached'.
 -- 'cached' can only cache a single value per type.
@@ -65,19 +73,24 @@ cachedBy :: (Monad m, Typeable a)
          -> ByteString                     -- ^ a cache key
          -> m a                            -- ^ cache the result of this action
          -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
-cachedBy cache k action = case clookup k cache of
+cachedBy cache k action = case cacheByGet k cache of
     Just val -> return $ Right val
     Nothing -> do
         val <- action
-        return $ Left (cinsert k val cache, val)
+        return $ Left (cacheBySet k val cache, val)
-  where
-    clookup :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a
-    clookup key c =
-        res
-      where
-        res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic
-        fromJust :: Maybe a -> a
-        fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
 
-    cinsert :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
+-- | Retrieves a value from the keyed cache
-    cinsert key v = insert (typeOf v, key) (toDyn v)
+--
+-- @since 1.6.10
+cacheByGet :: Typeable a => ByteString -> KeyedTypeMap -> Maybe a
+cacheByGet key c = res
+  where
+    res = lookup (typeOf $ fromJust res, key) c >>= fromDynamic
+    fromJust :: Maybe a -> a
+    fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
+
+-- | Sets a value in the keyed cache
+--
+-- @since 1.6.10
+cacheBySet :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
+cacheBySet key v cache = insert (typeOf v, key) (toDyn v) cache

yesod-core/test/YesodCoreTest/Cache.hs

@@ -46,7 +46,11 @@ getRootR = do
     V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
     V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
 
-    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]
+    cacheBySet "3" (V2 3)
+    Just (V2 v3a) <- cacheByGet "3"
+    V2 v3b <- cachedBy "3" $ (pure $ V2 4)
+
+    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
 
 getKeyR :: Handler RepPlain
 getKeyR = do
@@ -60,7 +64,12 @@ getKeyR = do
     V2 v3a <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
     V2 v3b <- cachedBy "2" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
 
-    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b]
+
+    cacheBySet "4" (V2 4)
+    Just (V2 v4a) <- cacheByGet "4"
+    V2 v4b <- cachedBy "4" $ (pure $ V2 5)
+
+    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b, v4a, v4b]
 
 getNestedR :: Handler RepPlain
 getNestedR = getNested cached
@@ -86,12 +95,12 @@ cacheTest =
     it "cached" $ runner $ do
       res <- request defaultRequest
       assertStatus 200 res
-      assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res
+      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
 
     it "cachedBy" $ runner $ do
       res <- request defaultRequest { pathInfo = ["key"] }
       assertStatus 200 res
-      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res
+      assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3, 4, 4 :: Int]) res
 
     it "nested cached" $ runner $ do
       res <- request defaultRequest { pathInfo = ["nested"] }

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.9
+version:         1.6.10
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>