{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE CPP #-}{-# LANGUAGE OverloadedStrings #-}{-# OPTIONS_GHC -fno-warn-orphans #-}moduleYesod.Dispatch(-- * Quasi-quoted routingparseRoutes,mkYesod,mkYesodSub-- ** More fine-grained,mkYesodData,mkYesodDispatch-- ** Path pieces,SinglePiece(..),MultiPiece(..),Strings-- * Convert to WAI,toWaiApp,basicHandler,basicHandler'#if TEST,testSuite#endif)where#if TESTimportYesod.Yesodhiding(testSuite)importYesod.Handlerhiding(testSuite)#elseimportYesod.YesodimportYesod.Handler#endifimportYesod.RequestimportYesod.InternalimportWeb.Routes.QuasiimportWeb.Routes.Quasi.ParseimportWeb.Routes.Quasi.THimportLanguage.Haskell.TH.SyntaximportYesod.WebRoutesimportqualifiedNetwork.WaiasWimportNetwork.Wai.Middleware.CleanPath(cleanPathFunc)importNetwork.Wai.Middleware.JsonpimportNetwork.Wai.Middleware.GzipimportqualifiedNetwork.Wai.Handler.SimpleServerasSSimportqualifiedNetwork.Wai.Handler.CGIasCGIimportSystem.Environment(getEnvironment)importqualifiedData.ByteString.Char8asBimportqualifiedData.ByteString.UTF8asSimportControl.Concurrent.MVarimportControl.Arrow((***))importData.TimeimportControl.MonadimportData.MaybeimportWeb.ClientSessionimportqualifiedWeb.ClientSessionasCSimportData.Char(isLower,isUpper)importData.SerializeimportqualifiedData.SerializeasSerimportNetwork.Wai.Parsehiding(FileInfo)importqualifiedNetwork.Wai.ParseasNWPimportData.String(fromString)#if TESTimportTest.Framework(testGroup,Test)importTest.Framework.Providers.QuickCheck2(testProperty)importTest.QuickCheckimportSystem.IO.UnsafeimportYesod.Contenthiding(testSuite)importData.Serialize.GetimportData.Serialize.Put#elseimportYesod.Content#endif-- | Generates URL datatype and site function for the given 'Resource's. This-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.-- Use 'parseRoutes' to create the 'Resource's.mkYesod::String-- ^ name of the argument datatype->[Resource]->Q[Dec]mkYesodname=fmap(uncurry(++)).mkYesodGeneralname[][]False-- | Generates URL datatype and site function for the given 'Resource's. This-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.-- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not-- executable by itself, but instead provides functionality to-- be embedded in other sites.mkYesodSub::String-- ^ name of the argument datatype->Cxt->[Resource]->Q[Dec]mkYesodSubnameclazzes=fmap(uncurry(++)).mkYesodGeneralname'restclazzesTruewhere(name':rest)=wordsname-- | Sometimes, you will want to declare your routes in one file and define-- your handlers elsewhere. For example, this is the only way to break up a-- monolithic file into smaller parts. Use this function, paired with-- 'mkYesodDispatch', to do just that.mkYesodData::String->[Resource]->Q[Dec]mkYesodDatanameres=do(x,_)<-mkYesodGeneralname[][]Falseresletrname=mkName$"resources"++nameeres<-liftreslety=[SigDrname$ListT`AppT`ConT''Resource,FunDrname[Clause[](NormalBeres)[]]]return$x++y-- | See 'mkYesodData'.mkYesodDispatch::String->[Resource]->Q[Dec]mkYesodDispatchname=fmapsnd.mkYesodGeneralname[][]FalsemkYesodGeneral::String-- ^ argument name->[String]-- ^ parameters for site argument->Cxt-- ^ classes->Bool-- ^ is subsite?->[Resource]->Q([Dec],[Dec])mkYesodGeneralnameargsclazzesisSubres=doletname'=mkNamenameargs'=mapmkNameargsarg=foldlAppT(ConTname')$mapVarTargs'th<-mapM(thResourceFromResourcearg)res-- FIXME now we cannot have multi-nested subsitesw'<-createRoutesthletroutesName=mkName$name++"Route"letw=DataD[]routesName[]w'[''Show,''Read,''Eq]letx=TySynInstD''Route[arg]$ConTroutesNameparse'<-createParsethparse''<-newName"parse"letparse=LetE[FunDparse''parse']$VarEparse''render'<-createRenderthrender''<-newName"render"letrender=LetE[FunDrender''render']$VarErender''tmh<-[|toMasterHandler|]modMaster<-[|fmapchooseRep|]dispatch'<-createDispatchmodMastertmhthdispatch''<-newName"dispatch"letdispatch=LetE[FunDdispatch''dispatch']$LamE[WildP]$VarEdispatch''site<-[|Site|]letsite'=site`AppE`dispatch`AppE`render`AppE`parselet(ctx,ytyp,yfunc)=ifisSubthen(clazzes,ConT''YesodSubSite`AppT`arg`AppT`VarT(mkName"master"),"getSubSite")else([],ConT''YesodSite`AppT`arg,"getSite")lety=InstanceDctxytyp[FunD(mkNameyfunc)[Clause[](NormalBsite')[]]]return([w,x],[y])isStatic::Piece->BoolisStaticStaticPiece{}=TrueisStatic_=FalsefromStatic::Piece->StringfromStatic(StaticPieces)=sfromStatic_=error"fromStatic"thResourceFromResource::Type->Resource->QTHResourcethResourceFromResource_(Resourcenpsattribs)|all(allisUpper)attribs=return(n,Simplepsattribs)thResourceFromResourcemaster(Resourcenpsatts@[stype,toSubArg])|allisStaticps&&any(anyisLower)atts=doletstype'=ConT$mkNamestypegss<-[|getSubSite|]letinside=ConT''Maybe`AppT`(ConT''GHandler`AppT`stype'`AppT`master`AppT`ConT''ChooseRep)lettyp=ConT''Site`AppT`(ConT''Route`AppT`stype')`AppT`(ArrowT`AppT`ConT''String`AppT`inside)letgss'=gss`SigE`typparse'<-[|parsePathSegments|]letparse=parse'`AppE`gss'render'<-[|formatPathSegments|]letrender=render'`AppE`gss'dispatch'<-[|fliphandleSite(error"Cannot use subsite render function")|]letdispatch=dispatch'`AppE`gss'return(n,SubSite{ssType=ConT''Route`AppT`stype',ssParse=parse,ssRender=render,ssDispatch=dispatch,ssToMasterArg=VarE$mkNametoSubArg,ssPieces=mapfromStaticps})thResourceFromResource_(Resourcen__)=error$"Invalid attributes for resource: "++nsessionName::StringsessionName="_SESSION"-- | Convert the given argument into a WAI application, executable with any WAI-- handler. You can use 'basicHandler' if you wish.toWaiApp::(Yesody,YesodSitey)=>y->IOW.ApplicationtoWaiAppa=return$gzip$jsonp$cleanPathFunc(splitPatha)(B.pack$approota)$toWaiApp'atoWaiApp'::(Yesody,YesodSitey)=>y->[String]->W.Request->IOW.ResponsetoWaiApp'ysegmentsenv=dokey'<-encryptKeyynow<-getCurrentTimeletgetExpiresm=fromIntegral(m*60)`addUTCTime`nowletexp'=getExpires$clientSessionDurationylethost=W.remoteHostenvletsession'=fromMaybe[]$doraw<-lookup"Cookie"$W.requestHeadersenvval<-lookup(B.packsessionName)$parseCookiesrawdecodeSessionkey'nowhostvalletsite=getSitemethod=B.unpack$W.requestMethodenvtypes=httpAcceptenvpathSegments=filter(not.null)segmentseurl=parsePathSegmentssitepathSegmentsrenderuqs=let(ps,qs')=formatPathSegmentssiteuinfromMaybe(joinPathy(approoty)ps$qs++qs')(urlRenderOverrideyu)leterrorHandler'=localNoCurrent.errorHandlerrr<-parseWaiRequestenvsession'leth=doonRequestcaseeurlofLeft_->errorHandler'NotFoundRighturl->doisWrite<-isWriteRequesturlar<-isAuthorizedurlisWritecasearofAuthorized->return()AuthenticationRequired->caseauthRouteyofNothing->permissionDenied"Authentication required"Justurl'->dosetUltDest'redirectRedirectTemporaryurl'Unauthorizeds->permissionDeniedscasehandleSitesiterenderurlmethodofNothing->errorHandler'$BadMethodmethodJusth'->h'leteurl'=either(constNothing)Justeurlleteher=runHandler(errorHandler'er)rendereurl'idyidletya=runHandlerhrendereurl'idyid(s,hs,ct,c,sessionFinal)<-unYesodAppyaehrrtypesletsessionVal=encodeSessionkey'exp'hostsessionFinalleths'=AddCookie(clientSessionDurationy)sessionName(S.toStringsessionVal):hshs''=map(headerToPairgetExpires)hs'hs'''=("Content-Type",S.fromStringct):hs''return$W.Responseshs'''chttpAccept::W.Request->[ContentType]httpAccept=mapB.unpack.parseHttpAccept.fromMaybeB.empty.lookup"Accept".W.requestHeaders-- | Runs an application with CGI if CGI variables are present (namely-- PATH_INFO); otherwise uses SimpleServer.basicHandler::(Yesody,YesodSitey)=>Int-- ^ port number->y->IO()basicHandlerporty=basicHandler'port(Just"localhost")y-- | Same as 'basicHandler', but allows you to specify the hostname to display-- to the user. If 'Nothing' is provided, then no output is produced.basicHandler'::(Yesody,YesodSitey)=>Int-- ^ port number->MaybeString-- ^ host name, 'Nothing' to show nothing->y->IO()basicHandler'portmhosty=doapp<-toWaiAppyvars<-getEnvironmentcaselookup"PATH_INFO"varsofNothing->docasemhostofNothing->return()Justh->putStrLn$concat["http://",h,":",showport,"/"]SS.runportappJust_->CGI.runappparseWaiRequest::W.Request->[(String,String)]-- ^ session->IORequestparseWaiRequestenvsession'=doletgets'=map(S.toString***S.toString)$parseQueryString$W.queryStringenvletreqCookie=fromMaybeB.empty$lookup"Cookie"$W.requestHeadersenvcookies'=map(S.toString***S.toString)$parseCookiesreqCookieacceptLang=lookup"Accept-Language"$W.requestHeadersenvlangs=mapS.toString$maybe[]parseHttpAcceptacceptLanglangs'=caselookuplangKeysession'ofNothing->langsJustx->x:langslangs''=caselookuplangKeycookies'ofNothing->langs'Justx->x:langs'langs'''=caselookuplangKeygets'ofNothing->langs''Justx->x:langs''rbthunk<-iothunk$rbHelperenvreturn$Requestgets'cookies'session'rbthunkenvlangs'''rbHelper::W.Request->IORequestBodyContentsrbHelper=fmap(fix1***mapfix2).parseRequestBodylbsSinkwherefix1=map(S.toString***S.toString)fix2(x,NWP.FileInfoabc)=(S.toStringx,FileInfo(S.toStringa)(S.toStringb)c)-- | Produces a \"compute on demand\" value. The computation will be run once-- it is requested, and then the result will be stored. This will happen only-- once.iothunk::IOa->IO(IOa)iothunk=fmapgo.newMVar.Leftwherego::MVar(Either(IOa)a)->IOagomvar=modifyMVarmvargo'go'::Either(IOa)a->IO(Either(IOa)a,a)go'(Rightval)=return(Rightval,val)go'(Leftcomp)=doval<-compreturn(Rightval,val)-- | Convert Header to a key/value pair.headerToPair::(Int->UTCTime)-- ^ minutes -> expiration time->Header->(W.ResponseHeader,B.ByteString)headerToPairgetExpires(AddCookieminuteskeyvalue)=letexpires=getExpiresminutesin("Set-Cookie",S.fromString$key++"="++value++"; path=/; expires="++formatW3expires)headerToPair_(DeleteCookiekey)=("Set-Cookie",S.fromString$key++"=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")headerToPair_(Headerkeyvalue)=(fromStringkey,S.fromStringvalue)encodeSession::CS.Key->UTCTime-- ^ expire time->B.ByteString-- ^ remote host->[(String,String)]-- ^ session->B.ByteString-- ^ cookie valueencodeSessionkeyexpirerhostsession'=encryptkey$encode$SessionCookieexpirerhostsession'decodeSession::CS.Key->UTCTime-- ^ current time->B.ByteString-- ^ remote host field->B.ByteString-- ^ cookie value->Maybe[(String,String)]decodeSessionkeynowrhostencrypted=dodecrypted<-decryptkeyencryptedSessionCookieexpirerhost'session'<-either(constNothing)Just$decodedecryptedguard$expire>nowguard$rhost'==rhostreturnsession'dataSessionCookie=SessionCookieUTCTimeB.ByteString[(String,String)]deriving(Show,Read)instanceSerializeSessionCookiewhereput(SessionCookieabc)=putTimea>>putb>>putcget=doa<-getTimeb<-Ser.getc<-Ser.getreturn$SessionCookieabcputTime::PutterUTCTimeputTimet@(UTCTimed_)=doput$toModifiedJulianDaydletndt=diffUTCTimet$UTCTimed0put$toRationalndtgetTime::GetUTCTimegetTime=dod<-Ser.getndt<-Ser.getreturn$fromRationalndt`addUTCTime`UTCTime(ModifiedJulianDayd)0#if TESTtestSuite::TesttestSuite=testGroup"Yesod.Dispatch"[testProperty"encode/decode session"propEncDecSession,testProperty"get/put time"propGetPutTime]propEncDecSession::[(String,String)]->BoolpropEncDecSessionsession'=unsafePerformIO$dokey<-getDefaultKeynow<-getCurrentTimeletexpire=addUTCTime1nowletrhost=B.pack"some host"letval=encodeSessionkeyexpirerhostsession'return$Justsession'==decodeSessionkeynowrhostvalpropGetPutTime::UTCTime->BoolpropGetPutTimet=Rightt==runGetgetTime(runPut$putTimet)instanceArbitraryUTCTimewherearbitrary=doa<-arbitraryb<-arbitraryreturn$addUTCTime(fromRationalb)$UTCTime(ModifiedJulianDaya)0#endif