diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -132,7 +132,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Control.Monad.Trans.RWS +import Control.Monad.Trans.Reader import System.IO import qualified Network.Wai as W @@ -170,6 +170,7 @@ import qualified Yesod.Internal.Cache as Cache import Yesod.Internal.Cache (mkCacheKey, CacheKey) import Data.Typeable (Typeable) +import qualified Data.IORef as I -- | The type-safe URLs associated with a site argument. type family Route a @@ -184,6 +185,7 @@ , handlerRoute :: Maybe (Route sub) , handlerRender :: Route master -> [(Text, Text)] -> Text , handlerToMaster :: Route sub -> Route master + , handlerState :: I.IORef GHState } handlerSubData :: (Route sub -> Route master) @@ -204,11 +206,24 @@ , 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)) +get :: MonadIO monad => GGHandler sub master monad GHState +get = do + hd <- ask + liftIO $ I.readIORef $ handlerState hd +put :: MonadIO monad => GHState -> GGHandler sub master monad () +put g = do + hd <- ask + liftIO $ I.writeIORef (handlerState hd) g + +modify :: MonadIO monad => (GHState -> GHState) -> GGHandler sub master monad () +modify f = do + hd <- ask + liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ()) + +tell :: MonadIO monad => Endo [Header] -> GGHandler sub master monad () +tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } + -- | Used internally for promoting subsite handler functions to master site -- handler functions. Should not be needed by users. toMasterHandler :: (Route sub -> Route master) @@ -252,7 +267,7 @@ -- '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. -type GGHandler sub master = RWST (HandlerData sub master) (Endo [Header]) GHState +type GGHandler sub master = ReaderT (HandlerData sub master) type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) @@ -261,6 +276,7 @@ , ghsRBC :: Maybe RequestBodyContents , ghsIdent :: Int , ghsCache :: Cache.Cache + , ghsHeaders :: Endo [Header] } type SessionMap = Map.Map Text Text @@ -367,6 +383,13 @@ case fromException e of Just x -> x Nothing -> InternalError $ T.pack $ show e + istate <- liftIO $ I.newIORef GHState + { ghsSession = initSession + , ghsRBC = Nothing + , ghsIdent = 1 + , ghsCache = mempty + , ghsHeaders = mempty + } let hd = HandlerData { handlerRequest = rr , handlerSub = sa @@ -374,16 +397,14 @@ , handlerRoute = sroute , handlerRender = mrender , handlerToMaster = tomr + , handlerState = istate } - 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)) + contents' <- catchIter (fmap Right $ runReaderT handler hd) + (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id + $ fromException e) + state <- liftIO $ I.readIORef istate + let finalSession = ghsSession state + let headers = ghsHeaders state let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession @@ -452,16 +473,16 @@ -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: Monad mo => Route master -> GGHandler sub master mo () +setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo () setUltDest dest = do render <- getUrlRender setUltDestString $ render dest -- | Same as 'setUltDest', but use the given string. -setUltDestText :: Monad mo => Text -> GGHandler sub master mo () +setUltDestText :: MonadIO mo => Text -> GGHandler sub master mo () setUltDestText = setSession ultDestKey -setUltDestString :: Monad mo => Text -> GGHandler sub master mo () +setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo () setUltDestString = setSession ultDestKey {-# DEPRECATED setUltDestString "Use setUltDestText instead" #-} @@ -469,7 +490,7 @@ -- -- If this is a 404 handler, there is no current page, and then this call does -- nothing. -setUltDest' :: Monad mo => GGHandler sub master mo () +setUltDest' :: MonadIO mo => GGHandler sub master mo () setUltDest' = do route <- getCurrentRoute case route of @@ -483,7 +504,7 @@ -- | Sets the ultimate destination to the referer request header, if present. -- -- This function will not overwrite an existing ultdest. -setUltDestReferer :: Monad mo => GGHandler sub master mo () +setUltDestReferer :: MonadIO mo => GGHandler sub master mo () setUltDestReferer = do mdest <- lookupSession ultDestKey maybe @@ -507,7 +528,7 @@ maybe (redirect rt def) (redirectText rt) mdest -- | Remove a previously set ultimate destination. See 'setUltDest'. -clearUltDest :: Monad mo => GGHandler sub master mo () +clearUltDest :: MonadIO mo => GGHandler sub master mo () clearUltDest = deleteSession ultDestKey msgKey :: Text @@ -516,13 +537,13 @@ -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessage :: Monad mo => Html -> GGHandler sub master mo () +setMessage :: MonadIO mo => Html -> GGHandler sub master mo () setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessageI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler sub y mo () +setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler sub y mo () setMessageI msg = do mr <- getMessageRender setMessage $ toHtml $ mr msg @@ -531,7 +552,7 @@ -- variable. -- -- See 'setMessage'. -getMessage :: Monad mo => GGHandler sub master mo (Maybe Html) +getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html) getMessage = do mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey deleteSession msgKey @@ -613,7 +634,7 @@ ------- Headers -- | Set the cookie on the client. -setCookie :: Monad mo +setCookie :: MonadIO mo => Int -- ^ minutes to timeout -> H.Ascii -- ^ key -> H.Ascii -- ^ value @@ -621,22 +642,22 @@ setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo () +deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo () deleteCookie = addHeader . DeleteCookie -- | Set the language in the user session. Will show up in 'languages' on the -- next request. -setLanguage :: Monad mo => Text -> GGHandler sub master mo () +setLanguage :: MonadIO mo => Text -> GGHandler sub master mo () setLanguage = setSession langKey -- | Set an arbitrary response header. -setHeader :: Monad mo +setHeader :: MonadIO mo => CI H.Ascii -> H.Ascii -> GGHandler sub master mo () setHeader a = addHeader . Header a -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. -cacheSeconds :: Monad mo => Int -> GGHandler s m mo () +cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo () cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat [ "max-age=" , show i @@ -645,16 +666,16 @@ -- | Set the Expires header to some date in 2037. In other words, this content -- is never (realistically) expired. -neverExpires :: Monad mo => GGHandler s m mo () +neverExpires :: MonadIO mo => GGHandler s m mo () neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" -- | Set an Expires header in the past, meaning this content should not be -- cached. -alreadyExpired :: Monad mo => GGHandler s m mo () +alreadyExpired :: MonadIO mo => GGHandler s m mo () alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. -expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () +expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo () expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123 -- | Set a variable in the user's session. @@ -662,21 +683,21 @@ -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. -setSession :: Monad mo +setSession :: MonadIO mo => Text -- ^ key -> Text -- ^ value -> GGHandler sub master mo () setSession k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. -deleteSession :: Monad mo => Text -> GGHandler sub master mo () +deleteSession :: MonadIO mo => Text -> GGHandler sub master mo () 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 :: MonadIO mo => Header -> GGHandler sub master mo () addHeader = tell . Endo . (:) getStatus :: ErrorResponse -> H.Status @@ -702,13 +723,13 @@ local (\hd -> hd { handlerRoute = Nothing }) -- | Lookup for session data. -lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text) +lookupSession :: MonadIO mo => Text -> GGHandler s m mo (Maybe Text) 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 :: MonadIO mo => GGHandler s m mo SessionMap getSession = liftM ghsSession get handlerToYAR :: (HasReps a, HasReps b) @@ -799,7 +820,7 @@ headerToPair _ _ (Header key value) = (key, value) -- | Get a unique identifier. -newIdent :: Monad mo => GGHandler sub master mo String -- FIXME use Text +newIdent :: MonadIO mo => GGHandler sub master mo String -- FIXME use Text newIdent = do x <- get let i' = ghsIdent x + 1 @@ -809,8 +830,7 @@ liftIOHandler :: MonadIO mo => GGHandler sub master IO a -> GGHandler sub master mo a -liftIOHandler (RWST m) = RWST $ \r s -> - liftIO (m r s) +liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r -- | Redirect to a POST resource. -- @@ -860,15 +880,15 @@ l <- reqLangs `liftM` getRequest return $ renderMessage m l -cacheLookup :: Monad mo => CacheKey a -> GGHandler sub master mo (Maybe a) +cacheLookup :: MonadIO 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 :: MonadIO 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 :: MonadIO mo => CacheKey a -> GGHandler sub master mo () cacheDelete k = modify $ \gs -> gs { ghsCache = Cache.delete k $ ghsCache gs } diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -46,7 +46,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid -import Control.Monad.Trans.RWS +import Control.Monad.Trans.Writer (runWriterT) import Text.Hamlet import Text.Julius import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString) @@ -501,7 +501,7 @@ -> GHandler sub master (PageContent (Route master)) widgetToPageContent (GWidget w) = do master <- getYesod - ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0 + ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runWriterT w let title = maybe mempty unTitle mTitle let scripts = runUniqueList scripts' let stylesheets = runUniqueList stylesheets' diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -57,7 +57,7 @@ ) where import Data.Monoid -import Control.Monad.Trans.RWS +import Control.Monad.Trans.Writer import qualified Text.Blaze.Html5 as H import Text.Hamlet import Text.Cassius @@ -103,10 +103,11 @@ 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 + newtype StT (GGWidget master) a = + StWidget {unStWidget :: StT (GWInner master) a} + liftWith f = GWidget $ liftWith $ \run -> + f $ liftM StWidget . run . unGWidget + restoreT = GWidget . restoreT . liftM unStWidget {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (GGWidget master m) where @@ -119,7 +120,7 @@ lift = GWidget . lift type GWidget s m = GGWidget m (GHandler s m) -type GWInner master = RWST () (GWData (Route master)) Int +type GWInner master = WriterT (GWData (Route master)) instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where mempty = return () @@ -129,9 +130,7 @@ addSubWidget sub (GWidget w) = do master <- lift getYesod let sr = fromSubRoute sub master - s <- GWidget get - (a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s - GWidget $ put s' + (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runWriterT w GWidget $ tell w' return a @@ -299,9 +298,9 @@ -- manipulations. It can be easier to use this sometimes than 'wrapWidget'. extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (HtmlUrl (Route m)) extractBody (GWidget w) = - GWidget $ mapRWST (liftM go) w + GWidget $ mapWriterT (liftM go) w where - go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g) + go ((), GWData (Body h) b c d e f g) = (h, GWData (Body mempty) b c d e f g) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/test/YesodCoreTest/Exceptions.hs b/test/YesodCoreTest/Exceptions.hs --- a/test/YesodCoreTest/Exceptions.hs +++ b/test/YesodCoreTest/Exceptions.hs @@ -7,11 +7,13 @@ import Test.Hspec.HUnit () import Yesod.Core hiding (Request) +import Network.Wai import Network.Wai.Test data Y = Y mkYesod "Y" [parseRoutes| / RootR GET +/redirect RedirR GET |] instance Yesod Y where @@ -22,9 +24,15 @@ getRootR :: Handler () getRootR = error "FOOBAR" >> return () +getRedirR :: Handler () +getRedirR = do + setHeader "foo" "bar" + redirect RedirectPermanent RootR + exceptionsTest :: [Spec] exceptionsTest = describe "Test.Exceptions" [ it "500" case500 + , it "redirect keeps headers" caseRedirect ] runner :: Session () -> IO () @@ -35,3 +43,9 @@ res <- request defaultRequest assertStatus 500 res assertBody "FOOBAR" res + +caseRedirect :: IO () +caseRedirect = runner $ do + res <- request defaultRequest { pathInfo = ["redirect"] } + assertStatus 301 res + assertHeader "foo" "bar" 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.5 +version: 0.9.3.6 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -102,7 +102,7 @@ test-suite tests type: exitcode-stdio-1.0 - main-is: ../test.hs + main-is: test.hs hs-source-dirs: test if flag(ghc7)