From 815e185a4b1228c8136cbb4292340005228ae8c3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 13 Mar 2013 07:12:19 +0200 Subject: [PATCH] Slight simplification to YesodDispatch typeclass --- yesod-core/Yesod/Core/Class/Dispatch.hs | 8 +++--- yesod-core/Yesod/Core/Dispatch.hs | 6 ++--- yesod-core/Yesod/Core/Internal/Run.hs | 8 +++--- yesod-core/test/YesodCoreTest/CleanPath.hs | 2 +- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 30 ++++++++++------------ 5 files changed, 24 insertions(+), 30 deletions(-) diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index a7ae1dd9..5872df48 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -14,13 +14,11 @@ import Yesod.Core.Internal.Request (textQueryString) class YesodDispatch sub master where yesodDispatch :: Yesod master - => W.Application -- ^ 404 handler - -> (Route sub -> W.Application) -- ^ 405 handler - -> (Route sub -> YesodRunnerEnv sub master) + => (Maybe (Route sub) -> YesodRunnerEnv sub master) -> W.Application instance YesodDispatch WaiSubsite master where - yesodDispatch _404 _405 getEnv req = + yesodDispatch getEnv req = app req where - YesodRunnerEnv { yreSub = WaiSubsite app } = getEnv $ WaiSubsiteRoute (W.pathInfo req) (textQueryString req) + 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 59a62c71..b6fddc4b 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -150,6 +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)|] } res return $ FunD 'yesodDispatch [clause'] in sequence [instanceD context yDispatch [thisDispatch]] @@ -181,7 +183,7 @@ toWaiApp' :: ( Yesod master toWaiApp' y logger sb req = case cleanPath y $ W.pathInfo req of Left pieces -> sendRedirect y pieces req - Right pieces -> yesodDispatch app404 handler405 (yre . Just) req + Right pieces -> yesodDispatch yre req { W.pathInfo = pieces } where @@ -193,8 +195,6 @@ toWaiApp' y logger sb req = , 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 = diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index c4a3a49d..52135ddf 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -275,15 +275,15 @@ resolveApproot master req = fixEnv :: (oldSub -> newSub) -> (Route newSub -> Route oldSub) - -> (Route oldSub -> YesodRunnerEnv oldSub master) - -> (Route newSub -> YesodRunnerEnv newSub master) + -> (Maybe (Route oldSub) -> YesodRunnerEnv oldSub master) + -> (Maybe (Route newSub) -> YesodRunnerEnv newSub master) fixEnv toNewSub toOldRoute getEnvOld newRoute = - go (getEnvOld $ toOldRoute newRoute) + go (getEnvOld $ fmap toOldRoute newRoute) where go env = env { yreSub = toNewSub $ yreSub env , yreToMaster = yreToMaster env . toOldRoute - , yreRoute = Just newRoute + , yreRoute = newRoute } stripHandlerT :: (HandlerReader m, HandlerState m, MonadBaseControl IO m) diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index e3c8c739..8bf7f5a3 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/yesod-core/test/YesodCoreTest/CleanPath.hs @@ -30,7 +30,7 @@ instance RenderRoute Subsite where renderRoute (SubsiteRoute x) = (x, []) instance YesodDispatch Subsite master where - yesodDispatch _404 _405 _getEnv req = return $ responseLBS + yesodDispatch _getEnv req = return $ responseLBS status200 [ ("Content-Type", "SUBSITE") ] $ L8.pack $ show (pathInfo req) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index 6c7b11b6..6b7a27a7 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -36,6 +36,8 @@ data MkDispatchSettings = MkDispatchSettings , mdsGetPathInfo :: Q Exp , mdsSetPathInfo :: Q Exp , mdsMethod :: Q Exp + , mds404 :: Q Exp + , mds405 :: Q Exp } -- | @@ -112,8 +114,6 @@ mkDispatchClause mds 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. - app4040 <- newName "app4040" - handler4050 <- newName "handler4050" getEnv0 <- newName "getEnv0" req0 <- newName "req0" pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|] @@ -137,17 +137,15 @@ mkDispatchClause mds ress' = do ] -- The input to the clause. - let pats = map VarP [app4040, handler4050, getEnv0, req0] + let pats = map VarP [getEnv0, req0] -- For each resource that dispatches based on methods, build up a map for handling the dispatching. methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress u <- [|case $(return dispatched) of - Just f -> f $(return $ VarE app4040) - $(return $ VarE handler4050) - $(return $ VarE getEnv0) + Just f -> f $(return $ VarE getEnv0) $(return $ VarE req0) - Nothing -> $(return $ VarE app4040 `AppE` VarE req0) + Nothing -> $(mds404 mds) $(return $ VarE getEnv0) $(return $ VarE req0) |] return $ Clause pats (NormalB u) $ dispatchFun : methodMaps where @@ -287,13 +285,11 @@ buildCaller :: MkDispatchSettings -> Q Exp buildCaller mds xrest parents name resDisp ys = do getEnv <- newName "getEnv" - app404 <- newName "_app404" - handler405 <- newName "_handler405" req <- newName "req" method <- [|$(mdsMethod mds) $(return $ VarE req)|] - let pat = map VarP [app404, handler405, getEnv, req] + let pat = map VarP [getEnv, req] -- Create the route let route = routeFromDynamics parents name ys @@ -303,7 +299,7 @@ buildCaller mds xrest parents name resDisp ys = do Methods _ ms -> do handler <- newName "handler" - let env = VarE getEnv `AppE` route + env <- [|$(return $ VarE getEnv) (Just $(return route))|] -- Run the whole thing runner <- [|$(return $ VarE handler) @@ -325,10 +321,12 @@ buildCaller mds xrest parents name resDisp ys = do 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 + body405 <- + [|$(mds405 mds) + $(return $ VarE getEnv) + $(return route) + $(return $ VarE req) + |] return $ CaseE mf [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) [] , Match (ConP 'Nothing []) (NormalB body405) [] @@ -339,8 +337,6 @@ buildCaller mds xrest parents name resDisp ys = do let sub2 = LamE [VarP sub] (foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys) [|$(mdsDispatcher mds) - $(return $ VarE app404) - ($(return $ VarE handler405) . $(return route)) ($(mdsFixEnv mds) $(return sub2) $(return route)