{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE EmptyDataDecls #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE RankNTypes #-}moduleSnap.Internal.Typeswhere------------------------------------------------------------------------------importControl.ApplicativeimportControl.Exception(throwIO,ErrorCall(..))importControl.Monad.CatchIOimportControl.Monad.State.StrictimportData.ByteString.Char8(ByteString)importqualifiedData.ByteString.Char8asSimportqualifiedData.ByteString.Lazy.Char8asLimportqualifiedData.CIByteStringasCIBimportData.IORefimportqualifiedData.IterateeasIterimportData.MaybeimportqualifiedData.TextasTimportqualifiedData.Text.EncodingasTimportqualifiedData.Text.LazyasLTimportqualifiedData.Text.Lazy.EncodingasLTimportData.Typeable------------------------------------------------------------------------------importSnap.Iterateehiding(Enumerator)importSnap.Internal.Http.Types-------------------------------------------------------------------------------- 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
-}------------------------------------------------------------------------------newtypeSnapa=Snap{unSnap::StateTSnapState(IterateeIO)(Maybe(EitherResponsea))}------------------------------------------------------------------------------dataSnapState=SnapState{_snapRequest::Request,_snapResponse::Response,_snapLogError::ByteString->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-------------------------------------------------------------------------------- | The Typeable instance is here so Snap can be dynamically executed with-- Hint.snapTyCon::TyConsnapTyCon=mkTyCon"Snap.Types.Snap"{-# NOINLINE snapTyCon #-}instanceTypeable1SnapwheretypeOf1_=mkTyConAppsnapTyCon[]------------------------------------------------------------------------------liftIter::IterateeIOa->SnapaliftIteri=Snap(lifti>>=return.Just.Right)-------------------------------------------------------------------------------- | Sends the request body through an iteratee (data consumer) and-- returns the result.runRequestBody::IterateeIOa->SnaparunRequestBodyiter=doreq<-getRequestsenum<-liftIO$readIORef$rqBodyreqlet(SomeEnumeratorenum)=senum-- make sure the iteratee consumes all of the outputletiter'=iter>>=(\a->Iter.skipToEof>>returna)-- run the iterateeresult<-liftIter$Iter.joinIM$enumiter'-- 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$return.Iter.joinI.Iter.take0)returnresult-------------------------------------------------------------------------------- | Returns the request body as a bytestring.getRequestBody::SnapL.ByteStringgetRequestBody=liftMfromWrap$runRequestBodystream2stream{-# INLINE getRequestBody #-}-------------------------------------------------------------------------------- | Detaches the request body's 'Enumerator' from the 'Request' and-- returns it. You would want to use this if you needed to send the-- HTTP request body (transformed or otherwise) through to the output-- in O(1) space. (Examples: transcoding, \"echo\", etc)---- Normally Snap is careful to ensure that the request body is fully-- consumed after your web handler runs; this function is marked-- \"unsafe\" because it breaks this guarantee and leaves the-- responsibility up to you. If you don't fully consume the-- 'Enumerator' you get here, the next HTTP request in the pipeline-- (if any) will misparse. Be careful with exception handlers.unsafeDetachRequestBody::Snap(Enumeratora)unsafeDetachRequestBody=doreq<-getRequestletioref=rqBodyreqsenum<-liftIO$readIORefioreflet(SomeEnumeratorenum)=senumliftIO$writeIORefioref(SomeEnumerator$return.Iter.joinI.Iter.take0)returnenum-------------------------------------------------------------------------------- | Short-circuits a 'Snap' monad action early, storing the given-- 'Response' value in its state.finishWith::Response->Snap()finishWith=Snap.return.Just.Left{-# INLINE finishWith #-}-------------------------------------------------------------------------------- | 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::Snapapass=empty-------------------------------------------------------------------------------- | Runs a 'Snap' monad action only if the request's HTTP method matches-- the given method.method::Method->Snapa->Snapamethodmaction=doreq<-getRequestunless(rqMethodreq==m)passaction{-# INLINE method #-}-------------------------------------------------------------------------------- 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::(ByteString->ByteString->Bool)->ByteString->Snapa->SnapapathWithcpaction=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::ByteString-- ^ path component to match->Snapa-- ^ handler to run->Snapadir=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::ByteString-- ^ path to match against->Snapa-- ^ handler to run->Snapapath=pathWith(==){-# INLINE path #-}-------------------------------------------------------------------------------- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.ifTop::Snapa->SnapaifTop=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::SnapRequestgetRequest=liftM_snapRequestsget{-# INLINE getRequest #-}-------------------------------------------------------------------------------- | Grabs the 'Response' object out of the 'Snap' monad.getResponse::SnapResponsegetResponse=liftM_snapResponsesget{-# INLINE getResponse #-}-------------------------------------------------------------------------------- | Puts a new 'Response' object into the 'Snap' monad.putResponse::Response->Snap()putResponser=smodify$\ss->ss{_snapResponse=r}{-# INLINE putResponse #-}-------------------------------------------------------------------------------- | Puts a new 'Request' object into the 'Snap' monad.putRequest::Request->Snap()putRequestr=smodify$\ss->ss{_snapRequest=r}{-# INLINE putRequest #-}-------------------------------------------------------------------------------- | Modifies the 'Request' object stored in a 'Snap' monad.modifyRequest::(Request->Request)->Snap()modifyRequestf=smodify$\ss->ss{_snapRequest=f$_snapRequestss}{-# INLINE modifyRequest #-}-------------------------------------------------------------------------------- | Modifes the 'Response' object stored in a 'Snap' monad.modifyResponse::(Response->Response)->Snap()modifyResponsef=smodify$\ss->ss{_snapResponse=f$_snapResponsess}{-# INLINE modifyResponse #-}-------------------------------------------------------------------------------- | Log an error message in the 'Snap' monadlogError::ByteString->Snap()logErrors=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::(foralla.Enumeratora)-- ^ output to add->Snap()addToOutputenum=modifyResponse$modifyResponseBody(>.enum)-------------------------------------------------------------------------------- | Adds the given strict 'ByteString' to the body of the 'Response' stored in-- the 'Snap' monad state.writeBS::ByteString->Snap()writeBSs=addToOutput$enumBSs-------------------------------------------------------------------------------- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored in-- the 'Snap' monad state.writeLBS::L.ByteString->Snap()writeLBSs=addToOutput$enumLBSs-------------------------------------------------------------------------------- | Adds the given strict 'T.Text' to the body of the 'Response' stored in the-- 'Snap' monad state.writeText::T.Text->Snap()writeTexts=writeBS$T.encodeUtf8s-------------------------------------------------------------------------------- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the-- 'Snap' monad state.writeLazyText::LT.Text->Snap()writeLazyTexts=writeLBS$LT.encodeUtf8s-------------------------------------------------------------------------------- | 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::FilePath->Snap()sendFilef=modifyResponse$\r->r{rspBody=SendFilef}-------------------------------------------------------------------------------- | 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::(Request->Request)->Snapa->SnapalocalRequestfm=doreq<-getRequestrunActreq<|>(putRequestreq>>pass)whererunActreq=domodifyRequestfresult<-mputRequestreqreturnresult{-# INLINE localRequest #-}-------------------------------------------------------------------------------- | Fetches the 'Request' from state and hands it to the given action.withRequest::(Request->Snapa)->SnapawithRequest=(getRequest>>=){-# INLINE withRequest #-}-------------------------------------------------------------------------------- | Fetches the 'Response' from state and hands it to the given action.withResponse::(Response->Snapa)->SnapawithResponse=(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::Snap()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'::CIB.CIByteString->Snap()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 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())->Request->IterateeIO(Request,Response)runSnap(Snapm)logerrreq=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(>.enumBS"404")$emptyResponsedresp=emptyResponse{rspHttpVersion=rqVersionreq}ss=SnapStatereqdresplogerr{-# INLINE runSnap #-}------------------------------------------------------------------------------evalSnap::Snapa->(ByteString->IO())->Request->IterateeIOaevalSnap(Snapm)logerrreq=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=SnapStatereqdresplogerr{-# 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::ByteString-- ^ parameter name to look up->Snap(MaybeByteString)getParamk=dorq<-getRequestreturn$liftM(S.intercalate" ")$rqParamkrq