Remove yreRoute
This commit is contained in:
parent
815e185a4b
commit
9a53092be7
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|]
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user