Typeable-based cache implementation (#268)
This commit is contained in:
Michael Snoyman
parent
1a5793e2b9
commit
9559c2a345
@ -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 <head>
|
||||
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user