haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Typeable-based cache implementation (#268)

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-10 15:05:40 +02:00
parent 1a5793e2b9
commit 9559c2a345
5 changed files with 57 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
yesod-core/Yesod/Core/Types.hs
View File

@ -24,11 +24,11 @@ import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, MonadThrow (..), import Data.Conduit (Flush, MonadThrow (..),
MonadUnsafeIO (..), MonadUnsafeIO (..),
ResourceT, Source) ResourceT, Source)
import Data.IntMap (IntMap) import Data.Dynamic (Dynamic)
import Data.IORef (IORef) import Data.IORef (IORef)
import Data.Map (Map, unionWith) import Data.Map (Map, unionWith)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Monoid (Any, Endo (..), Last (..), import Data.Monoid (Endo (..), Last (..),
Monoid (..)) Monoid (..))
import Data.Serialize (Serialize (..), import Data.Serialize (Serialize (..),
putByteString) putByteString)
@ -38,13 +38,14 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TBuilder import qualified Data.Text.Lazy.Builder as TBuilder
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Typeable (TypeRep)
import Language.Haskell.TH.Syntax (Loc) import Language.Haskell.TH.Syntax (Loc)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import Network.Wai (FilePart, import Network.Wai (FilePart,
RequestBodyLength) RequestBodyLength)
import qualified Network.Wai as W import qualified Network.Wai as W
import qualified Network.Wai.Parse as NWP 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.Blaze.Html (Html)
import Text.Hamlet (HtmlUrl) import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl) import Text.Julius (JavascriptUrl)
@ -155,11 +156,9 @@ type BottomOfHeadAsync master
-> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
-> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head> -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
newtype Cache = Cache (IntMap Any) newtype Cache = Cache (Map TypeRep Dynamic)
deriving Monoid deriving Monoid
newtype CacheKey a = CacheKey Int
type Texts = [Text] type Texts = [Text]
-- | Wrap up a normal WAI application as a Yesod subsite. -- | Wrap up a normal WAI application as a Yesod subsite.
@ -180,9 +179,9 @@ data RunHandlerEnv sub master = RunHandlerEnv
} }
data HandlerData sub master = HandlerData data HandlerData sub master = HandlerData
{ handlerRequest :: !YesodRequest { handlerRequest :: !YesodRequest
, handlerEnv :: !(RunHandlerEnv sub master) , handlerEnv :: !(RunHandlerEnv sub master)
, handlerState :: !(IORef GHState) , handlerState :: !(IORef GHState)
} }
data YesodRunnerEnv sub master = YesodRunnerEnv data YesodRunnerEnv sub master = YesodRunnerEnv

46
yesod-core/Yesod/Handler.hs
View File

@ -120,11 +120,7 @@ module Yesod.Handler
-- * i18n -- * i18n
, getMessageRender , getMessageRender
-- * Per-request caching -- * Per-request caching
, CacheKey , cached
, mkCacheKey
, cacheLookup
, cacheInsert
, cacheDelete
-- * Internal Yesod -- * Internal Yesod
, YesodApp , YesodApp
, runSubsiteGetter , runSubsiteGetter
@ -170,14 +166,14 @@ import Text.Shakespeare.I18N (RenderMessage (..))
import Text.Blaze.Html (toHtml, preEscapedToMarkup) import Text.Blaze.Html (toHtml, preEscapedToMarkup)
#define preEscapedText preEscapedToMarkup #define preEscapedText preEscapedToMarkup
import qualified Yesod.Internal.Cache as Cache
import Yesod.Internal.Cache (mkCacheKey)
import qualified Data.IORef as I import qualified Data.IORef as I
import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Yesod.Routes.Class (Route) import Yesod.Routes.Class (Route)
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Trans.Class import Yesod.Core.Trans.Class
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Data.Typeable (Typeable, typeOf)
import Data.Dynamic (fromDynamic, toDyn)
class YesodSubRoute s y where class YesodSubRoute s y where
fromSubRoute :: s -> y -> Route s -> Route y fromSubRoute :: s -> y -> Route s -> Route y
@ -723,18 +719,34 @@ getMessageRender = do
l <- reqLangs `liftM` getRequest l <- reqLangs `liftM` getRequest
return $ renderMessage m l return $ renderMessage m l
cacheLookup :: CacheKey a -> GHandler sub master (Maybe a) -- | Use a per-request cache to avoid performing the same action multiple
cacheLookup k = do -- 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 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 () cinsert :: Typeable a => a -> Cache -> Cache
cacheInsert k v = modify $ \gs -> cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m)
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 }
ask :: GHandler sub master (HandlerData sub master) ask :: GHandler sub master (HandlerData sub master)
ask = GHandler return ask = GHandler return

32
yesod-core/Yesod/Internal/Cache.hs
View File

@ -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)

35
yesod-core/test/YesodCoreTest/Cache.hs
View File

@ -1,38 +1,40 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
module YesodCoreTest.Cache (cacheTest, Widget) where module YesodCoreTest.Cache (cacheTest, Widget) where
import Test.Hspec import Test.Hspec
import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Yesod.Core import Yesod.Core
import Data.IORef.Lifted
import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy.Char8 as L8
data C = C data C = C
key :: CacheKey Int newtype V1 = V1 Int
key = $(mkCacheKey) deriving Typeable
key2 :: CacheKey Int newtype V2 = V2 Int
key2 = $(mkCacheKey) deriving Typeable
mkYesod "C" [parseRoutes|/ RootR GET|] mkYesod "C" [parseRoutes|/ RootR GET|]
instance Yesod C instance Yesod C
getRootR :: Handler () getRootR :: Handler RepPlain
getRootR = do getRootR = do
Nothing <- cacheLookup key ref <- newIORef 0
cacheInsert key 5 V1 v1a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)
Just 5 <- cacheLookup key V1 v1b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)
cacheInsert key 7
Just 7 <- cacheLookup key V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
Nothing <- cacheLookup key2 V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
cacheDelete key
Nothing <- cacheLookup key return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]
return ()
cacheTest :: Spec cacheTest :: Spec
cacheTest = cacheTest =
@ -44,5 +46,6 @@ runner f = toWaiApp C >>= runSession f
works :: IO () works :: IO ()
works = runner $ do works = runner $ do
res <- request defaultRequest { pathInfo = [] } res <- request defaultRequest
assertStatus 200 res assertStatus 200 res
assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res

2
yesod-core/yesod-core.cabal
View File

@ -96,7 +96,6 @@ library
Yesod.Widget Yesod.Widget
Yesod.Internal.TestApi Yesod.Internal.TestApi
other-modules: Yesod.Internal other-modules: Yesod.Internal
Yesod.Internal.Cache
Yesod.Internal.Core Yesod.Internal.Core
Yesod.Internal.Session Yesod.Internal.Session
Yesod.Internal.Request Yesod.Internal.Request
@ -132,6 +131,7 @@ test-suite tests
,transformers ,transformers
, conduit , conduit
, containers , containers
, lifted-base
ghc-options: -Wall ghc-options: -Wall
source-repository head source-repository head