{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE EmptyDataDecls #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE PackageImports #-}{-# LANGUAGE RankNTypes #-}moduleSnap.Internal.Typeswhere------------------------------------------------------------------------------import"MonadCatchIO-transformers"Control.Monad.CatchIOimportBlaze.ByteString.BuilderimportBlaze.ByteString.Builder.Char.Utf8importControl.ApplicativeimportControl.Exception(throwIO,ErrorCall(..))importControl.MonadimportControl.Monad.StateimportData.ByteString.Char8(ByteString)importqualifiedData.ByteString.Char8asSimportqualifiedData.ByteString.Lazy.Char8asLimportqualifiedData.CIByteStringasCIBimportData.IntimportData.IORefimportData.MaybeimportData.MonoidimportqualifiedData.TextasTimportqualifiedData.Text.LazyasLTimportData.TypeableimportPreludehiding(catch,take)------------------------------------------------------------------importSnap.Internal.Http.TypesimportSnap.IterateeimportSnap.Internal.Iteratee.Debug-------------------------------------------------------------------------------- The Snap Monad------------------------------------------------------------------------------{-|
'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you:
1. stateful access to fetch or modify an HTTP 'Request'
2. stateful access to fetch or modify an HTTP 'Response'
3. failure \/ 'Alternative' \/ 'MonadPlus' semantics: a 'Snap' handler can
choose not to handle a given request, using 'empty' or its synonym 'pass',
and you can try alternative handlers with the '<|>' operator:
> a :: Snap String
> a = pass
>
> b :: Snap String
> b = return "foo"
>
> c :: Snap String
> c = a <|> b -- try running a, if it fails then try b
4. convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText',
'addToOutput') for writing output to the 'Response':
> a :: (forall a . Enumerator a) -> Snap ()
> a someEnumerator = do
> writeBS "I'm a strict bytestring"
> writeLBS "I'm a lazy bytestring"
> addToOutput someEnumerator
5. early termination: if you call 'finishWith':
> a :: Snap ()
> a = do
> modifyResponse $ setResponseStatus 500 "Internal Server Error"
> writeBS "500 error"
> r <- getResponse
> finishWith r
then any subsequent processing will be skipped and supplied 'Response'
value will be returned from 'runSnap' as-is.
6. access to the 'IO' monad through a 'MonadIO' instance:
> a :: Snap ()
> a = liftIO fireTheMissiles
7. the ability to set a timeout which will kill the handler thread after @N@
seconds of inactivity:
> a :: Snap ()
> a = setTimeout 30
You may notice that most of the type signatures in this module contain a
@(MonadSnap m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass which,
in essence, says \"you can get back to the 'Snap' monad from here\". Using
'MonadSnap' you can extend the 'Snap' monad with additional functionality and
still have access to most of the 'Snap' functions without writing 'lift'
everywhere. Instances are already provided for most of the common monad
transformers ('ReaderT', 'WriterT', 'StateT', etc.).
-}-------------------------------------------------------------------------------- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes-- it easy to wrap 'Snap' inside monad transformers.class(Monadm,MonadIOm,MonadCatchIOm,MonadPlusm,Functorm,Applicativem,Alternativem)=>MonadSnapmwhereliftSnap::Snapa->ma------------------------------------------------------------------------------newtypeSnapa=Snap{unSnap::StateTSnapState(IterateeByteStringIO)(Maybe(EitherResponsea))}------------------------------------------------------------------------------dataSnapState=SnapState{_snapRequest::Request,_snapResponse::Response,_snapLogError::ByteString->IO(),_snapSetTimeout::Int->IO()}------------------------------------------------------------------------------instanceMonadSnapwhere(Snapm)>>=f=Snap$doeth<-mmaybe(returnNothing)(either(return.Just.Left)(unSnap.f))ethreturn=Snap.return.Just.Rightfail=const$Snap$returnNothing------------------------------------------------------------------------------instanceMonadIOSnapwhereliftIOm=Snap$liftM(Just.Right)$liftIOm------------------------------------------------------------------------------instanceMonadCatchIOSnapwherecatch(Snapm)handler=Snap$dox<-trymcasexof(Lefte)->let(Snapz)=handlereinz(Righty)->returnyblock(Snapm)=Snap$blockmunblock(Snapm)=Snap$unblockm------------------------------------------------------------------------------instanceMonadPlusSnapwheremzero=Snap$returnNothinga`mplus`b=Snap$domb<-unSnapaifisJustmbthenreturnmbelseunSnapb------------------------------------------------------------------------------instanceFunctorSnapwherefmap=liftM------------------------------------------------------------------------------instanceApplicativeSnapwherepure=return(<*>)=ap------------------------------------------------------------------------------instanceAlternativeSnapwhereempty=mzero(<|>)=mplus------------------------------------------------------------------------------instanceMonadSnapSnapwhereliftSnap=id-------------------------------------------------------------------------------- | The Typeable instance is here so Snap can be dynamically executed with-- Hint.snapTyCon::TyConsnapTyCon=mkTyCon"Snap.Types.Snap"{-# NOINLINE snapTyCon #-}instanceTypeable1SnapwheretypeOf1_=mkTyConAppsnapTyCon[]------------------------------------------------------------------------------liftIter::MonadSnapm=>IterateeByteStringIOa->maliftIteri=liftSnap$Snap(lifti>>=return.Just.Right)-------------------------------------------------------------------------------- | Sends the request body through an iteratee (data consumer) and-- returns the result.runRequestBody::MonadSnapm=>IterateeByteStringIOa->marunRequestBodyiter=doreq<-getRequestsenum<-liftIO$readIORef$rqBodyreqlet(SomeEnumeratorenum)=senum-- make sure the iteratee consumes all of the outputletiter'=iter>>=\a->skipToEof>>returna-- run the iterateestep<-liftIO$runIterateeiter'result<-liftIter$enumstep-- stuff a new dummy enumerator into the request, so you can only try to-- read the request body from the socket onceliftIO$writeIORef(rqBodyreq)(SomeEnumerator$joinI.take0)returnresult-------------------------------------------------------------------------------- | Returns the request body as a bytestring.getRequestBody::MonadSnapm=>mL.ByteStringgetRequestBody=liftML.fromChunks$runRequestBodyconsume{-# INLINE getRequestBody #-}-------------------------------------------------------------------------------- | Normally Snap is careful to ensure that the request body is fully-- consumed after your web handler runs, but before the 'Response' enumerator-- is streamed out the socket. If you want to transform the request body into-- some output in O(1) space, you should use this function.---- Note that upon calling this function, response processing finishes early as-- if you called 'finishWith'. Make sure you set any content types, headers,-- cookies, etc. before you call this function.--transformRequestBody::(foralla.EnumeratorBuilderIOa)-- ^ the output 'Iteratee' is passed to this-- 'Enumerator', and then the resulting 'Iteratee' is-- fed the request body stream. Your 'Enumerator' is-- responsible for transforming the input.->Snap()transformRequestBodytrans=doreq<-getRequestletioref=rqBodyreqsenum<-liftIO$readIORefioreflet(SomeEnumeratorenum')=senumletenum=mapEnumtoByteStringfromByteStringenum'liftIO$writeIORefioref(SomeEnumeratorenumEOF)origRsp<-getResponseletrsp=setResponseBody(\writeEnd->doleti=iterateeDebugWrapperWithshowBuilder"transformRequestBody"$transwriteEndst<-liftIO$runIterateeienumst)$origRsp{rspTransformingRqBody=True}finishWithrsp-------------------------------------------------------------------------------- | Short-circuits a 'Snap' monad action early, storing the given-- 'Response' value in its state.finishWith::MonadSnapm=>Response->mafinishWith=liftSnap.Snap.return.Just.Left{-# INLINE finishWith #-}-------------------------------------------------------------------------------- | Capture the flow of control in case a handler calls 'finishWith'.---- /WARNING/: in the event of a call to 'transformRequestBody' it is possible-- to violate HTTP protocol safety when using this function. If you call-- 'catchFinishWith' it is suggested that you do not modify the body of the-- 'Response' which was passed to the 'finishWith' call.catchFinishWith::Snapa->Snap(EitherResponsea)catchFinishWith(Snapm)=Snap$doeth<-mmaybe(returnNothing)(either(\resp->return$Just$Right$Leftresp)(\a->return$Just$Right$Righta))eth{-# INLINE catchFinishWith #-}-------------------------------------------------------------------------------- | Fails out of a 'Snap' monad action. This is used to indicate-- that you choose not to handle the given request within the given-- handler.pass::MonadSnapm=>mapass=empty-------------------------------------------------------------------------------- | Runs a 'Snap' monad action only if the request's HTTP method matches-- the given method.method::MonadSnapm=>Method->ma->mamethodmaction=doreq<-getRequestunless(rqMethodreq==m)passaction{-# INLINE method #-}-------------------------------------------------------------------------------- | Runs a 'Snap' monad action only if the request's HTTP method matches-- one of the given methods.methods::MonadSnapm=>[Method]->ma->mamethodsmsaction=doreq<-getRequestunless(rqMethodreq`elem`ms)passaction{-# INLINE methods #-}-------------------------------------------------------------------------------- Appends n bytes of the path info to the context path with a-- trailing slash.updateContextPath::Int->Request->RequestupdateContextPathnreq|n>0=req{rqContextPath=ctx,rqPathInfo=pinfo}|otherwise=reqwherectx'=S.taken(rqPathInforeq)ctx=S.concat[rqContextPathreq,ctx',"/"]pinfo=S.drop(n+1)(rqPathInforeq)-------------------------------------------------------------------------------- Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given-- predicate.pathWith::MonadSnapm=>(ByteString->ByteString->Bool)->ByteString->ma->mapathWithcpaction=doreq<-getRequestunless(cp(rqPathInforeq))passlocalRequest(updateContextPath$S.lengthp)action-------------------------------------------------------------------------------- | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request-- starts with the given path. For example,---- > dir "foo" handler---- Will fail if 'rqPathInfo' is not \"@\/foo@\" or \"@\/foo\/...@\", and will-- add @\"foo\/\"@ to the handler's local 'rqContextPath'.dir::MonadSnapm=>ByteString-- ^ path component to match->ma-- ^ handler to run->madir=pathWithfwherefdrpinfo=dr==xwhere(x,_)=S.break(=='/')pinfo{-# INLINE dir #-}-------------------------------------------------------------------------------- | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is-- exactly equal to the given string. If the path matches, locally sets-- 'rqContextPath' to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\",-- and runs the given handler.path::MonadSnapm=>ByteString-- ^ path to match against->ma-- ^ handler to run->mapath=pathWith(==){-# INLINE path #-}-------------------------------------------------------------------------------- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.ifTop::MonadSnapm=>ma->maifTop=path""{-# INLINE ifTop #-}-------------------------------------------------------------------------------- | Local Snap version of 'get'.sget::SnapSnapStatesget=Snap$liftM(Just.Right)get{-# INLINE sget #-}-------------------------------------------------------------------------------- | Local Snap monad version of 'modify'.smodify::(SnapState->SnapState)->Snap()smodifyf=Snap$modifyf>>return(Just$Right()){-# INLINE smodify #-}-------------------------------------------------------------------------------- | Grabs the 'Request' object out of the 'Snap' monad.getRequest::MonadSnapm=>mRequestgetRequest=liftSnap$liftM_snapRequestsget{-# INLINE getRequest #-}-------------------------------------------------------------------------------- | Grabs the 'Response' object out of the 'Snap' monad.getResponse::MonadSnapm=>mResponsegetResponse=liftSnap$liftM_snapResponsesget{-# INLINE getResponse #-}-------------------------------------------------------------------------------- | Puts a new 'Response' object into the 'Snap' monad.putResponse::MonadSnapm=>Response->m()putResponser=liftSnap$smodify$\ss->ss{_snapResponse=r}{-# INLINE putResponse #-}-------------------------------------------------------------------------------- | Puts a new 'Request' object into the 'Snap' monad.putRequest::MonadSnapm=>Request->m()putRequestr=liftSnap$smodify$\ss->ss{_snapRequest=r}{-# INLINE putRequest #-}-------------------------------------------------------------------------------- | Modifies the 'Request' object stored in a 'Snap' monad.modifyRequest::MonadSnapm=>(Request->Request)->m()modifyRequestf=liftSnap$smodify$\ss->ss{_snapRequest=f$_snapRequestss}{-# INLINE modifyRequest #-}-------------------------------------------------------------------------------- | Modifes the 'Response' object stored in a 'Snap' monad.modifyResponse::MonadSnapm=>(Response->Response)->m()modifyResponsef=liftSnap$smodify$\ss->ss{_snapResponse=f$_snapResponsess}{-# INLINE modifyResponse #-}-------------------------------------------------------------------------------- | Performs a redirect by setting the @Location@ header to the given target-- URL/path and the status code to 302 in the 'Response' object stored in a-- 'Snap' monad. Note that the target URL is not validated in any way.-- Consider using 'redirect\'' instead, which allows you to choose the correct-- status code.redirect::MonadSnapm=>ByteString->maredirecttarget=redirect'target302{-# INLINE redirect #-}-------------------------------------------------------------------------------- | Performs a redirect by setting the @Location@ header to the given target-- URL/path and the status code (should be one of 301, 302, 303 or 307) in the-- 'Response' object stored in a 'Snap' monad. Note that the target URL is not-- validated in any way.redirect'::MonadSnapm=>ByteString->Int->maredirect'targetstatus=dor<-getResponsefinishWith$setResponseCodestatus$setContentLength0$modifyResponseBody(const$enumBuildermempty)$setHeader"Location"targetr{-# INLINE redirect' #-}-------------------------------------------------------------------------------- | Log an error message in the 'Snap' monadlogError::MonadSnapm=>ByteString->m()logErrors=liftSnap$Snap$gets_snapLogError>>=(\l->liftIO$ls)>>return(Just$Right()){-# INLINE logError #-}-------------------------------------------------------------------------------- | Adds the output from the given enumerator to the 'Response'-- stored in the 'Snap' monad state.addToOutput::MonadSnapm=>(foralla.EnumeratorBuilderIOa)-- ^ output to add->m()addToOutputenum=modifyResponse$modifyResponseBody(>==>enum)-------------------------------------------------------------------------------- | Adds the given 'Builder' to the body of the 'Response' stored in the-- | 'Snap' monad state.writeBuilder::MonadSnapm=>Builder->m()writeBuilderb=addToOutput$enumBuilderb{-# INLINE writeBuilder #-}-------------------------------------------------------------------------------- | Adds the given strict 'ByteString' to the body of the 'Response' stored-- in the 'Snap' monad state.---- Warning: This function is intentionally non-strict. If any pure-- exceptions are raised by the expression creating the 'ByteString',-- the exception won't actually be raised within the Snap handler.writeBS::MonadSnapm=>ByteString->m()writeBSs=writeBuilder$fromByteStrings-------------------------------------------------------------------------------- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored-- in the 'Snap' monad state.---- Warning: This function is intentionally non-strict. If any pure-- exceptions are raised by the expression creating the 'ByteString',-- the exception won't actually be raised within the Snap handler.writeLBS::MonadSnapm=>L.ByteString->m()writeLBSs=writeBuilder$fromLazyByteStrings-------------------------------------------------------------------------------- | Adds the given strict 'T.Text' to the body of the 'Response' stored in-- the 'Snap' monad state.---- Warning: This function is intentionally non-strict. If any pure-- exceptions are raised by the expression creating the 'ByteString',-- the exception won't actually be raised within the Snap handler.writeText::MonadSnapm=>T.Text->m()writeTexts=writeBuilder$fromTexts-------------------------------------------------------------------------------- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the-- 'Snap' monad state.---- Warning: This function is intentionally non-strict. If any pure-- exceptions are raised by the expression creating the 'ByteString',-- the exception won't actually be raised within the Snap handler.writeLazyText::MonadSnapm=>LT.Text->m()writeLazyTexts=writeBuilder$fromLazyTexts-------------------------------------------------------------------------------- | Sets the output to be the contents of the specified file.---- Calling 'sendFile' will overwrite any output queued to be sent in the-- 'Response'. If the response body is not modified after the call to-- 'sendFile', Snap will use the efficient @sendfile()@ system call on-- platforms that support it.---- If the response body is modified (using 'modifyResponseBody'), the file-- will be read using @mmap()@.sendFile::(MonadSnapm)=>FilePath->m()sendFilef=modifyResponse$\r->r{rspBody=SendFilefNothing}-------------------------------------------------------------------------------- | Sets the output to be the contents of the specified file, within the-- given (start,end) range.---- Calling 'sendFilePartial' will overwrite any output queued to be sent in-- the 'Response'. If the response body is not modified after the call to-- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on-- platforms that support it.---- If the response body is modified (using 'modifyResponseBody'), the file-- will be read using @mmap()@.sendFilePartial::(MonadSnapm)=>FilePath->(Int64,Int64)->m()sendFilePartialfrng=modifyResponse$\r->r{rspBody=SendFilef(Justrng)}-------------------------------------------------------------------------------- | Runs a 'Snap' action with a locally-modified 'Request' state-- object. The 'Request' object in the Snap monad state after the call-- to localRequest will be unchanged.localRequest::MonadSnapm=>(Request->Request)->ma->malocalRequestfm=doreq<-getRequestrunActreq<|>(putRequestreq>>pass)whererunActreq=domodifyRequestfresult<-mputRequestreqreturnresult{-# INLINE localRequest #-}-------------------------------------------------------------------------------- | Fetches the 'Request' from state and hands it to the given action.withRequest::MonadSnapm=>(Request->ma)->mawithRequest=(getRequest>>=){-# INLINE withRequest #-}-------------------------------------------------------------------------------- | Fetches the 'Response' from state and hands it to the given action.withResponse::MonadSnapm=>(Response->ma)->mawithResponse=(getResponse>>=){-# INLINE withResponse #-}-------------------------------------------------------------------------------- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'-- field to the value in the X-Forwarded-For header. If the header is-- not present, this action has no effect.---- This action should be used only when working behind a reverse http-- proxy that sets the X-Forwarded-For header. This is the only way to-- ensure the value in the X-Forwarded-For header can be trusted.---- This is provided as a filter so actions that require the remote-- address can get it in a uniform manner. It has specifically limited-- functionality to ensure that its transformation can be trusted,-- when used correctly.ipHeaderFilter::MonadSnapm=>m()ipHeaderFilter=ipHeaderFilter'"x-forwarded-for"-------------------------------------------------------------------------------- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'-- field to the value from the header specified. If the header-- specified is not present, this action has no effect.---- This action should be used only when working behind a reverse http-- proxy that sets the header being looked at. This is the only way to-- ensure the value in the header can be trusted.---- This is provided as a filter so actions that require the remote-- address can get it in a uniform manner. It has specifically limited-- functionality to ensure that its transformation can be trusted,-- when used correctly.ipHeaderFilter'::MonadSnapm=>CIB.CIByteString->m()ipHeaderFilter'header=doheaderContents<-getHeaderheader<$>getRequestletwhitespace=" \t\r\n"ipChrs=".0123456789"trimfs=f(`elem`s)clean=trimS.takeWhileipChrs.trimS.dropWhilewhitespacesetIPip=modifyRequest$\rq->rq{rqRemoteAddr=cleanip}maybe(return())setIPheaderContents-------------------------------------------------------------------------------- | This function brackets a Snap action in resource acquisition and-- release. This is provided because MonadCatchIO's 'bracket' function-- doesn't work properly in the case of a short-circuit return from-- the action being bracketed.---- In order to prevent confusion regarding the effects of the-- aquisition and release actions on the Snap state, this function-- doesn't accept Snap actions for the acquire or release actions.---- This function will run the release action in all cases where the-- acquire action succeeded. This includes the following behaviors-- from the bracketed Snap action.---- 1. Normal completion---- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'---- 3. An exception being thrown.bracketSnap::IOa->(a->IOb)->(a->Snapc)->SnapcbracketSnapbeforeafterthing=block.Snap$doa<-liftIObeforeletafter'=liftIO$aftera(Snapthing')=thingar<-unblockthing'`onException`after'_<-after'returnr-------------------------------------------------------------------------------- | This exception is thrown if the handler you supply to 'runSnap' fails.dataNoHandlerException=NoHandlerExceptionderiving(Eq,Typeable)------------------------------------------------------------------------------instanceShowNoHandlerExceptionwhereshowNoHandlerException="No handler for request"------------------------------------------------------------------------------instanceExceptionNoHandlerException-------------------------------------------------------------------------------- | Runs a 'Snap' monad action in the 'Iteratee IO' monad.runSnap::Snapa->(ByteString->IO())->(Int->IO())->Request->IterateeByteStringIO(Request,Response)runSnap(Snapm)logerrtimeoutActionreq=do(r,ss')<-runStateTmsse<-maybe(return$Leftfourohfour)returnr-- is this a case of early termination?letresp=caseeofLeftx->xRight_->_snapResponsess'return(_snapRequestss',resp)wherefourohfour=setContentLength3$setResponseStatus404"Not Found"$modifyResponseBody(>==>enumBuilder(fromByteString"404"))$emptyResponsedresp=emptyResponse{rspHttpVersion=rqVersionreq}ss=SnapStatereqdresplogerrtimeoutAction{-# INLINE runSnap #-}------------------------------------------------------------------------------evalSnap::Snapa->(ByteString->IO())->(Int->IO())->Request->IterateeByteStringIOaevalSnap(Snapm)logerrtimeoutActionreq=do(r,_)<-runStateTmsse<-maybe(liftIO$throwIONoHandlerException)returnr-- is this a case of early termination?caseeofLeft_->liftIO$throwIO$ErrorCall"no value"Rightx->returnxwheredresp=emptyResponse{rspHttpVersion=rqVersionreq}ss=SnapStatereqdresplogerrtimeoutAction{-# INLINE evalSnap #-}-------------------------------------------------------------------------------- | See 'rqParam'. Looks up a value for the given named parameter in the-- 'Request'. If more than one value was entered for the given parameter name,-- 'getParam' gloms the values together with:---- @ 'S.intercalate' \" \"@--getParam::MonadSnapm=>ByteString-- ^ parameter name to look up->m(MaybeByteString)getParamk=dorq<-getRequestreturn$liftM(S.intercalate" ")$rqParamkrq-------------------------------------------------------------------------------- | See 'rqParams'. Convenience function to return 'Params' from the-- 'Request' inside of a 'MonadSnap' instance.getParams::MonadSnapm=>mParamsgetParams=getRequest>>=return.rqParams-------------------------------------------------------------------------------- | Gets the HTTP 'Cookie' with the specified name.getCookie::MonadSnapm=>ByteString->m(MaybeCookie)getCookiename=withRequest$return.listToMaybe.filter(\c->cookieNamec==name).rqCookies-------------------------------------------------------------------------------- | Causes the handler thread to be killed @n@ seconds from now.setTimeout::MonadSnapm=>Int->m()setTimeoutn=dot<-getTimeoutActionliftIO$tn-------------------------------------------------------------------------------- | Returns an 'IO' action which you can use to reset the handling thread's-- timeout value.getTimeoutAction::MonadSnapm=>m(Int->IO())getTimeoutAction=liftSnap$liftM_snapSetTimeoutsget