diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -97,6 +98,12 @@ , liftIOHandler -- * i18n , getMessageRender + -- * Per-request caching + , CacheKey + , mkCacheKey + , cacheLookup + , cacheInsert + , cacheDelete -- * Internal Yesod , runHandler , YesodApp (..) @@ -121,14 +128,11 @@ import Control.Exception hiding (Handler, catch, finally) import Control.Applicative -import Control.Monad (liftM, join, MonadPlus) +import Control.Monad (liftM) import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State -import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..)) +import Control.Monad.Trans.RWS import System.IO import qualified Network.Wai as W @@ -142,8 +146,6 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL -import Control.Monad.IO.Control (MonadControlIO) -import Control.Monad.Trans.Control (MonadTransControl, liftControl) import qualified Data.Map as Map import qualified Data.ByteString as S import Data.ByteString (ByteString) @@ -153,7 +155,7 @@ import Yesod.Content import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie) -import Control.Arrow (second, (***)) +import Control.Arrow ((***)) import qualified Network.Wai.Parse as NWP import Data.Monoid (mappend, mempty, Endo (..)) import qualified Data.ByteString.Char8 as S8 @@ -165,6 +167,10 @@ import Text.Blaze (toHtml, preEscapedText) import Yesod.Internal.TestApi (catchIter) +import qualified Yesod.Internal.Cache as Cache +import Yesod.Internal.Cache (mkCacheKey, CacheKey) +import Data.Typeable (Typeable) + -- | The type-safe URLs associated with a site argument. type family Route a @@ -198,6 +204,11 @@ , handlerRoute = route } +withReaderT :: (HandlerData s m -> HandlerData s' m) + -> GGHandler s' m mo a + -> GGHandler s m mo a +withReaderT f = withRWST (\r s -> (f r, s)) + -- | Used internally for promoting subsite handler functions to master site -- handler functions. Should not be needed by users. toMasterHandler :: (Route sub -> Route master) @@ -205,8 +216,7 @@ -> Route sub -> GGHandler sub master mo a -> GGHandler sub' master mo a -toMasterHandler tm ts route (GHandler h) = - GHandler $ withReaderT (handlerSubData tm ts route) h +toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route) toMasterHandlerDyn :: Monad mo => (Route sub -> Route master) @@ -214,9 +224,9 @@ -> Route sub -> GGHandler sub master mo a -> GGHandler sub' master mo a -toMasterHandlerDyn tm getSub route (GHandler h) = do +toMasterHandlerDyn tm getSub route h = do sub <- getSub - GHandler $ withReaderT (handlerSubData tm (const sub) route) h + withReaderT (handlerSubData tm (const sub) route) h class SubsiteGetter g m s | g -> s where runSubsiteGetter :: g -> m s @@ -235,22 +245,14 @@ -> Maybe (Route sub) -> GGHandler sub master mo a -> GGHandler sub' master mo a -toMasterHandlerMaybe tm ts route (GHandler h) = - GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h +toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route) -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of 'ReaderT' for basic arguments, a -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling -- special responses. It is declared as a newtype to make compiler errors more -- readable. -newtype GGHandler sub master m a = - GHandler - { unGHandler :: GHInner sub master m a - } - deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadPlus) - -instance MonadTrans (GGHandler s m) where - lift = GHandler . lift . lift . lift . lift +type GGHandler sub master = RWST (HandlerData sub master) (Endo [Header]) GHState type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) @@ -258,16 +260,9 @@ { ghsSession :: SessionMap , ghsRBC :: Maybe RequestBodyContents , ghsIdent :: Int + , ghsCache :: Cache.Cache } -type GHInner s m monad = -- FIXME collapse the stack - ReaderT (HandlerData s m) ( - ErrorT HandlerContents ( - WriterT (Endo [Header]) ( - StateT GHState ( - monad - )))) - type SessionMap = Map.Map Text Text -- | An extension of the basic WAI 'W.Application' datatype to provide extra @@ -293,25 +288,27 @@ | HCRedirect RedirectType Text | HCCreated Text | HCWai W.Response + deriving Typeable -instance Error HandlerContents where - strMsg = HCError . InternalError . T.pack +instance Show HandlerContents where + show _ = "Cannot show a HandlerContents" +instance Exception HandlerContents getRequest :: Monad mo => GGHandler s m mo Request -getRequest = handlerRequest `liftM` GHandler ask +getRequest = handlerRequest `liftM` ask -instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where - failure = GHandler . lift . throwError . HCError +instance MonadIO monad => Failure ErrorResponse (GGHandler sub master monad) where + failure = liftIO . throwIO . HCError runRequestBody :: GHandler s m RequestBodyContents runRequestBody = do - x <- GHandler $ lift $ lift $ lift get + x <- get case ghsRBC x of Just rbc -> return rbc Nothing -> do rr <- waiRequest rbc <- lift $ rbHelper rr - GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc } + put x { ghsRBC = Just rbc } return rbc rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents @@ -326,33 +323,33 @@ -- | Get the sub application argument. getYesodSub :: Monad m => GGHandler sub master m sub -getYesodSub = handlerSub `liftM` GHandler ask +getYesodSub = handlerSub `liftM` ask -- | Get the master site appliation argument. getYesod :: Monad m => GGHandler sub master m master -getYesod = handlerMaster `liftM` GHandler ask +getYesod = handlerMaster `liftM` ask -- | Get the URL rendering function. getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text) getUrlRender = do - x <- handlerRender `liftM` GHandler ask + x <- handlerRender `liftM` ask return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams :: Monad m => GGHandler sub master m (Route master -> [(Text, Text)] -> Text) -getUrlRenderParams = handlerRender `liftM` GHandler ask +getUrlRenderParams = handlerRender `liftM` ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub)) -getCurrentRoute = handlerRoute `liftM` GHandler ask +getCurrentRoute = handlerRoute `liftM` ask -- | Get the function to promote a route for a subsite to a route for the -- master site. getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master) -getRouteToMaster = handlerToMaster `liftM` GHandler ask +getRouteToMaster = handlerToMaster `liftM` ask -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. @@ -378,15 +375,15 @@ , handlerRender = mrender , handlerToMaster = tomr } - let initSession' = GHState initSession Nothing 1 - ((contents', headers), finalSession) <- catchIter ( - fmap (second ghsSession) - $ flip runStateT initSession' - $ runWriterT - $ runErrorT - $ flip runReaderT hd - $ unGHandler handler - ) (\e -> return ((Left $ HCError $ toErrorHandler e, mempty), initSession)) + let initSession' = GHState initSession Nothing 1 mempty + (contents', finalSession, headers) <- catchIter ( + fmap (\(a, b, c) -> (Right a, ghsSession b, c)) + $ runRWST handler hd initSession' + ) (\e -> return ( + case fromException e of + Just x -> Left x + Nothing -> Left $ HCError $ toErrorHandler e + , initSession, mempty)) let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession @@ -431,11 +428,11 @@ session -- | Redirect to the given route. -redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a +redirect :: MonadIO mo => RedirectType -> Route master -> GGHandler sub master mo a redirect rt url = redirectParams rt url [] -- | Redirects to the given route with the associated query-string parameters. -redirectParams :: Monad mo +redirectParams :: MonadIO mo => RedirectType -> Route master -> [(Text, Text)] -> GGHandler sub master mo a redirectParams rt url params = do @@ -443,8 +440,8 @@ redirectString rt $ r url params -- | Redirect to the given URL. -redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a -redirectText rt = GHandler . lift . throwError . HCRedirect rt +redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GGHandler sub master mo a +redirectText rt = liftIO . throwIO . HCRedirect rt redirectString = redirectText {-# DEPRECATED redirectString "Use redirectText instead" #-} @@ -479,7 +476,7 @@ Nothing -> return () Just r -> do tm <- getRouteToMaster - gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask + gets' <- reqGetParams `liftM` handlerRequest `liftM` ask render <- getUrlRenderParams setUltDestString $ render (tm r) gets' @@ -500,7 +497,7 @@ -- value from the session. -- -- The ultimate destination is set with 'setUltDest'. -redirectUltDest :: Monad mo +redirectUltDest :: MonadIO mo => RedirectType -> Route master -- ^ default destination if nothing in session -> GGHandler sub master mo a @@ -544,52 +541,52 @@ -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. -sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a -sendFile ct fp = GHandler . lift . throwError $ HCSendFile ct fp Nothing +sendFile :: MonadIO mo => ContentType -> FilePath -> GGHandler sub master mo a +sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing -- | Same as 'sendFile', but only sends part of a file. -sendFilePart :: Monad mo +sendFilePart :: MonadIO mo => ContentType -> FilePath -> Integer -- ^ offset -> Integer -- ^ count -> GGHandler sub master mo a sendFilePart ct fp off count = - GHandler . lift . throwError $ HCSendFile ct fp $ Just $ W.FilePart off count + liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count -- | Bypass remaining handler code and output the given content with a 200 -- status code. -sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a -sendResponse = GHandler . lift . throwError . HCContent H.status200 +sendResponse :: (MonadIO mo, HasReps c) => c -> GGHandler sub master mo a +sendResponse = liftIO . throwIO . HCContent H.status200 . chooseRep -- | Bypass remaining handler code and output the given content with the given -- status code. -sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a -sendResponseStatus s = GHandler . lift . throwError . HCContent s +sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GGHandler s m mo a +sendResponseStatus s = liftIO . throwIO . HCContent s . chooseRep -- | Send a 201 "Created" response with the given route as the Location -- response header. -sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a +sendResponseCreated :: MonadIO mo => Route m -> GGHandler s m mo a sendResponseCreated url = do r <- getUrlRender - GHandler $ lift $ throwError $ HCCreated $ r url + liftIO . throwIO $ HCCreated $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session -- that you have already specified. This function short-circuits. It should be -- considered only for very specific needs. If you are not sure if you need it, -- you don't. -sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b -sendWaiResponse = GHandler . lift . throwError . HCWai +sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b +sendWaiResponse = liftIO . throwIO . HCWai -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound -- | Return a 405 method not supported page. -badMethod :: Monad mo => GGHandler s m mo a +badMethod :: MonadIO mo => GGHandler s m mo a badMethod = do w <- waiRequest failure $ BadMethod $ W.requestMethod w @@ -599,7 +596,7 @@ permissionDenied = failure . PermissionDenied -- | Return a 403 permission denied page. -permissionDeniedI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler s y mo a +permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler s y mo a permissionDeniedI msg = do mr <- getMessageRender permissionDenied $ mr msg @@ -609,7 +606,7 @@ invalidArgs = failure . InvalidArgs -- | Return a 400 invalid arguments page. -invalidArgsI :: (RenderMessage y msg, Monad mo) => [msg] -> GGHandler s y mo a +invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GGHandler s y mo a invalidArgsI msg = do mr <- getMessageRender invalidArgs $ map mr msg @@ -669,18 +666,18 @@ => Text -- ^ key -> Text -- ^ value -> GGHandler sub master mo () -setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k +setSession k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: Monad mo => Text -> GGHandler sub master mo () -deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete +deleteSession = modify . modSession . Map.delete modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession f x = x { ghsSession = f $ ghsSession x } -- | Internal use only, not to be confused with 'setHeader'. addHeader :: Monad mo => Header -> GGHandler sub master mo () -addHeader = GHandler . lift . lift . tell . Endo . (:) +addHeader = tell . Endo . (:) getStatus :: ErrorResponse -> H.Status getStatus NotFound = H.status404 @@ -702,17 +699,17 @@ localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a localNoCurrent = - GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler + local (\hd -> hd { handlerRoute = Nothing }) -- | Lookup for session data. lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text) -lookupSession n = GHandler $ do - m <- liftM ghsSession $ lift $ lift $ lift get +lookupSession n = do + m <- liftM ghsSession get return $ Map.lookup n m -- | Get all session variables. getSession :: Monad mo => GGHandler s m mo SessionMap -getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get +getSession = liftM ghsSession get handlerToYAR :: (HasReps a, HasReps b) => m -- ^ master site foundation @@ -803,7 +800,7 @@ -- | Get a unique identifier. newIdent :: Monad mo => GGHandler sub master mo String -- FIXME use Text -newIdent = GHandler $ lift $ lift $ lift $ do +newIdent = do x <- get let i' = ghsIdent x + 1 put x { ghsIdent = i' } @@ -812,42 +809,8 @@ liftIOHandler :: MonadIO mo => GGHandler sub master IO a -> GGHandler sub master mo a -liftIOHandler m = GHandler $ - ReaderT $ \r -> - ErrorT $ - WriterT $ - StateT $ \s -> - liftIO $ runGGHandler m r s - -runGGHandler :: GGHandler sub master m a - -> HandlerData sub master - -> GHState - -> m ( ( Either HandlerContents a - , Endo [Header] - ) - , GHState - ) -runGGHandler m r s = runStateT - (runWriterT - (runErrorT - (runReaderT - (unGHandler m) r))) s - -instance MonadTransControl (GGHandler s m) where - liftControl f = - GHandler $ - liftControl $ \runRdr -> - liftControl $ \runErr -> - liftControl $ \runWrt -> - liftControl $ \runSt -> - f ( liftM ( GHandler - . join . lift - . join . lift - . join . lift - ) - . runSt . runWrt . runErr . runRdr - . unGHandler - ) +liftIOHandler (RWST m) = RWST $ \r s -> + liftIO (m r s) -- | Redirect to a POST resource. -- @@ -855,7 +818,7 @@ -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. -redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a +redirectToPost :: MonadIO mo => Route master -> GGHandler sub master mo a redirectToPost dest = hamletToRepHtml #if GHC7 [hamlet| @@ -896,3 +859,16 @@ m <- getYesod l <- reqLangs `liftM` getRequest return $ renderMessage m l + +cacheLookup :: Monad mo => CacheKey a -> GGHandler sub master mo (Maybe a) +cacheLookup k = do + gs <- get + return $ Cache.lookup k $ ghsCache gs + +cacheInsert :: Monad mo => CacheKey a -> a -> GGHandler sub master mo () +cacheInsert k v = modify $ \gs -> + gs { ghsCache = Cache.insert k v $ ghsCache gs } + +cacheDelete :: Monad mo => CacheKey a -> GGHandler sub master mo () +cacheDelete k = modify $ \gs -> + gs { ghsCache = Cache.delete k $ ghsCache gs } diff --git a/Yesod/Internal/Cache.hs b/Yesod/Internal/Cache.hs new file mode 100644 --- /dev/null +++ b/Yesod/Internal/Cache.hs @@ -0,0 +1,38 @@ +{-# 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 GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) +import Data.Monoid (Monoid) +import Control.Applicative ((<$>)) + +newtype Cache = Cache (Map.IntMap Any) + deriving Monoid + +newtype CacheKey a = CacheKey Int + +-- | 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/Internal/Core.hs b/Yesod/Internal/Core.hs --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -170,9 +170,9 @@ -- | Determine if a request is authorized or not. -- - -- Return 'Nothing' is the request is authorized, 'Just' a message if - -- unauthorized. If authentication is required, you should use a redirect; - -- the Auth helper provides this functionality automatically. + -- Return 'Authorized' if the request is authorized, + -- 'Unauthorized' a message if unauthorized. + -- If authentication is required, return 'AuthenticationRequired'. isAuthorized :: Route a -> Bool -- ^ is this a write request? -> GHandler s a AuthResult diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Widget @@ -78,16 +79,41 @@ import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName) +#if MIN_VERSION_monad_control(0, 3, 0) +import Control.Monad.Trans.Control (MonadTransControl (..), MonadBaseControl (..), defaultLiftBaseWith, defaultRestoreM, ComposeSt) +#else import Control.Monad.IO.Control (MonadControlIO) +#endif import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText) import Text.Blaze (toHtml, preEscapedLazyText) +import Control.Monad.Base (MonadBase (liftBase)) -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a } - deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO) + deriving (Functor, Applicative, Monad, MonadIO +#if !MIN_VERSION_monad_control(0, 3, 0) + , MonadControlIO +#endif + ) + +instance MonadBase b m => MonadBase b (GGWidget master m) where + liftBase = lift . liftBase +#if MIN_VERSION_monad_control(0, 3, 0) +instance MonadTransControl (GGWidget master) where + newtype StT (GGWidget master) a = StRWS {unStRWS :: (a, Int, GWData (Route master))} + liftWith f = GWidget $ RWST $ \r s -> liftM (\x -> (x, s, mempty)) + (f $ \t -> liftM StRWS $ runRWST (unGWidget t) r s) + restoreT mSt = GWidget $ RWST $ \_ _ -> liftM unStRWS mSt + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} +instance MonadBaseControl b m => MonadBaseControl b (GGWidget master m) where + newtype StM (GGWidget master m) a = StMT {unStMT :: ComposeSt (GGWidget master) m a} + liftBaseWith = defaultLiftBaseWith StMT + restoreM = defaultRestoreM unStMT +#endif instance MonadTrans (GGWidget m) where lift = GWidget . lift diff --git a/test/YesodCoreTest/Cache.hs b/test/YesodCoreTest/Cache.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/Cache.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module YesodCoreTest.Cache (cacheTest, Widget) where + +import Test.Hspec +import Test.Hspec.HUnit() + +import Network.Wai +import Network.Wai.Test + +import Yesod.Core + +data C = C + +key :: CacheKey Int +key = $(mkCacheKey) + +key2 :: CacheKey Int +key2 = $(mkCacheKey) + +mkYesod "C" [parseRoutes|/ RootR GET|] + +instance Yesod C where approot _ = "" + +getRootR :: Handler () +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 () + +cacheTest :: [Spec] +cacheTest = + describe "Test.Cache" + [ it "works" works + ] + +runner :: Session () -> IO () +runner f = toWaiApp C >>= runSession f + +works :: IO () +works = runner $ do + res <- request defaultRequest { pathInfo = [] } + assertStatus 200 res diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.9.3.4 +version: 0.9.3.5 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -24,6 +24,7 @@ test/YesodCoreTest/Links.hs test/YesodCoreTest/InternalRequest.hs test/YesodCoreTest/ErrorHandling.hs + test/YesodCoreTest/Cache.hs test.hs flag test @@ -63,7 +64,8 @@ , old-locale >= 1.0.0.2 && < 1.1 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 - , monad-control >= 0.2 && < 0.3 + , monad-control >= 0.2 && < 0.4 + , transformers-base >= 0.4 , enumerator >= 0.4.8 && < 0.5 , cookie >= 0.3 && < 0.4 , blaze-html >= 0.4.1.3 && < 0.5 @@ -89,6 +91,7 @@ Yesod.Config Yesod.Internal.TestApi other-modules: Yesod.Internal + Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request