From 00b5781ec51791c5c0d8d182f5150a744a4aea33 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Sat, 20 Sep 2014 13:18:19 -0700 Subject: [PATCH 1/2] add cachedBy, like cached but adds a key re-factored to a base implementation with no Yesod dependencies in TypeCache.hs --- yesod-core/Yesod/Core/Handler.hs | 61 +++++++++++-------- yesod-core/Yesod/Core/Internal/Run.hs | 1 + yesod-core/Yesod/Core/TypeCache.hs | 82 ++++++++++++++++++++++++++ yesod-core/Yesod/Core/Types.hs | 9 +-- yesod-core/test/YesodCoreTest/Cache.hs | 41 ++++++++++--- yesod-core/yesod-core.cabal | 2 + 6 files changed, 158 insertions(+), 38 deletions(-) create mode 100644 yesod-core/Yesod/Core/TypeCache.hs diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index e975039f..faf5f183 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/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 --- times. Note that values are stored by their type. Therefore, you should use --- newtype wrappers to distinguish logically different types. +-- | Use a per-request cache to avoid performing the same action multiple times. +-- Values are stored by their type, the result of typeOf from Typeable. +-- Therefore, you should use differnt 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: -- -- 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 - case clookup cache of - Just val -> return val - Nothing -> do - val <- f - put $ gs { ghsCache = cinsert val cache } - 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" + eres <- Cache.cached (ghsCache gs) action + case eres of + Right res -> return res + Left (newCache, res) -> do + put $ gs { ghsCache = newCache } + return res - cinsert :: Typeable a => a -> Cache -> Cache - cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m) +-- | 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 +-- +-- '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. -- diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 6bb16587..0c33e076 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/TypeCache.hs b/yesod-core/Yesod/Core/TypeCache.hs new file mode 100644 index 00000000..62356d33 --- /dev/null +++ b/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 differnt 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: +-- +-- 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) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index df208f27..1a001337 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/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 -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] } diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index 45df7615..ca472ec2 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 44855f59..9a55a686 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 @@ -73,6 +74,7 @@ library Yesod.Core.Widget Yesod.Core.Internal Yesod.Core.Types + Yesod.Core.TypeCache other-modules: Yesod.Core.Internal.Session Yesod.Core.Internal.Request Yesod.Core.Class.Handler From f18d0a8bac1a88823e228a93f761a7ccad6d9ac0 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Sat, 20 Sep 2014 20:57:27 -0700 Subject: [PATCH 2/2] TypeCache typo and module exposure --- yesod-core/Yesod/Core/Handler.hs | 2 +- yesod-core/Yesod/Core/TypeCache.hs | 2 +- yesod-core/yesod-core.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index faf5f183..36f8f5c4 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -855,7 +855,7 @@ getMessageRender = do -- | Use a per-request cache to avoid performing the same action multiple times. -- Values are stored by their type, the result of typeOf from Typeable. --- Therefore, you should use differnt newtype wrappers at each cache site. +-- 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. diff --git a/yesod-core/Yesod/Core/TypeCache.hs b/yesod-core/Yesod/Core/TypeCache.hs index 62356d33..3b68f8c2 100644 --- a/yesod-core/Yesod/Core/TypeCache.hs +++ b/yesod-core/Yesod/Core/TypeCache.hs @@ -19,7 +19,7 @@ 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 differnt newtype wrappers at each cache site. +-- 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. diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 9a55a686..7559c52e 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -74,7 +74,6 @@ library Yesod.Core.Widget Yesod.Core.Internal Yesod.Core.Types - Yesod.Core.TypeCache other-modules: Yesod.Core.Internal.Session Yesod.Core.Internal.Request Yesod.Core.Class.Handler @@ -86,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