diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 1e7893705..537591251 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -214,6 +214,7 @@ import Text.Hamlet (Html, HtmlUrl, hamlet) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HM import Data.Byteable (constEqBytes) @@ -1002,12 +1003,14 @@ cached :: (MonadHandler m, Typeable a) => m a -> m a cached action = do - gs <- get - eres <- Cache.cached (ghsCache gs) action + cache <- ghsCache <$> get + eres <- Cache.cached cache action case eres of Right res -> return res Left (newCache, res) -> do - put $ gs { ghsCache = newCache } + gs <- get + let merged = newCache `HM.union` ghsCache gs + put $ gs { ghsCache = merged } return res -- | a per-request cache. just like 'cached'. @@ -1022,12 +1025,14 @@ cached action = do -- Since 1.4.0 cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a cachedBy k action = do - gs <- get - eres <- Cache.cachedBy (ghsCacheBy gs) k action + cache <- ghsCacheBy <$> get + eres <- Cache.cachedBy cache k action case eres of Right res -> return res Left (newCache, res) -> do - put $ gs { ghsCacheBy = newCache } + gs <- get + let merged = newCache `HM.union` ghsCacheBy gs + put $ gs { ghsCacheBy = merged } return res -- | Get the list of supported languages supplied by the user. diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index 5b77c1bac..332a8bc9f 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/yesod-core/test/YesodCoreTest/Cache.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Rank2Types #-} module YesodCoreTest.Cache (cacheTest, Widget) where import Test.Hspec @@ -25,6 +26,8 @@ newtype V2 = V2 Int mkYesod "C" [parseRoutes| / RootR GET /key KeyR GET +/nested NestedR GET +/nested-key NestedKeyR GET |] instance Yesod C where @@ -55,6 +58,24 @@ getKeyR = do return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b, v3a, v3b] +getNestedR :: Handler RepPlain +getNestedR = getNested cached + +getNestedKeyR :: Handler RepPlain +getNestedKeyR = getNested $ cachedBy "3" + +-- | Issue #1266 +getNested :: (forall a. Typeable a => (Handler a -> Handler a)) -> Handler RepPlain +getNested cacheMethod = do + ref <- newIORef 0 + let getV2 = atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) + V1 _ <- cacheMethod $ do + V2 val <- cacheMethod $ getV2 + return $ V1 val + V2 v2 <- cacheMethod $ getV2 + + return $ RepPlain $ toContent $ show v2 + cacheTest :: Spec cacheTest = describe "Test.Cache" $ do @@ -68,5 +89,15 @@ cacheTest = assertStatus 200 res assertBody (L8.pack $ show [1, 1, 2, 2, 3, 3 :: Int]) res + it "nested cached" $ runner $ do + res <- request defaultRequest { pathInfo = ["nested"] } + assertStatus 200 res + assertBody (L8.pack $ show (1 :: Int)) res + + it "nested cachedBy" $ runner $ do + res <- request defaultRequest { pathInfo = ["nested-key"] } + assertStatus 200 res + assertBody (L8.pack $ show (1 :: Int)) res + runner :: Session () -> IO () runner f = toWaiApp C >>= runSession f