Merge pull request #831 from yesodweb/cachedBy

add cachedBy, like cached but adds a key

yesod-core/Yesod/Core/Handler.hs

@@ -145,6 +145,7 @@ module Yesod.Core.Handler
     , getMessageRender
       -- * Per-request caching
     , cached
+    , cachedBy
     ) where
 
 import           Data.Time                     (UTCTime, addUTCTime,
@@ -187,10 +188,9 @@ import           Yesod.Core.Content            (ToTypedContent (..), simpleConte
 import           Yesod.Core.Internal.Util      (formatRFC1123)
 import           Text.Blaze.Html               (preEscapedToMarkup, toHtml)
 
-import           Data.Dynamic                  (fromDynamic, toDyn)
 import qualified Data.IORef.Lifted             as I
 import           Data.Maybe                    (listToMaybe, mapMaybe)
-import           Data.Typeable                 (Typeable, typeOf)
+import           Data.Typeable                 (Typeable)
 import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
@@ -208,6 +208,7 @@ import Control.Monad.Trans.Control (control, MonadBaseControl)
 import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
                     , Sink
                    )
+import qualified Yesod.Core.TypeCache as Cache
 
 get :: MonadHandler m => m GHState
 get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@@ -351,6 +352,7 @@ handlerToIO =
       return $ oldState { ghsRBC = Nothing
                         , ghsIdent = 1
                         , ghsCache = mempty
+                        , ghsCacheBy = mempty
                         , ghsHeaders = mempty }
 
     -- xx From this point onwards, no references to oldHandlerData xx
@@ -851,34 +853,47 @@ getMessageRender = do
     l <- reqLangs `liftM` getRequest
     return $ renderMessage (rheSite env) l
 
--- | Use a per-request cache to avoid performing the same action multiple
+-- | Use a per-request cache to avoid performing the same action multiple times.
--- times. Note that values are stored by their type. Therefore, you should use
+-- Values are stored by their type, the result of typeOf from Typeable.
--- newtype wrappers to distinguish logically different types.
+-- Therefore, you should use different newtype wrappers at each cache site.
+--
+-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.
+-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.
+--
+-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>
 --
 -- Since 1.2.0
 cached :: (MonadHandler m, Typeable a)
        => m a
        -> m a
-cached f = do
+cached action = do
     gs <- get
-    let cache = ghsCache gs
+    eres <- Cache.cached (ghsCache gs) action
-    case clookup cache of
+    case eres of
-        Just val -> return val
+      Right res -> return res
-        Nothing -> do
+      Left (newCache, res) -> do
-            val <- f
+          put $ gs { ghsCache = newCache }
-            put $ gs { ghsCache = cinsert val cache }
+          return res
-            return val
-  where
-    clookup :: Typeable a => Cache -> Maybe a
-    clookup (Cache m) =
-        res
-      where
-        res = Map.lookup (typeOf $ fromJust res) m >>= fromDynamic
-        fromJust :: Maybe a -> a
-        fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"
 
-    cinsert :: Typeable a => a -> Cache -> Cache
+-- | a per-request cache. just like 'cached'.
-    cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m)
+-- 'cached' can only cache a single value per type.
+-- 'cachedBy' stores multiple values per type by usage of a ByteString key
+--
+-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user
+-- 'cachedBy' is required if the action has parameters and can return multiple values per type.
+-- You can turn those parameters into a ByteString cache key.
+-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.
+--
+-- 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
+    case eres of
+      Right res -> return res
+      Left (newCache, res) -> do
+          put $ gs { ghsCacheBy = newCache }
+          return res
 
 -- | Get the list of supported languages supplied by the user.
 --

yesod-core/Yesod/Core/Internal/Run.hs

@@ -74,6 +74,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
         , ghsRBC = Nothing
         , ghsIdent = 1
         , ghsCache = mempty
+        , ghsCacheBy = mempty
         , ghsHeaders = mempty
         }
     let hd = HandlerData

yesod-core/Yesod/Core/TypeCache.hs

@@ -0,0 +1,82 @@
+-- | a module for caching a monadic action based on its return type
+--
+-- The cache is a HashMap where the key uses the result of typeOf from Typeable.
+-- The value stored is toDyn from Dynamic to support arbitrary value types.
+--
+-- un-exported newtype wrappers should be used to maintain unique keys in the cache.
+--
+-- used in 'Yesod.Core.Handler.cached' and 'Yesod.Core.Handler.cachedBy'
+module Yesod.Core.TypeCache where
+
+import           Prelude hiding (lookup)
+import           Data.Typeable                      (Typeable, TypeRep, typeOf)
+import           Data.HashMap.Strict
+import           Data.ByteString                    (ByteString)
+import           Data.Dynamic                       (Dynamic, toDyn, fromDynamic)
+
+type TypeMap      = HashMap TypeRep Dynamic
+type KeyedTypeMap = HashMap (TypeRep, ByteString) Dynamic
+
+-- | avoid performing the same action multiple times.
+-- Values are stored by their type, the result of typeOf from Typeable.
+-- Therefore, you should use different newtype wrappers at each cache site.
+--
+-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.
+-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.
+--
+-- In Yesod, this is used for a cache that is cleared at the end of every request.
+-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>
+--
+-- Since 1.2.0
+cached :: (Monad m, Typeable a)
+       => TypeMap
+       -> m a
+       -> m (Either (TypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
+cached cache action = case clookup 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"
+
+    cinsert :: Typeable a => a -> TypeMap -> TypeMap
+    cinsert v = insert (typeOf v) (toDyn v)
+
+-- | like 'cached'.
+-- 'cached' can only cache a single value per type.
+-- 'cachedBy' stores multiple values per type by usage of a ByteString key
+--
+-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user
+-- 'cachedBy' is required if the action has parameters and can return multiple values per type.
+-- You can turn those parameters into a ByteString cache key.
+-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.
+--
+-- Since 1.4.0
+cachedBy :: (Monad m, Typeable a)
+         => KeyedTypeMap
+         -> ByteString
+         -> m a
+         -> m (Either (KeyedTypeMap, a) a) -- ^ Left is a cache miss, Right is a hit
+cachedBy cache k action = case clookup 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"
+
+    cinsert :: Typeable a => ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
+    cinsert key v = insert (typeOf v, key) (toDyn v)

yesod-core/Yesod/Core/Types.hs

@@ -25,7 +25,6 @@ import           Control.Monad.Trans.Resource       (MonadResource (..), Interna
 import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Lazy               as L
 import           Data.Conduit                       (Flush, Source)
-import           Data.Dynamic                       (Dynamic)
 import           Data.IORef                         (IORef)
 import           Data.Map                           (Map, unionWith)
 import qualified Data.Map                           as Map
@@ -39,7 +38,6 @@ import qualified Data.Text                          as T
 import qualified Data.Text.Lazy.Builder             as TBuilder
 import           Data.Time                          (UTCTime)
 import           Data.Typeable                      (Typeable)
-import           Data.Typeable                      (TypeRep)
 import           Language.Haskell.TH.Syntax         (Loc)
 import qualified Network.HTTP.Types                 as H
 import           Network.Wai                        (FilePart,
@@ -59,6 +57,7 @@ import           Control.Monad.Reader               (MonadReader (..))
 import Prelude hiding (catch)
 import Control.DeepSeq (NFData (rnf))
 import Data.Conduit.Lazy (MonadActive, monadActive)
+import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -162,9 +161,6 @@ type BottomOfHeadAsync master
       -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
       -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
 
-newtype Cache = Cache (Map TypeRep Dynamic)
-    deriving Monoid
-
 type Texts = [Text]
 
 -- | Wrap up a normal WAI application as a Yesod subsite.
@@ -223,7 +219,8 @@ data GHState = GHState
     { ghsSession :: SessionMap
     , ghsRBC     :: Maybe RequestBodyContents
     , ghsIdent   :: Int
-    , ghsCache   :: Cache
+    , ghsCache   :: TypeMap
+    , ghsCacheBy :: KeyedTypeMap
     , ghsHeaders :: Endo [Header]
     }
 

yesod-core/test/YesodCoreTest/Cache.hs

@@ -6,12 +6,15 @@ module YesodCoreTest.Cache (cacheTest, Widget) where
 
 import Test.Hspec
 
+import Network.Wai
 import Network.Wai.Test
 
 import Yesod.Core
 import Data.IORef.Lifted
 import Data.Typeable (Typeable)
 import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 
 data C = C
 
@@ -21,9 +24,13 @@ newtype V1 = V1 Int
 newtype V2 = V2 Int
     deriving Typeable
 
-mkYesod "C" [parseRoutes|/ RootR GET|]
+mkYesod "C" [parseRoutes|
+/    RootR GET
+/key KeyR GET
+|]
 
-instance Yesod C
+instance Yesod C where
+    errorHandler e = liftIO (print e) >> defaultErrorHandler e
 
 getRootR :: Handler RepPlain
 getRootR = do
@@ -36,16 +43,32 @@ getRootR = do
 
     return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]
 
+getKeyR :: Handler RepPlain
+getKeyR = do
+    ref <- newIORef 0
+    V1 v1a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)
+    V1 v1b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)
+
+    V2 v2a <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
+    V2 v2b <- cachedBy "1" $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
+
+    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]
+
 cacheTest :: Spec
 cacheTest =
   describe "Test.Cache" $ do
-      it "works" works
+    it "cached" $ runner $ do
+      res <- request defaultRequest
+      assertStatus 200 res
+      assertBody (L8.pack $ show [1, 1, 2, 2 :: 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
 
 runner :: Session () -> IO ()
 runner f = toWaiApp C >>= runSession f
-
-works :: IO ()
-works = runner $ do
-    res <- request defaultRequest
-    assertStatus 200 res
-    assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res

yesod-core/yesod-core.cabal

@@ -40,6 +40,7 @@ library
                    , cereal                >= 0.3
                    , old-locale            >= 1.0.0.2  && < 1.1
                    , containers            >= 0.2
+                   , unordered-containers  >= 0.2
                    , monad-control         >= 0.3      && < 0.4
                    , transformers-base     >= 0.4
                    , cookie                >= 0.4.1    && < 0.5
@@ -84,6 +85,7 @@ library
                      Yesod.Core.Class.Yesod
                      Yesod.Core.Class.Dispatch
                      Yesod.Core.Class.Breadcrumbs
+                     Yesod.Core.TypeCache
                      Paths_yesod_core
 
                      Yesod.Routes.TH