diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index e731a1e7..b8c3e1d9 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -24,11 +24,11 @@ import qualified Data.ByteString.Lazy as L import Data.Conduit (Flush, MonadThrow (..), MonadUnsafeIO (..), ResourceT, Source) -import Data.IntMap (IntMap) +import Data.Dynamic (Dynamic) import Data.IORef (IORef) import Data.Map (Map, unionWith) import qualified Data.Map as Map -import Data.Monoid (Any, Endo (..), Last (..), +import Data.Monoid (Endo (..), Last (..), Monoid (..)) import Data.Serialize (Serialize (..), putByteString) @@ -38,13 +38,14 @@ 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, RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP -import System.Log.FastLogger (LogStr, toLogStr, Logger) +import System.Log.FastLogger (LogStr, Logger, toLogStr) import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) @@ -155,11 +156,9 @@ 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 (IntMap Any) +newtype Cache = Cache (Map TypeRep Dynamic) deriving Monoid -newtype CacheKey a = CacheKey Int - type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. @@ -180,9 +179,9 @@ data RunHandlerEnv sub master = RunHandlerEnv } data HandlerData sub master = HandlerData - { handlerRequest :: !YesodRequest - , handlerEnv :: !(RunHandlerEnv sub master) - , handlerState :: !(IORef GHState) + { handlerRequest :: !YesodRequest + , handlerEnv :: !(RunHandlerEnv sub master) + , handlerState :: !(IORef GHState) } data YesodRunnerEnv sub master = YesodRunnerEnv diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index d45e95e9..34080529 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -120,11 +120,7 @@ module Yesod.Handler -- * i18n , getMessageRender -- * Per-request caching - , CacheKey - , mkCacheKey - , cacheLookup - , cacheInsert - , cacheDelete + , cached -- * Internal Yesod , YesodApp , runSubsiteGetter @@ -170,14 +166,14 @@ import Text.Shakespeare.I18N (RenderMessage (..)) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup -import qualified Yesod.Internal.Cache as Cache -import Yesod.Internal.Cache (mkCacheKey) import qualified Data.IORef as I import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Yesod.Routes.Class (Route) import Yesod.Core.Types import Yesod.Core.Trans.Class import Data.Maybe (listToMaybe) +import Data.Typeable (Typeable, typeOf) +import Data.Dynamic (fromDynamic, toDyn) class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y @@ -723,18 +719,34 @@ getMessageRender = do l <- reqLangs `liftM` getRequest return $ renderMessage m l -cacheLookup :: CacheKey a -> GHandler sub master (Maybe a) -cacheLookup k = do +-- | 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. +-- +-- Since 1.2.0 +cached :: Typeable a + => GHandler sub master a + -> GHandler sub master a +cached f = do gs <- get - return $ Cache.lookup k $ ghsCache gs + 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" -cacheInsert :: CacheKey a -> a -> GHandler sub master () -cacheInsert k v = modify $ \gs -> - gs { ghsCache = Cache.insert k v $ ghsCache gs } - -cacheDelete :: CacheKey a -> GHandler sub master () -cacheDelete k = modify $ \gs -> - gs { ghsCache = Cache.delete k $ ghsCache gs } + cinsert :: Typeable a => a -> Cache -> Cache + cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m) ask :: GHandler sub master (HandlerData sub master) ask = GHandler return diff --git a/yesod-core/Yesod/Internal/Cache.hs b/yesod-core/Yesod/Internal/Cache.hs deleted file mode 100644 index 0fc2d2a1..00000000 --- a/yesod-core/Yesod/Internal/Cache.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -module Yesod.Internal.Cache - ( Cache - , CacheKey - , mkCacheKey - , lookup - , insert - , delete - ) where - -import Prelude hiding (lookup) -import qualified Data.IntMap as Map -import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL)) -import Language.Haskell.TH (appE) -import Data.Unique (hashUnique, newUnique) -import Unsafe.Coerce (unsafeCoerce) -import Control.Applicative ((<$>)) -import Yesod.Core.Types - --- | Generate a new 'CacheKey'. Be sure to give a full type signature. -mkCacheKey :: Q Exp -mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique) - -lookup :: CacheKey a -> Cache -> Maybe a -lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m - -insert :: CacheKey a -> a -> Cache -> Cache -insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m) - -delete :: CacheKey a -> Cache -> Cache -delete (CacheKey k) (Cache m) = Cache (Map.delete k m) diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index d12d0cc1..45df7615 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/yesod-core/test/YesodCoreTest/Cache.hs @@ -1,38 +1,40 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} 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 data C = C -key :: CacheKey Int -key = $(mkCacheKey) +newtype V1 = V1 Int + deriving Typeable -key2 :: CacheKey Int -key2 = $(mkCacheKey) +newtype V2 = V2 Int + deriving Typeable mkYesod "C" [parseRoutes|/ RootR GET|] instance Yesod C -getRootR :: Handler () +getRootR :: Handler RepPlain getRootR = do - Nothing <- cacheLookup key - cacheInsert key 5 - Just 5 <- cacheLookup key - cacheInsert key 7 - Just 7 <- cacheLookup key - Nothing <- cacheLookup key2 - cacheDelete key - Nothing <- cacheLookup key - return () + ref <- newIORef 0 + V1 v1a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) + V1 v1b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) + + 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] cacheTest :: Spec cacheTest = @@ -44,5 +46,6 @@ runner f = toWaiApp C >>= runSession f works :: IO () works = runner $ do - res <- request defaultRequest { pathInfo = [] } + 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 efd781fd..1a3a066a 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -96,7 +96,6 @@ library Yesod.Widget Yesod.Internal.TestApi other-modules: Yesod.Internal - Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request @@ -132,6 +131,7 @@ test-suite tests ,transformers , conduit , containers + , lifted-base ghc-options: -Wall source-repository head