diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index 5872df48..11da629e 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -14,11 +14,9 @@ import Yesod.Core.Internal.Request (textQueryString) class YesodDispatch sub master where yesodDispatch :: Yesod master - => (Maybe (Route sub) -> YesodRunnerEnv sub master) + => YesodRunnerEnv sub master -> W.Application instance YesodDispatch WaiSubsite master where - yesodDispatch getEnv req = + yesodDispatch YesodRunnerEnv { yreSub = WaiSubsite app } req = app req - where - YesodRunnerEnv { yreSub = WaiSubsite app } = getEnv $ Just $ WaiSubsiteRoute (W.pathInfo req) (textQueryString req) diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index b6fddc4b..07c60aaf 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -150,8 +150,8 @@ mkDispatchInstance context sub master res = do , mdsGetPathInfo = [|W.pathInfo|] , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] , mdsMethod = [|W.requestMethod|] - , mds404 = [|\getEnv -> yesodRunner (notFound >> return ()) $ getEnv Nothing|] - , mds405 = [|\getEnv route -> yesodRunner (badMethod >> return ()) (getEnv $ Just route)|] + , mds404 = [|\env -> yesodRunner (notFound >> return ()) env Nothing|] + , mds405 = [|\env route -> yesodRunner (badMethod >> return ()) env (Just route)|] } res return $ FunD 'yesodDispatch [clause'] in sequence [instanceD context yDispatch [thisDispatch]] @@ -187,13 +187,12 @@ toWaiApp' y logger sb req = { W.pathInfo = pieces } where - yre route = YesodRunnerEnv + yre = YesodRunnerEnv { yreLogger = logger , yreMaster = y , yreSub = y , yreToMaster = id , yreSessionBackend = sb - , yreRoute = route } sendRedirect :: Yesod master => master -> [Text] -> W.Application diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 52135ddf..e3cc9571 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -213,8 +213,9 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do yesodRunner :: (ToTypedContent res, Yesod master) => GHandler sub master res -> YesodRunnerEnv sub master + -> Maybe (Route sub) -> Application -yesodRunner handler' YesodRunnerEnv {..} req +yesodRunner handler' YesodRunnerEnv {..} route req | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse | otherwise = do let dontSaveSession _ = return [] @@ -233,7 +234,7 @@ yesodRunner handler' YesodRunnerEnv {..} req -- errors out, it will use the safeEh below to recover. rheSafe = RunHandlerEnv { rheRender = yesodRender yreMaster ra - , rheRoute = yreRoute + , rheRoute = route , rheToMaster = yreToMaster , rheMaster = yreMaster , rheSub = yreSub @@ -247,7 +248,7 @@ yesodRunner handler' YesodRunnerEnv {..} req yar <- runHandler rhe handler yreq liftIO $ yarToResponse yar saveSession yreq where - maxLen = maximumContentLength yreMaster $ fmap yreToMaster yreRoute + maxLen = maximumContentLength yreMaster $ fmap yreToMaster route handler = yesodMiddleware handler' yesodRender :: Yesod y @@ -275,15 +276,12 @@ resolveApproot master req = fixEnv :: (oldSub -> newSub) -> (Route newSub -> Route oldSub) - -> (Maybe (Route oldSub) -> YesodRunnerEnv oldSub master) - -> (Maybe (Route newSub) -> YesodRunnerEnv newSub master) -fixEnv toNewSub toOldRoute getEnvOld newRoute = - go (getEnvOld $ fmap toOldRoute newRoute) - where - go env = env - { yreSub = toNewSub $ yreSub env - , yreToMaster = yreToMaster env . toOldRoute - , yreRoute = newRoute + -> YesodRunnerEnv oldSub master + -> YesodRunnerEnv newSub master +fixEnv toNewSub toOldRoute envOld = + envOld + { yreSub = toNewSub $ yreSub envOld + , yreToMaster = yreToMaster envOld . toOldRoute } stripHandlerT :: (HandlerReader m, HandlerState m, MonadBaseControl IO m) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index b59a781b..a4f6f7a5 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -187,7 +187,6 @@ data YesodRunnerEnv sub master = YesodRunnerEnv { yreLogger :: !Logger , yreMaster :: !master , yreSub :: !sub - , yreRoute :: !(Maybe (Route sub)) , yreToMaster :: !(Route sub -> Route master) , yreSessionBackend :: !(Maybe SessionBackend) } diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index 6b7a27a7..d4427954 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -303,7 +303,8 @@ buildCaller mds xrest parents name resDisp ys = do -- Run the whole thing runner <- [|$(return $ VarE handler) - $(return env) + $(return $ VarE getEnv) + (Just $(return route)) $(return $ VarE req) |]