haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Beginning of a dispatch overhaul

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-12 10:21:26 +02:00
parent 9873b4d8f3
commit 04a034770b
10 changed files with 249 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
yesod-core/Yesod/Core/Class/Dispatch.hs
View File

@ -1,53 +1,26 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Yesod.Core.Class.Dispatch where module Yesod.Core.Class.Dispatch where
import Yesod.Core.Content
import Yesod.Core.Handler
import Yesod.Routes.Class import Yesod.Routes.Class
import qualified Network.Wai as W 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.Types
import Yesod.Core.Class.Yesod 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 -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.
class YesodDispatch sub master where class YesodDispatch sub master where
yesodDispatch yesodDispatch
:: Yesod master :: 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 -> 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 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)

56
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -43,14 +43,11 @@ import Network.Wai.Middleware.Autohead
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Monoid (mappend) import Data.Monoid (mappend)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Blaze.ByteString.Builder import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301) import Network.HTTP.Types (status301)
import Yesod.Routes.TH import Yesod.Routes.TH
import Yesod.Core.Content (toTypedContent)
import Yesod.Routes.Parse import Yesod.Routes.Parse
import System.Log.FastLogger (Logger) import System.Log.FastLogger (Logger)
import Yesod.Core.Types import Yesod.Core.Types
@ -132,7 +129,7 @@ mkYesodGeneral name args clazzes isSub resS = do
res = map (fmap parseType) resS res = map (fmap parseType) resS
subCons = conT $ mkName name subCons = conT $ mkName name
subArgs = map (varT. mkName) args subArgs = map (varT. mkName) args
-- | If the generation of @'YesodDispatch'@ instance require finer -- | If the generation of @'YesodDispatch'@ instance require finer
-- control of the types, contexts etc. using this combinator. You will -- control of the types, contexts etc. using this combinator. You will
-- hardly need this generality. However, in certain situations, like -- hardly need this generality. However, in certain situations, like
@ -144,23 +141,18 @@ mkDispatchInstance :: CxtQ -- ^ The context
-> [ResourceTree a] -- ^ The resource -> [ResourceTree a] -- ^ The resource
-> DecsQ -> DecsQ
mkDispatchInstance context sub master res = do 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 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 -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This is the same as 'toWaiAppPlain', except it includes two -- handler. This is the same as 'toWaiAppPlain', except it includes two
@ -186,15 +178,23 @@ toWaiApp' :: ( Yesod master
-> Logger -> Logger
-> Maybe (SessionBackend master) -> Maybe (SessionBackend master)
-> W.Application -> 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 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 :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env = sendRedirect y segments' env =

8
yesod-core/Yesod/Core/Internal/Request.hs
View File

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

23
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -234,11 +234,11 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
I.readIORef ret I.readIORef ret
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} {-# 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 | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
| otherwise = do | otherwise = do
let dontSaveSession _ = return [] let dontSaveSession _ = return []
@ -351,3 +351,16 @@ resolveApproot master req =
ApprootStatic t -> t ApprootStatic t -> t
ApprootMaster f -> f master ApprootMaster f -> f master
ApprootRequest f -> f master req 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
}

4
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

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

2
yesod-core/yesod-core.cabal
View File

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

149
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

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

77
yesod-routes/test/Hierarchy.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
@ -12,6 +13,8 @@ module Hierarchy
, Handler , Handler
, App , App
, toText , toText
, Env (..)
, fixEnv
) where ) where
import Test.Hspec import Test.Hspec
@ -22,6 +25,8 @@ import Yesod.Routes.Class
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import qualified Yesod.Routes.Class as YRC import qualified Yesod.Routes.Class as YRC
import Data.Text (Text, pack, append) import Data.Text (Text, pack, append)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
class ToText a where class ToText a where
toText :: a -> Text toText :: a -> Text
@ -29,27 +34,41 @@ class ToText a where
instance ToText Text where toText = id instance ToText Text where toText = id
instance ToText String where toText = pack 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 class Dispatcher sub master where
dispatcher 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 -> (YRC.Route sub -> App sub master) -- ^ 405 page
-> Text -- ^ method -> (YRC.Route sub -> Env sub master)
-> [Text]
-> App sub master -> App sub master
class RunHandler sub master where class RunHandler sub master where
runHandler 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 -> App sub master
data Hierarchy = Hierarchy data Hierarchy = Hierarchy
@ -63,7 +82,14 @@ do
/table/#Text TableR GET /table/#Text TableR GET
|] |]
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources 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 return
$ InstanceD $ InstanceD
[] []
@ -73,23 +99,23 @@ do
[FunD (mkName "dispatcher") [dispatch]] [FunD (mkName "dispatcher") [dispatch]]
: rrinst : rrinst
getHomeR :: Handler sub master getHomeR :: Handler sub master String
getHomeR = "home" getHomeR = "home"
getAdminRootR :: Int -> Handler sub master getAdminRootR :: Int -> Handler sub master Text
getAdminRootR i = pack $ "admin root: " ++ show i getAdminRootR i = pack $ "admin root: " ++ show i
getLoginR :: Int -> Handler sub master getLoginR :: Int -> Handler sub master Text
getLoginR i = pack $ "login: " ++ show i getLoginR i = pack $ "login: " ++ show i
postLoginR :: Int -> Handler sub master postLoginR :: Int -> Handler sub master Text
postLoginR i = pack $ "post login: " ++ show i 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 getTableR _ t = append "TableR " t
instance RunHandler Hierarchy master where instance RunHandler Hierarchy master where
runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute) runHandler h Env {..} _ = (toText h, fmap envToMaster envRoute)
hierarchy :: Spec hierarchy :: Spec
hierarchy = describe "hierarchy" $ do hierarchy = describe "hierarchy" $ do
@ -97,6 +123,15 @@ hierarchy = describe "hierarchy" $ do
renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], []) renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
it "renders table correctly" $ it "renders table correctly" $
renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], []) 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 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") it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")

47
yesod-routes/test/main.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
@ -20,6 +21,7 @@ import Yesod.Routes.Overlap (findOverlapNames)
import Yesod.Routes.TH hiding (Dispatch) import Yesod.Routes.TH hiding (Dispatch)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Hierarchy import Hierarchy
import qualified Data.ByteString.Char8 as S8
result :: ([Text] -> Maybe Int) -> Dispatch Int result :: ([Text] -> Maybe Int) -> Dispatch Int
result f ts = f ts result f ts = f ts
@ -106,7 +108,14 @@ do
] ]
addCheck = map ((,) True) addCheck = map ((,) True)
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress 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 return
$ InstanceD $ InstanceD
[] []
@ -117,16 +126,29 @@ do
: rrinst : rrinst
instance RunHandler MyApp master where 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 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 instance Dispatcher MySubParam master where
dispatcher _ (MySubParam i) toMaster app404 _ _ pieces = dispatcher app404 _405 getEnv (pieces, method) =
case map unpack pieces of 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 thDispatchAlias
@ -232,10 +254,19 @@ main = hspec $ do
@?= (map pack ["subparam", "6", "c"], []) @?= (map pack ["subparam", "6", "c"], [])
describe "thDispatch" $ do 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 "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR)
it "POST root is 405" $ disp "POST" [] @?= (pack "405", 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"] it "routes to blog post" $ disp "GET" ["blog", "somepost"]
@?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost") @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost")
it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"] it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]

3
yesod-routes/yesod-routes.cabal
View File

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