cached and cachedBy will not overwrite global state changes

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.

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