{-# LANGUAGE TemplateHaskell #-}moduleYesod.Routes.TH.Dispatch(-- ** DispatchmkDispatchClause,MkDispatchSettings(..),defaultGetHandler)whereimportPreludehiding(exp)importYesod.Routes.TH.TypesimportLanguage.Haskell.TH.SyntaximportData.Maybe(catMaybes)importControl.Monad(forM,replicateM)importData.Text(pack)importqualifiedYesod.Routes.DispatchasDimportqualifiedData.MapasMapimportData.Char(toLower)importWeb.PathPieces(PathPiece(..),PathMultiPiece(..))importControl.Applicative((<$>))importData.List(foldl')importData.Text.Encoding(encodeUtf8)dataMkDispatchSettings=MkDispatchSettings{mdsRunHandler::QExp,mdsSubDispatcher::QExp,mdsGetPathInfo::QExp,mdsSetPathInfo::QExp,mdsMethod::QExp,mds404::QExp,mds405::QExp,mdsGetHandler::MaybeString->String->QExp}defaultGetHandler::MaybeString->String->QExpdefaultGetHandlerNothings=return$VarE$mkName$"handle"++sdefaultGetHandler(Justmethod)s=return$VarE$mkName$maptoLowermethod++s-- |---- This function will generate a single clause that will address all-- your routing needs. It takes four arguments. The fourth (a list of-- 'Resource's) is self-explanatory. We\'ll discuss the first-- three. But first, let\'s cover the terminology.---- Dispatching involves a master type and a sub type. When you dispatch to the-- top level type, master and sub are the same. Each time to dispatch to-- another subsite, the sub changes. This requires two changes:---- * Getting the new sub value. This is handled via 'subsiteFunc'.---- * Figure out a way to convert sub routes to the original master route. To-- address this, we keep a toMaster function, and each time we dispatch to a-- new subsite, we compose it with the constructor for that subsite.---- Dispatching acts on two different components: the request method and a list-- of path pieces. If we cannot match the path pieces, we need to return a 404-- response. If the path pieces match, but the method is not supported, we need-- to return a 405 response.---- The final result of dispatch is going to be an application type. A simple-- example would be the WAI Application type. However, our handler functions-- will need more input: the master/subsite, the toMaster function, and the-- type-safe route. Therefore, we need to have another type, the handler type,-- and a function that turns a handler into an application, i.e.---- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app---- This is the first argument to our function. Note that this will almost-- certainly need to be a method of a typeclass, since it will want to behave-- differently based on the subsite.---- Note that the 404 response passed in is an application, while the 405-- response is a handler, since the former can\'t be passed the type-safe-- route.---- In the case of a subsite, we don\'t directly deal with a handler function.-- Instead, we redispatch to the subsite, passing on the updated sub value and-- toMaster function, as well as any remaining, unparsed path pieces. This-- function looks like:---- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app---- Where the parameters mean master, sub, toMaster, 404 response, 405 response,-- request method and path pieces. This is the second argument of our function.---- Finally, we need a way to decide which of the possible formats-- should the handler send the data out. Think of each URL holding an-- abstract object which has multiple representation (JSON, plain HTML-- etc). Each client might have a preference on which format it wants-- the abstract object in. For example, a javascript making a request-- (on behalf of a browser) might prefer a JSON object over a plain-- HTML file where as a user browsing with javascript disabled would-- want the page in HTML. The third argument is a function that-- converts the abstract object to the desired representation-- depending on the preferences sent by the client.---- The typical values for the first three arguments are,-- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and-- @fmap 'chooseRep'@.mkDispatchClause::MkDispatchSettings->[ResourceTreea]->QClausemkDispatchClausemdsress'=do-- Allocate the names to be used. Start off with the names passed to the-- function itself (with a 0 suffix).---- We don't reuse names so as to avoid shadowing names (triggers warnings-- 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.getEnv0<-newName"yesod_dispatch_env0"req0<-newName"req0"pieces<-[|$(mdsGetPathInfomds)$(return$VarEreq0)|]-- Name of the dispatch functiondispatch<-newName"dispatch"-- Dispatch function applied to the piecesletdispatched=VarEdispatch`AppE`pieces-- The 'D.Route's used in the dispatch functionroutes<-mapM(buildRoutemds)ress-- The dispatch function itselftoDispatch<-[|D.toDispatch|]letdispatchFun=FunDdispatch[Clause[](NormalB$toDispatch`AppE`ListEroutes)[]]-- The input to the clause.letpats=mapVarP[getEnv0,req0]-- For each resource that dispatches based on methods, build up a map for handling the dispatching.methodMaps<-catMaybes<$>mapM(buildMethodMapmds)ressu<-[|case$(returndispatched)ofJustf->f$(return$VarEgetEnv0)$(return$VarEreq0)Nothing->$(mdsRunHandlermds)$(mds404mds)$(return$VarEgetEnv0)Nothing$(return$VarEreq0)|]return$Clausepats(NormalBu)$dispatchFun:methodMapswhereress=flattenress'-- | Determine the name of the method map for a given resource name.methodMapName::String->NamemethodMapNames=mkName$"methods"++sbuildMethodMap::MkDispatchSettings->FlatResourcea->Q(MaybeDec)buildMethodMap_(FlatResource___(Methods_[]))=returnNothing-- single handle functionbuildMethodMapmds(FlatResourceparentsnamepieces'(Methodsmmultimethods))=dofromList<-[|Map.fromList|]methods'<-mapMgomethodsletexp=fromList`AppE`ListEmethods'letfun=FunD(methodMapNamename)[Clause[](NormalBexp)[]]return$Justfunwherepieces=concat$mapsndparents++[pieces']gomethod=dofunc<-mdsGetHandlermds(Justmethod)namepack'<-[|encodeUtf8.pack|]letisDynamicDynamic{}=TrueisDynamic_=FalseletargCount=length(filter(isDynamic.snd)pieces)+maybe0(const1)mmultixs<-replicateMargCount$newName"arg"runHandler<-mdsRunHandlermdsletrhs|nullxs=runHandler`AppE`func|otherwise=LamE(mapVarPxs)$runHandler`AppE`(foldl'AppEfunc$mapVarExs)return$TupE[pack'`AppE`LitE(StringLmethod),rhs]buildMethodMap_(FlatResource___Subsite{})=returnNothing-- | Build a single 'D.Route' expression.buildRoute::MkDispatchSettings->FlatResourcea->QExpbuildRoutemds(FlatResourceparentsnameresPiecesresDisp)=do-- First two arguments to D.RouteroutePieces<-ListE<$>mapM(convertPiece.snd)allPiecesisMulti<-caseresDispofMethodsNothing_->[|False|]_->[|True|][|D.Route$(returnroutePieces)$(returnisMulti)$(routeArg3mdsparentsname(mapsndallPieces)resDisp)|]whereallPieces=concat$mapsndparents++[resPieces]routeArg3::MkDispatchSettings->[(String,[(CheckOverlap,Piecea)])]->String-- ^ name of resource->[Piecea]->Dispatcha->QExprouteArg3mdsparentsnameresPiecesresDisp=dopieces<-newName"pieces"-- Allocate input piece variables (xs) and variables that have been-- converted via fromPathPiece (ys)xs<-forMresPieces$\piece->casepieceofStatic_->returnNothingDynamic_->Just<$>newName"x"-- Note: the zipping with Ints is just a workaround for (apparently) a bug-- in GHC where the identifiers are considered to be overlapping. Using-- newName should avoid the problem, but it doesn't.ys<-forM(zip(catMaybesxs)[1..])$\(x,i)->doy<-newName$"y"++show(i::Int)return(x,y)-- In case we have multi pieces at the endxrest<-newName"xrest"yrest<-newName"yrest"-- Determine the pattern for matching the piecespat<-caseresDispofMethodsNothing_->return$ListP$map(maybeWildPVarP)xs_->doletcons=mkName":"return$foldr(\ab->ConPcons[maybeWildPVarPa,b])(VarPxrest)xs-- Convert the xsfromPathPiece'<-[|fromPathPiece|]xstmts<-forMys$\(x,y)->return$BindS(VarPy)(fromPathPiece'`AppE`VarEx)-- Convert the xrest if appropriate(reststmts,yrest')<-caseresDispofMethods(Just_)_->dofromPathMultiPiece'<-[|fromPathMultiPiece|]return([BindS(VarPyrest)(fromPathMultiPiece'`AppE`VarExrest)],[yrest])_->return([],[])-- The final expression that actually uses the values we've computedcaller<-buildCallermdsxrestparentsnameresDisp$mapsndys++yrest'-- Put together all the statementsjust<-[|Just|]letstmts=concat[xstmts,reststmts,[NoBindS$just`AppE`caller]]errorMsg<-[|error"Invariant violated"|]letmatches=[Matchpat(NormalB$DoEstmts)[],MatchWildP(NormalBerrorMsg)[]]return$LamE[VarPpieces]$CaseE(VarEpieces)matches-- | The final expression in the individual Route definitions.buildCaller::MkDispatchSettings->Name-- ^ xrest->[(String,[(CheckOverlap,Piecea)])]->String-- ^ name of resource->Dispatcha->[Name]-- ^ ys->QExpbuildCallermdsxrestparentsnameresDispys=dogetEnv<-newName"yesod_dispatch_env"req<-newName"req"method<-[|$(mdsMethodmds)$(return$VarEreq)|]letpat=mapVarP[getEnv,req]-- Create the routeletroute=routeFromDynamicsparentsnameysexp<-caseresDispofMethods_ms->dohandler<-newName"handler"env<-[|$(return$VarEgetEnv)(Just$(returnroute))|]-- Run the whole thingrunner<-[|$(return$VarEhandler)$(return$VarEgetEnv)(Just$(returnroute))$(return$VarEreq)|]letmyLethandlerExp=LetE[FunDhandler[Clause[](NormalBhandlerExp)[]]]runnerifnullmsthendo-- Just a single handlerbase<-mdsGetHandlermdsNothingnamelethe=foldl'(\ab->a`AppE`VarEb)baseysrunHandler<-mdsRunHandlermdsreturn$myLet$runHandler`AppE`heelsedo-- Individual methodsmf<-[|Map.lookup$(returnmethod)$(return$VarE$methodMapNamename)|]f<-newName"f"letapply=foldl'(\ab->a`AppE`VarEb)(VarEf)ysbody405<-[|$(mdsRunHandlermds)$(mds405mds)$(return$VarEgetEnv)(Just$(returnroute))$(return$VarEreq)|]return$CaseEmf[Match(ConP'Just[VarPf])(NormalB$myLetapply)[],Match(ConP'Nothing[])(NormalBbody405)[]]Subsite_getSub->dosub<-newName"sub"letsub2=LamE[VarPsub](foldl'(\ab->a`AppE`VarEb)(VarE(mkNamegetSub)`AppE`VarEsub)ys)[|$(mdsSubDispatchermds)$(mdsRunHandlermds)$(returnsub2)$(returnroute)$(return$VarEgetEnv)($(mdsSetPathInfomds)$(return$VarExrest)$(return$VarEreq))|]return$LamEpatexp-- | Convert a 'Piece' to a 'D.Piece'convertPiece::Piecea->QExpconvertPiece(Statics)=[|D.Static(pack$(lifts))|]convertPiece(Dynamic_)=[|D.Dynamic|]routeFromDynamics::[(String,[(CheckOverlap,Piecea)])]-- ^ parents->String-- ^ constructor name->[Name]->ExprouteFromDynamics[]nameys=foldl'(\ab->a`AppE`VarEb)(ConE$mkNamename)ysrouteFromDynamics((parent,pieces):rest)nameys=foldl'(\ab->a`AppE`b)(ConE$mkNameparent)herewhere(here',ys')=splitAt(length$filter(isDynamic.snd)pieces)ysisDynamicDynamic{}=TrueisDynamic_=Falsehere=mapVarEhere'++[routeFromDynamicsrestnameys']