diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index bb91b84e..a7ae1dd9 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/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 - -> master - -> sub - -> (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 -- ^ 404 handler + -> (Route sub -> W.Application) -- ^ 405 handler + -> (Route sub -> YesodRunnerEnv sub 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) diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 53a0fb25..bfdc299c 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/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 @@ -132,7 +129,7 @@ mkYesodGeneral name args clazzes isSub resS = do res = map (fmap parseType) resS subCons = conT $ mkName name subArgs = map (varT. mkName) args - + -- | If the generation of @'YesodDispatch'@ instance require finer -- control of the types, contexts etc. using this combinator. You will -- hardly need this generality. However, in certain situations, like @@ -144,23 +141,18 @@ mkDispatchInstance :: CxtQ -- ^ The context -> [ResourceTree a] -- ^ The resource -> DecsQ mkDispatchInstance context sub master res = do - logger <- newName "logger" - let loggerE = varE logger - loggerP = VarP logger - yDispatch = conT ''YesodDispatch `appT` sub `appT` master + let yDispatch = conT ''YesodDispatch `appT` sub `appT` master thisDispatch = do - Clause pat body decs <- mkDispatchClause - [|yesodRunner $loggerE |] - [|yesodDispatch $loggerE |] - [|fmap toTypedContent|] - res - return $ FunD 'yesodDispatch - [ Clause (loggerP:pat) - body - decs - ] - in sequence [instanceD context yDispatch [thisDispatch]] - + clause' <- mkDispatchClause MkDispatchSettings + { mdsRunHandler = [|yesodRunner|] + , mdsDispatcher = [|yesodDispatch |] + , mdsFixEnv = [|fixEnv|] + , mdsGetPathInfo = [|W.pathInfo|] + , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] + , mdsMethod = [|W.requestMethod|] + } res + return $ FunD 'yesodDispatch [clause'] + 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 = - case cleanPath y $ W.pathInfo env of - Left pieces -> sendRedirect y pieces env - Right pieces -> - yesodDispatch logger y y id app404 handler405 method pieces sb env +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 + { W.pathInfo = pieces + } where - app404 = yesodRunner logger notFound y y Nothing id - handler405 route = yesodRunner logger badMethod y y (Just route) id - method = decodeUtf8With lenientDecode $ W.requestMethod env + yre route = YesodRunnerEnv + { yreLogger = logger + , 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 = diff --git a/yesod-core/Yesod/Core/Internal/Request.hs b/yesod-core/Yesod/Core/Internal/Request.hs index f52d07fc..0b2502b1 100644 --- a/yesod-core/Yesod/Core/Internal/Request.hs +++ b/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 "") - $ queryToQueryText - $ W.queryString env + gets = textQueryString 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. -- diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 5beab696..59f8b9c5 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/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 - => YesodRunnerEnv sub master - -> GHandler sub master TypedContent - -> Application -defaultYesodRunner YesodRunnerEnv {..} handler' req +yesodRunner :: (ToTypedContent res, Yesod master) + => GHandler sub master res + -> YesodRunnerEnv sub master + -> Application +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 + } diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index a88246c0..e3c8c739 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/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| diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 0a2011f4..dd44cec1 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index a52f69ad..6c7b11b6 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/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 - -> Q Exp -- ^ dispatcher function - -> Q Exp -- ^ fixHandler function +mkDispatchClause :: MkDispatchSettings -> [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" - pieces0 <- newName "pieces0" + getEnv0 <- newName "getEnv0" + 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) - $(return $ VarE sub0) - $(return $ VarE toMaster0) - $(return $ VarE app4040) + Just f -> f $(return $ VarE app4040) $(return $ VarE handler4050) - $(return $ VarE method0) - Nothing -> $(return $ VarE app4040) + $(return $ VarE getEnv0) + $(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) - return $ TupE [pack' `AppE` LitE (StringL method), rhs] + runHandler <- mdsRunHandler mds + 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 runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do +buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp +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 - -> Q Exp -- ^ dispatcher - -> Q Exp -- ^ fixHandler +routeArg3 :: MkDispatchSettings -> [(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 - -> Q Exp -- ^ dispatcher - -> Q Exp -- ^ fixHandler +buildCaller :: MkDispatchSettings -> 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 - master <- newName "master" - sub <- newName "sub" - toMaster <- newName "toMaster" +buildCaller mds xrest parents name resDisp ys = do + getEnv <- newName "getEnv" 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) - $(return $ VarE handler) - $(return $ VarE master) - $(return $ VarE sub) - (Just $(return route)) - $(return $ VarE toMaster)|] + runner <- [|$(return $ VarE handler) + $(return env) + $(return $ VarE req) + |] 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 = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys - return $ myLet he + let he = foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys + runHandler <- mdsRunHandler mds + 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 - [|$(dispatcher) - $(return $ VarE master) - $(return sub2) - ($(return $ VarE toMaster) . $(return route)) + sub <- newName "sub" + 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)) - $(return $ VarE method) - $(return $ VarE xrest) + ($(mdsFixEnv mds) + $(return sub2) + $(return route) + $(return $ VarE getEnv) + ) + ($(mdsSetPathInfo mds) + $(return $ VarE xrest) + $(return $ VarE req) + ) |] return $ LamE pat exp diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index a4bf6316..9543f0d7 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/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 App sub master = (Text, Maybe (YRC.Route master)) +type Handler sub master a = a +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 - -> sub - -> (YRC.Route sub -> YRC.Route master) - -> App sub master -- ^ 404 page + :: App sub master -- ^ 404 page -> (YRC.Route sub -> App sub master) -- ^ 405 page - -> Text -- ^ method - -> [Text] + -> (YRC.Route sub -> Env sub master) -> App sub master class RunHandler sub master where runHandler - :: Handler sub master - -> master - -> sub - -> Maybe (YRC.Route sub) - -> (YRC.Route sub -> YRC.Route master) + :: ToText a + => Handler sub master a + -> Env sub 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") diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 16db9be9..dedfa0c9 100644 --- a/yesod-routes/test/main.hs +++ b/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) - _ -> app404 + [[c]] -> + 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"] diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index eb367b35..7fdb7a0a 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/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 @@ -46,6 +46,7 @@ test-suite runtests , containers , template-haskell , path-pieces + , bytestring ghc-options: -Wall source-repository head