diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 9222ac99..8476321c 100644 --- a/yesod-core/ChangeLog.md +++ b/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) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 2bd720e4..ab0a1d8d 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/TypeCache.hs b/yesod-core/Yesod/Core/TypeCache.hs index 7baf37d1..78bbe0a2 100644 --- a/yesod-core/Yesod/Core/TypeCache.hs +++ b/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) - 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" + return $ Left (cacheSet val cache, val) - cinsert :: Typeable a => a -> TypeMap -> TypeMap - cinsert v = insert (typeOf v) (toDyn v) +-- | Retrieves a value from the cache +-- +-- @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) - 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" + return $ Left (cacheBySet k val cache, val) - cinsert :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap - cinsert key v = insert (typeOf v, key) (toDyn v) +-- | Retrieves a value from the keyed cache +-- +-- @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 \ No newline at end of file diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index e1ba9204..846544a1 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/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"] } diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index e6486da3..a4762587 100644 --- a/yesod-core/yesod-core.cabal +++ b/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