From 4ece5fafd94963984da24d3d5ba1a08b16367393 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 13:24:23 +0200 Subject: [PATCH] Removed handlerToYAR --- yesod-core/Yesod/Core/Run.hs | 103 ++++++++---------- yesod-core/Yesod/Internal/Request.hs | 4 +- .../test/YesodCoreTest/InternalRequest.hs | 5 +- yesod-core/yesod-core.cabal | 2 +- 4 files changed, 55 insertions(+), 59 deletions(-) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index 6ba18081..60308d43 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -14,7 +14,6 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (LogLevel, LogSource) import Control.Monad.Trans.Resource (runResourceT) -import Control.Monad.Trans.Resource (ResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -49,26 +48,6 @@ import Yesod.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) -handlerToYAR :: (HasReps a, HasReps b) - => master -- ^ master site foundation - -> sub -- ^ sub site foundation - -> (RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - -> (Route sub -> Route master) - -> (Route master -> [(Text, Text)] -> Text) -- route renderer - -> (ErrorResponse -> GHandler sub master a) - -> YesodRequest - -> Maybe (Route sub) - -> SessionMap - -> GHandler sub master b - -> ResourceT IO YesodResponse -handlerToYAR y s upload log' toMasterRoute render errorHandler0 rr murl sessionMap h = - ya rr { reqOnError = eh', reqSession = sessionMap } - where - ya = runHandler h render murl toMasterRoute y s upload log' - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' - errorHandler' = localNoCurrent . errorHandler0 - yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response yarToResponse (YRWai a) _ = a yarToResponse (YRPlain s hs _ c _) extraHeaders = @@ -111,19 +90,23 @@ local :: (HandlerData sub' master' -> HandlerData sub master) -> GHandler sub' master' a local f (GHandler x) = GHandler $ \r -> x $ f r +data RunHandlerEnv sub master = RunHandlerEnv -- FIXME merge with YesodRunnerEnv? Or HandlerData + { rheRender :: !(Route master -> [(Text, Text)] -> Text) + , rheRoute :: !(Maybe (Route sub)) + , rheToMaster :: !(Route sub -> Route master) + , rheMaster :: !master + , rheSub :: !sub + , rheUpload :: !(RequestBodyLength -> FileUpload) + , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + } + -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'Application'. Should not be needed by users. runHandler :: HasReps c - => GHandler sub master c - -> (Route master -> [(Text, Text)] -> Text) - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> master - -> sub - -> (RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + => RunHandlerEnv sub master + -> GHandler sub master c -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' req = do +runHandler RunHandlerEnv {..} handler yreq = do let toErrorHandler e = case fromException e of Just (HCError x) -> x @@ -136,15 +119,15 @@ runHandler handler mrender sroute tomr master sub upload log' req = do , ghsHeaders = mempty } let hd = HandlerData - { handlerRequest = req - , handlerSub = sub - , handlerMaster = master - , handlerRoute = sroute - , handlerRender = mrender - , handlerToMaster = tomr + { handlerRequest = yreq + , handlerSub = rheSub + , handlerMaster = rheMaster + , handlerRoute = rheRoute + , handlerRender = rheRender + , handlerToMaster = rheToMaster , handlerState = istate - , handlerUpload = upload - , handlerLog = log' + , handlerUpload = rheUpload + , handlerLog = rheLog } contents' <- catch (fmap Right $ unGHandler handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id @@ -154,7 +137,7 @@ runHandler handler mrender sroute tomr master sub upload log' req = do let headers = ghsHeaders state let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do - yar <- eh e req + yar <- eh e yreq { reqOnError = safeEh , reqSession = finalSession } @@ -196,9 +179,9 @@ runHandler handler mrender sroute tomr master sub upload log' req = do finalSession HCWai r -> return $ YRWai r where - eh = reqOnError req - cts = reqAccept req - initSession = reqSession req + eh = reqOnError yreq + cts = reqAccept yreq + initSession = reqSession yreq safeEh :: ErrorResponse -> YesodApp safeEh er req = do @@ -256,16 +239,17 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () - let yapp = - runHandler - handler' - (yesodRender master $ resolveApproot master fakeWaiRequest) - Nothing - id - master - master - (fileUpload master) - (messageLoggerSource master $ logger master) + let yapp = runHandler + RunHandlerEnv + { rheRender = yesodRender master $ resolveApproot master fakeWaiRequest + , rheRoute = Nothing + , rheToMaster = id + , rheMaster = master + , rheSub = master + , rheUpload = fileUpload master + , rheLog = messageLoggerSource master $ logger master + } + handler' errHandler err req = do liftIO $ I.writeIORef ret (Left err) return $ YRPlain @@ -344,11 +328,20 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req redirect url' Unauthorized s' -> permissionDenied s' handler - let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session let ra = resolveApproot yreMaster req let log' = messageLoggerSource yreMaster yreLogger - yar <- handlerToYAR yreMaster yreSub (fileUpload yreMaster) log' yreToMaster - (yesodRender yreMaster ra) errorHandler rr yreRoute sessionMap h + rhe = RunHandlerEnv + { rheRender = yesodRender yreMaster ra + , rheRoute = yreRoute + , rheToMaster = yreToMaster + , rheMaster = yreMaster + , rheSub = yreSub + , rheUpload = fileUpload yreMaster + , rheLog = log' + } + yar <- runHandler rhe h rr + { reqOnError = runHandler rhe . localNoCurrent . errorHandler + } extraHeaders <- case yar of (YRPlain _ _ ct _ newSess) -> do let nsToken = maybe diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index c1b9a58d..21dc06da 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -82,7 +82,9 @@ parseWaiRequest env session onError useToken maxBodySize gen = , reqWaiRequest = limitRequestBody maxBodySize env , reqLangs = langs'' , reqToken = token - , reqSession = session + , reqSession = if useToken + then Map.delete tokenKey session + else session , reqAccept = httpAccept env , reqOnError = onError } diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index aea1f9a5..d9437da6 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -11,6 +11,7 @@ import Yesod.Request (YesodRequest (..)) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) +import Yesod.Core.Types (YesodApp, ErrorResponse) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do @@ -91,8 +92,8 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e , queryString = [("_LANG", Just "en-QUERY")] } (singleton "_LANG" "en-SESSION") onError False 10000 g -onError :: a -onError = error "Yesod.InternalRequest.onError" +onError :: ErrorResponse -> YesodApp +onError _ = error "Yesod.InternalRequest.onError" internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 40cddf9e..b9b8b03b 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -96,12 +96,12 @@ library Yesod.Request Yesod.Widget Yesod.Internal.TestApi + Yesod.Core.Types other-modules: Yesod.Internal Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request - Yesod.Core.Types Yesod.Core.Time Yesod.Core.Trans.Class Yesod.Core.Run