Beginning of a dispatch overhaul

yesod-core/Yesod/Core/Class/Dispatch.hs

@@ -1,53 +1,26 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE FlexibleInstances #-}
 module Yesod.Core.Class.Dispatch where
 
-import Yesod.Core.Content
-import Yesod.Core.Handler
-
 import Yesod.Routes.Class
-
 import qualified Network.Wai as W
-import Yesod.Core.Internal.Session
-import Data.Text (Text)
-import System.Log.FastLogger (Logger)
 import Yesod.Core.Types
 import Yesod.Core.Class.Yesod
-import Yesod.Core.Internal.Run
+import Yesod.Core.Internal.Request (textQueryString)
 
 -- | This class is automatically instantiated when you use the template haskell
 -- mkYesod function. You should never need to deal with it directly.
 class YesodDispatch sub master where
     yesodDispatch
         :: Yesod master
-        => Logger
+        => W.Application -- ^ 404 handler
-        -> master
+        -> (Route sub -> W.Application) -- ^ 405 handler
-        -> sub
+        -> (Route sub -> YesodRunnerEnv sub master)
-        -> (Route sub -> Route master)
-        -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
-        -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
-        -> Text -- ^ request method
-        -> [Text] -- ^ pieces
-        -> Maybe (SessionBackend master)
         -> W.Application
 
-    yesodRunner :: Yesod master
-                => Logger
-                -> GHandler sub master TypedContent
-                -> master
-                -> sub
-                -> Maybe (Route sub)
-                -> (Route sub -> Route master)
-                -> Maybe (SessionBackend master)
-                -> W.Application
-    yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv
-        { yreLogger = logger
-        , yreMaster = master
-        , yreSub = sub
-        , yreRoute = murl
-        , yreToMaster = tomaster
-        , yreSessionBackend = msb
-        } handler
-
 instance YesodDispatch WaiSubsite master where
-    yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
+    yesodDispatch _404 _405 getEnv req =
+        app req
+      where
+        YesodRunnerEnv { yreSub = WaiSubsite app } = getEnv $ WaiSubsiteRoute (W.pathInfo req) (textQueryString req)

yesod-core/Yesod/Core/Dispatch.hs

@@ -43,14 +43,11 @@ import Network.Wai.Middleware.Autohead
 import Data.ByteString.Lazy.Char8 ()
 
 import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8With)
-import Data.Text.Encoding.Error (lenientDecode)
 import Data.Monoid (mappend)
 import qualified Data.ByteString as S
 import qualified Blaze.ByteString.Builder
 import Network.HTTP.Types (status301)
 import Yesod.Routes.TH
-import Yesod.Core.Content (toTypedContent)
 import Yesod.Routes.Parse
 import System.Log.FastLogger (Logger)
 import Yesod.Core.Types
@@ -144,23 +141,18 @@ mkDispatchInstance :: CxtQ                -- ^ The context
                    -> [ResourceTree a]    -- ^ The resource
                    -> DecsQ
 mkDispatchInstance context sub master res = do
-  logger <- newName "logger"
+  let yDispatch = conT ''YesodDispatch `appT` sub `appT` master
-  let loggerE = varE logger
-      loggerP = VarP logger
-      yDispatch = conT ''YesodDispatch `appT` sub `appT` master
       thisDispatch = do
-            Clause pat body decs <- mkDispatchClause
+            clause' <- mkDispatchClause MkDispatchSettings
-                                    [|yesodRunner   $loggerE |]
+                { mdsRunHandler = [|yesodRunner|]
-                                    [|yesodDispatch $loggerE |]
+                , mdsDispatcher = [|yesodDispatch |]
-                                    [|fmap toTypedContent|]
+                , mdsFixEnv = [|fixEnv|]
-                                    res
+                , mdsGetPathInfo = [|W.pathInfo|]
-            return $ FunD 'yesodDispatch
+                , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
-                         [ Clause (loggerP:pat)
+                , mdsMethod = [|W.requestMethod|]
-                                  body
+                } res
-                                  decs
+            return $ FunD 'yesodDispatch [clause']
-                         ]
+   in sequence [instanceD context yDispatch [thisDispatch]]
-      in sequence [instanceD context yDispatch [thisDispatch]]
-        
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This is the same as 'toWaiAppPlain', except it includes two
@@ -186,15 +178,23 @@ toWaiApp' :: ( Yesod master
           -> Logger
           -> Maybe (SessionBackend master)
           -> W.Application
-toWaiApp' y logger sb env =
+toWaiApp' y logger sb req =
-    case cleanPath y $ W.pathInfo env of
+    case cleanPath y $ W.pathInfo req of
-        Left pieces -> sendRedirect y pieces env
+        Left pieces -> sendRedirect y pieces req
-        Right pieces ->
+        Right pieces -> yesodDispatch app404 handler405 (yre . Just) req
-            yesodDispatch logger y y id app404 handler405 method pieces sb env
+            { W.pathInfo = pieces
+            }
   where
-    app404 = yesodRunner logger notFound y y Nothing id
+    yre route = YesodRunnerEnv
-    handler405 route = yesodRunner logger badMethod y y (Just route) id
+        { yreLogger = logger
-    method = decodeUtf8With lenientDecode $ W.requestMethod env
+        , yreMaster = y
+        , yreSub = y
+        , yreToMaster = id
+        , yreSessionBackend = sb
+        , yreRoute = route
+        }
+    app404 = yesodRunner (notFound >> return ()) $ yre Nothing
+    handler405 = yesodRunner (badMethod >> return ()) . yre . Just
 
 sendRedirect :: Yesod master => master -> [Text] -> W.Application
 sendRedirect y segments' env =

yesod-core/Yesod/Core/Internal/Request.hs

@@ -15,6 +15,7 @@ module Yesod.Core.Internal.Request
     , tooLargeResponse
     , tokenKey
     , langKey
+    , textQueryString
     -- The below are exported for testing.
     , randomString
     ) where
@@ -95,9 +96,7 @@ parseWaiRequest env session useToken maxBodySize =
                             else session
         , reqAccept     = httpAccept env
         }
-    gets = map (second $ fromMaybe "")
+    gets = textQueryString env
-         $ queryToQueryText
-         $ W.queryString env
     reqCookie = lookup "Cookie" $ W.requestHeaders env
     cookies = maybe [] parseCookiesText reqCookie
     acceptLang = lookup "Accept-Language" $ W.requestHeaders env
@@ -128,6 +127,9 @@ parseWaiRequest env session useToken maxBodySize =
                 Nothing -> Right $ Just . pack . randomString 10
         | otherwise = Left Nothing
 
+textQueryString :: W.Request -> [(Text, Text)]
+textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString
+
 -- | Get the list of accepted content types from the WAI Request\'s Accept
 -- header.
 --

yesod-core/Yesod/Core/Internal/Run.hs

@@ -234,11 +234,11 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
   I.readIORef ret
 {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
 
-defaultYesodRunner :: Yesod master
+yesodRunner :: (ToTypedContent res, Yesod master)
-                   => YesodRunnerEnv sub master
+            => GHandler sub master res
-                   -> GHandler sub master TypedContent
+            -> YesodRunnerEnv sub master
-                   -> Application
+            -> Application
-defaultYesodRunner YesodRunnerEnv {..} handler' req
+yesodRunner handler' YesodRunnerEnv {..} req
   | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
   | otherwise = do
     let dontSaveSession _ = return []
@@ -351,3 +351,16 @@ resolveApproot master req =
         ApprootStatic t -> t
         ApprootMaster f -> f master
         ApprootRequest f -> f master req
+
+fixEnv :: (oldSub -> newSub)
+       -> (Route newSub -> Route oldSub)
+       -> (Route oldSub -> YesodRunnerEnv oldSub master)
+       -> (Route newSub -> YesodRunnerEnv newSub master)
+fixEnv toNewSub toOldRoute getEnvOld newRoute =
+    go (getEnvOld $ toOldRoute newRoute)
+  where
+    go env = env
+        { yreSub = toNewSub $ yreSub env
+        , yreToMaster = yreToMaster env . toOldRoute
+        , yreRoute = Just newRoute
+        }

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -30,10 +30,10 @@ instance RenderRoute Subsite where
     renderRoute (SubsiteRoute x) = (x, [])
 
 instance YesodDispatch Subsite master where
-    yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS
+    yesodDispatch _404 _405 _getEnv req = return $ responseLBS
         status200
         [ ("Content-Type", "SUBSITE")
-        ] $ L8.pack $ show pieces
+        ] $ L8.pack $ show (pathInfo req)
 
 data Y = Y
 mkYesod "Y" [parseRoutes|

yesod-core/yesod-core.cabal

@@ -50,7 +50,7 @@ library
 
     build-depends:   base                  >= 4.3      && < 5
                    , time                  >= 1.1.4
-                   , yesod-routes          >= 1.1      && < 1.2
+                   , yesod-routes          >= 1.2      && < 1.3
                    , wai                   >= 1.4      && < 1.5
                    , wai-extra             >= 1.3      && < 1.4
                    , bytestring            >= 0.9.1.4

yesod-routes/Yesod/Routes/TH/Dispatch.hs

@@ -2,6 +2,7 @@
 module Yesod.Routes.TH.Dispatch
     ( -- ** Dispatch
       mkDispatchClause
+    , MkDispatchSettings (..)
     ) where
 
 import Prelude hiding (exp)
@@ -16,6 +17,7 @@ import Data.Char (toLower)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Control.Applicative ((<$>))
 import Data.List (foldl')
+import Data.Text.Encoding (encodeUtf8)
 
 data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
 
@@ -27,6 +29,15 @@ flatten =
     go front (ResourceParent name pieces children) =
         concatMap (go (front . ((name, pieces):))) children
 
+data MkDispatchSettings = MkDispatchSettings
+    { mdsRunHandler :: Q Exp
+    , mdsDispatcher :: Q Exp
+    , mdsFixEnv :: Q Exp
+    , mdsGetPathInfo :: Q Exp
+    , mdsSetPathInfo :: Q Exp
+    , mdsMethod :: Q Exp
+    }
+
 -- |
 --
 -- This function will generate a single clause that will address all
@@ -90,12 +101,10 @@ flatten =
 -- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and
 -- @fmap 'chooseRep'@.
 
-mkDispatchClause :: Q Exp -- ^ runHandler function
+mkDispatchClause :: MkDispatchSettings
-                 -> Q Exp -- ^ dispatcher function
-                 -> Q Exp -- ^ fixHandler function
                  -> [ResourceTree a]
                  -> Q Clause
-mkDispatchClause runHandler dispatcher fixHandler ress' = do
+mkDispatchClause mds ress' = do
     -- Allocate the names to be used. Start off with the names passed to the
     -- function itself (with a 0 suffix).
     --
@@ -103,41 +112,42 @@ mkDispatchClause runHandler dispatcher fixHandler ress' = do
     -- with -Wall). Additionally, we want to ensure that none of the code
     -- passed to toDispatch uses variables from the closure to prevent the
     -- dispatch data structure from being rebuilt on each run.
-    master0 <- newName "master0"
-    sub0 <- newName "sub0"
-    toMaster0 <- newName "toMaster0"
     app4040 <- newName "app4040"
     handler4050 <- newName "handler4050"
-    method0 <- newName "method0"
+    getEnv0 <- newName "getEnv0"
-    pieces0 <- newName "pieces0"
+    req0 <- newName "req0"
+    pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|]
 
     -- Name of the dispatch function
     dispatch <- newName "dispatch"
 
     -- Dispatch function applied to the pieces
-    let dispatched = VarE dispatch `AppE` VarE pieces0
+    let dispatched = VarE dispatch `AppE` pieces
 
     -- The 'D.Route's used in the dispatch function
-    routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress
+    routes <- mapM (buildRoute mds) ress
 
     -- The dispatch function itself
     toDispatch <- [|D.toDispatch|]
-    let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []]
+    let dispatchFun = FunD dispatch
+            [Clause
+                []
+                (NormalB $ toDispatch `AppE` ListE routes)
+                []
+            ]
 
     -- The input to the clause.
-    let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
+    let pats = map VarP [app4040, handler4050, getEnv0, req0]
 
     -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
-    methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress
+    methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress
 
     u <- [|case $(return dispatched) of
-            Just f -> f $(return $ VarE master0)
+            Just f -> f $(return $ VarE app4040)
-                        $(return $ VarE sub0)
-                        $(return $ VarE toMaster0)
-                        $(return $ VarE app4040)
                         $(return $ VarE handler4050)
-                        $(return $ VarE method0)
+                        $(return $ VarE getEnv0)
-            Nothing -> $(return $ VarE app4040)
+                        $(return $ VarE req0)
+            Nothing -> $(return $ VarE app4040 `AppE` VarE req0)
           |]
     return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
   where
@@ -147,11 +157,11 @@ mkDispatchClause runHandler dispatcher fixHandler ress' = do
 methodMapName :: String -> Name
 methodMapName s = mkName $ "methods" ++ s
 
-buildMethodMap :: Q Exp -- ^ fixHandler
+buildMethodMap :: MkDispatchSettings
                -> FlatResource a
                -> Q (Maybe Dec)
 buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
-buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do
+buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do
     fromList <- [|Map.fromList|]
     methods' <- mapM go methods
     let exp = fromList `AppE` ListE methods'
@@ -160,20 +170,27 @@ buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti met
   where
     pieces = concat $ map snd parents ++ [pieces']
     go method = do
-        fh <- fixHandler
         let func = VarE $ mkName $ map toLower method ++ name
-        pack' <- [|pack|]
+        pack' <- [|encodeUtf8 . pack|]
         let isDynamic Dynamic{} = True
             isDynamic _ = False
         let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti
         xs <- replicateM argCount $ newName "arg"
-        let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
+        runHandler <- mdsRunHandler mds
-        return $ TupE [pack' `AppE` LitE (StringL method), rhs]
+        let rhs
+                | null xs = runHandler `AppE` func
+                | otherwise =
+                    LamE (map VarP xs) $
+                    runHandler `AppE` (foldl' AppE func $ map VarE xs)
+        return $ TupE
+            [ pack' `AppE` LitE (StringL method)
+            , rhs
+            ]
 buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
 
 -- | Build a single 'D.Route' expression.
-buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
+buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp
-buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
+buildRoute mds (FlatResource parents name resPieces resDisp) = do
     -- First two arguments to D.Route
     routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
     isMulti <-
@@ -181,19 +198,26 @@ buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces
             Methods Nothing _ -> [|False|]
             _ -> [|True|]
 
-    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
+    [|D.Route
+        $(return routePieces)
+        $(return isMulti)
+        $(routeArg3
+            mds
+            parents
+            name
+            (map snd allPieces)
+            resDisp)
+        |]
   where
     allPieces = concat $ map snd parents ++ [resPieces]
 
-routeArg3 :: Q Exp -- ^ runHandler
+routeArg3 :: MkDispatchSettings
-          -> Q Exp -- ^ dispatcher
-          -> Q Exp -- ^ fixHandler
           -> [(String, [(CheckOverlap, Piece a)])]
           -> String -- ^ name of resource
           -> [Piece a]
           -> Dispatch a
           -> Q Exp
-routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
+routeArg3 mds parents name resPieces resDisp = do
     pieces <- newName "pieces"
 
     -- Allocate input piece variables (xs) and variables that have been
@@ -235,7 +259,7 @@ routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
             _ -> return ([], [])
 
     -- The final expression that actually uses the values we've computed
-    caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
+    caller <- buildCaller mds xrest parents name resDisp $ map snd ys ++ yrest'
 
     -- Put together all the statements
     just <- [|Just|]
@@ -254,24 +278,22 @@ routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
     return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
 
 -- | The final expression in the individual Route definitions.
-buildCaller :: Q Exp -- ^ runHandler
+buildCaller :: MkDispatchSettings
-            -> Q Exp -- ^ dispatcher
-            -> Q Exp -- ^ fixHandler
             -> Name -- ^ xrest
             -> [(String, [(CheckOverlap, Piece a)])]
             -> String -- ^ name of resource
             -> Dispatch a
             -> [Name] -- ^ ys
             -> Q Exp
-buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
+buildCaller mds xrest parents name resDisp ys = do
-    master <- newName "master"
+    getEnv <- newName "getEnv"
-    sub <- newName "sub"
-    toMaster <- newName "toMaster"
     app404 <- newName "_app404"
     handler405 <- newName "_handler405"
-    method <- newName "_method"
+    req <- newName "req"
 
-    let pat = map VarP [master, sub, toMaster, app404, handler405, method]
+    method <- [|$(mdsMethod mds) $(return $ VarE req)|]
+
+    let pat = map VarP [app404, handler405, getEnv, req]
 
     -- Create the route
     let route = routeFromDynamics parents name ys
@@ -281,13 +303,13 @@ buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
             Methods _ ms -> do
                 handler <- newName "handler"
 
+                let env = VarE getEnv `AppE` route
+
                 -- Run the whole thing
-                runner <- [|$(runHandler)
+                runner <- [|$(return $ VarE handler)
-                                $(return $ VarE handler)
+                                $(return env)
-                                $(return $ VarE master)
+                                $(return $ VarE req)
-                                $(return $ VarE sub)
+                                |]
-                                (Just $(return route))
-                                $(return $ VarE toMaster)|]
 
                 let myLet handlerExp =
                         LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
@@ -295,32 +317,39 @@ buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
                 if null ms
                     then do
                         -- Just a single handler
-                        fh <- fixHandler
+                        let he = foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
-                        let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
+                        runHandler <- mdsRunHandler mds
-                        return $ myLet he
+                        return $ myLet $ runHandler `AppE` he
                     else do
                         -- Individual methods
-                        mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
+                        mf <- [|Map.lookup $(return method) $(return $ VarE $ methodMapName name)|]
                         f <- newName "f"
                         let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
                         let body405 =
                                 VarE handler405
                                 `AppE` route
+                                `AppE` VarE req
                         return $ CaseE mf
                             [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
                             , Match (ConP 'Nothing []) (NormalB body405) []
                             ]
 
             Subsite _ getSub -> do
-                let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
+                sub <- newName "sub"
-                [|$(dispatcher)
+                let sub2 = LamE [VarP sub]
-                    $(return $ VarE master)
+                        (foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys)
-                    $(return sub2)
+                [|$(mdsDispatcher mds)
-                    ($(return $ VarE toMaster) . $(return route))
                     $(return $ VarE app404)
                     ($(return $ VarE handler405) . $(return route))
-                    $(return $ VarE method)
+                    ($(mdsFixEnv mds)
-                    $(return $ VarE xrest)
+                        $(return sub2)
+                        $(return route)
+                        $(return $ VarE getEnv)
+                        )
+                    ($(mdsSetPathInfo mds)
+                        $(return $ VarE xrest)
+                        $(return $ VarE req)
+                        )
                  |]
 
     return $ LamE pat exp

yesod-routes/test/Hierarchy.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -12,6 +13,8 @@ module Hierarchy
     , Handler
     , App
     , toText
+    , Env (..)
+    , fixEnv
     ) where
 
 import Test.Hspec
@@ -22,6 +25,8 @@ import Yesod.Routes.Class
 import Language.Haskell.TH.Syntax
 import qualified Yesod.Routes.Class as YRC
 import Data.Text (Text, pack, append)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as S8
 
 class ToText a where
     toText :: a -> Text
@@ -29,27 +34,41 @@ class ToText a where
 instance ToText Text where toText = id
 instance ToText String where toText = pack
 
-type Handler sub master = Text
+type Handler sub master a = a
-type App sub master = (Text, Maybe (YRC.Route master))
+type Request = ([Text], ByteString) -- path info, method
+type App sub master = Request -> (Text, Maybe (YRC.Route master))
+data Env sub master = Env
+    { envRoute :: Maybe (YRC.Route sub)
+    , envToMaster :: YRC.Route sub -> YRC.Route master
+    , envSub :: sub
+    , envMaster :: master
+    }
+
+fixEnv :: (oldSub -> newSub)
+       -> (YRC.Route newSub -> YRC.Route oldSub)
+       -> (YRC.Route oldSub -> Env oldSub master)
+       -> (YRC.Route newSub -> Env newSub master)
+fixEnv toSub toRoute getEnv newRoute =
+    go (getEnv $ toRoute newRoute)
+  where
+    go env = env
+        { envRoute = Just newRoute
+        , envToMaster = envToMaster env . toRoute
+        , envSub = toSub $ envSub env
+        }
 
 class Dispatcher sub master where
     dispatcher
-        :: master
+        :: App sub master -- ^ 404 page
-        -> sub
-        -> (YRC.Route sub -> YRC.Route master)
-        -> App sub master -- ^ 404 page
         -> (YRC.Route sub -> App sub master) -- ^ 405 page
-        -> Text -- ^ method
+        -> (YRC.Route sub -> Env sub master)
-        -> [Text]
         -> App sub master
 
 class RunHandler sub master where
     runHandler
-        :: Handler sub master
+        :: ToText a
-        -> master
+        => Handler sub master a
-        -> sub
+        -> Env sub master
-        -> Maybe (YRC.Route sub)
-        -> (YRC.Route sub -> YRC.Route master)
         -> App sub master
 
 data Hierarchy = Hierarchy
@@ -63,7 +82,14 @@ do
     /table/#Text TableR GET
 |]
     rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
-    dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources
+    dispatch <- mkDispatchClause MkDispatchSettings
+        { mdsRunHandler = [|runHandler|]
+        , mdsDispatcher = [|dispatcher|]
+        , mdsFixEnv = [|fixEnv|]
+        , mdsGetPathInfo = [|fst|]
+        , mdsMethod = [|snd|]
+        , mdsSetPathInfo = [|\p (_, m) -> (p, m)|]
+        } resources
     return
         $ InstanceD
             []
@@ -73,23 +99,23 @@ do
             [FunD (mkName "dispatcher") [dispatch]]
         : rrinst
 
-getHomeR :: Handler sub master
+getHomeR :: Handler sub master String
 getHomeR = "home"
 
-getAdminRootR :: Int -> Handler sub master
+getAdminRootR :: Int -> Handler sub master Text
 getAdminRootR i = pack $ "admin root: " ++ show i
 
-getLoginR :: Int -> Handler sub master
+getLoginR :: Int -> Handler sub master Text
 getLoginR i = pack $ "login: " ++ show i
 
-postLoginR :: Int -> Handler sub master
+postLoginR :: Int -> Handler sub master Text
 postLoginR i = pack $ "post login: " ++ show i
 
-getTableR :: Int -> Text -> Handler sub master
+getTableR :: Int -> Text -> Handler sub master Text
 getTableR _ t = append "TableR " t
 
 instance RunHandler Hierarchy master where
-    runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
+    runHandler h Env {..} _ = (toText h, fmap envToMaster envRoute)
 
 hierarchy :: Spec
 hierarchy = describe "hierarchy" $ do
@@ -97,6 +123,15 @@ hierarchy = describe "hierarchy" $ do
         renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
     it "renders table correctly" $
         renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])
-    let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
+    let disp m ps = dispatcher
+            (const (pack "404", Nothing))
+            (\route -> const (pack "405", Just route))
+            (\route -> Env
+                { envRoute = Just route
+                , envToMaster = id
+                , envMaster = Hierarchy
+                , envSub = Hierarchy
+                })
+            (map pack ps, S8.pack m)
     it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)
     it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")

yesod-routes/test/main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ExistentialQuantification #-}
@@ -20,6 +21,7 @@ import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 import Hierarchy
+import qualified Data.ByteString.Char8 as S8
 
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
@@ -106,7 +108,14 @@ do
             ]
         addCheck = map ((,) True)
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
-    dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
+    dispatch <- mkDispatchClause MkDispatchSettings
+        { mdsRunHandler = [|runHandler|]
+        , mdsDispatcher = [|dispatcher|]
+        , mdsFixEnv = [|fixEnv|]
+        , mdsGetPathInfo = [|fst|]
+        , mdsMethod = [|snd|]
+        , mdsSetPathInfo = [|\p (_, m) -> (p, m)|]
+        } ress
     return
         $ InstanceD
             []
@@ -117,16 +126,29 @@ do
         : rrinst
 
 instance RunHandler MyApp master where
-    runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
+    runHandler h Env {..} = const (toText h, fmap envToMaster envRoute)
 
 instance Dispatcher MySub master where
-    dispatcher _ _ toMaster _ _ _ pieces = (pack $ "subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
+    dispatcher _404 _405 getEnv (pieces, _method) =
+        ( pack $ "subsite: " ++ show pieces
+        , Just $ envToMaster env route
+        )
+      where
+        route = MySubRoute (pieces, [])
+        env = getEnv route
 
 instance Dispatcher MySubParam master where
-    dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
+    dispatcher app404 _405 getEnv (pieces, method) =
         case map unpack pieces of
-            [[c]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
+            [[c]] ->
-            _ -> app404
+                let route = ParamRoute c
+                    env = getEnv route
+                    toMaster = envToMaster env
+                    MySubParam i = envSub env
+                 in ( pack $ "subparam " ++ show i ++ ' ' : [c]
+                    , Just $ toMaster route
+                    )
+            _ -> app404 (pieces, method)
 
 {-
 thDispatchAlias
@@ -232,10 +254,19 @@ main = hspec $ do
             @?= (map pack ["subparam", "6", "c"], [])
 
     describe "thDispatch" $ do
-        let disp m ps = dispatcher MyApp MyApp id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
+        let disp m ps = dispatcher
+                (const (pack "404", Nothing))
+                ((\route -> const (pack "405", Just route)))
+                (\route -> Env
+                    { envRoute = Just route
+                    , envToMaster = id
+                    , envMaster = MyApp
+                    , envSub = MyApp
+                    })
+                (map pack ps, S8.pack m)
         it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR)
         it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)
-        it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing)
+        it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing :: Maybe (YRC.Route MyApp))
         it "routes to blog post" $ disp "GET" ["blog", "somepost"]
             @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost")
         it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]

yesod-routes/yesod-routes.cabal

@@ -1,5 +1,5 @@
 name:            yesod-routes
-version:         1.1.2
+version:         1.2.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -46,6 +46,7 @@ test-suite runtests
                  , containers
                  , template-haskell
                  , path-pieces
+                 , bytestring
     ghc-options:     -Wall
 
 source-repository head