Beginning of a dispatch overhaul
This commit is contained in:
Michael Snoyman
parent
9873b4d8f3
commit
04a034770b
@ -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)
|
||||
|
||||
@ -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 =
|
||||
|
||||
@ -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.
|
||||
--
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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|
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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"]
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user