{-# OPTIONS_HADDOCK prune #-}-- |This is the Resource Monad; monadic actions to define the behavior-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is-- also a state machine.-- -- Request Processing Flow:---- 1. A client issues an HTTP request.---- 2. If the URI of it matches to any resource, the corresponding-- 'Resource' Monad starts running on a newly spawned thread.---- 3. The 'Resource' Monad looks at the request header, find (or not-- find) an entity, receive the request body (if any), decide the-- response header, and decide the response body. This process-- will be discussed later.---- 4. The 'Resource' Monad and its thread stops running. The client-- may or may not be sending us the next request at this point.---- 'Resource' Monad takes the following states. The initial state is-- /Examining Request/ and the final state is /Done/.---- [/Examining Request/] In this state, a 'Resource' looks at the-- request header and thinks about an entity for it. If there is a-- suitable entity, the 'Resource' tells the system an entity tag-- and its last modification time ('foundEntity'). If it found no-- entity, it tells the system so ('foundNoEntity'). In case it is-- impossible to decide the existence of entity, which is a typical-- case for POST requests, 'Resource' does nothing in this state.---- [/Getting Body/] A 'Resource' asks the system to receive a-- request body from client. Before actually reading from the-- socket, the system sends \"100 Continue\" to the client if need-- be. When a 'Resource' transits to the next state without-- receiving all or part of request body, the system still reads it-- and just throws it away.---- [/Deciding Header/] A 'Resource' makes a decision of status code-- and response header. When it transits to the next state, the-- system checks the validness of response header and then write-- them to the socket.---- [/Deciding Body/] In this state, a 'Resource' asks the system to-- write some response body to the socket. When it transits to the-- next state without writing any response body, the system-- completes it depending on the status code.---- [/Done/] Everything is over. A 'Resource' can do nothing for the-- HTTP interaction anymore.---- Note that the state transition is one-way: for instance, it is an-- error to try to read a request body after writing some-- response. This limitation is for efficiency. We don't want to read-- the entire request before starting 'Resource', nor we don't want to-- postpone writing the entire response till the end of 'Resource'-- computation.moduleNetwork.HTTP.Lucu.Resource(-- * TypesResource,FormData(..),runRes-- private-- * Actions-- ** Getting request header-- |These actions can be computed regardless of the current state,-- and they don't change the state.,getConfig,getRemoteAddr,getRemoteAddr',getRemoteHost,getRemoteCertificate,getRequest,getMethod,getRequestURI,getRequestVersion,getResourcePath,getPathInfo,getQueryForm,getHeader,getAccept,getAcceptEncoding,isEncodingAcceptable,getContentType,getAuthorization-- ** Finding an entity-- |These actions can be computed only in the /Examining Request/-- state. After the computation, the 'Resource' transits to-- /Getting Body/ state.,foundEntity,foundETag,foundTimeStamp,foundNoEntity-- ** Getting a request body-- |Computation of these actions changes the state to /Getting-- Body/.,input,inputChunk,inputLBS,inputChunkLBS,inputForm,defaultLimit-- ** Setting response headers-- |Computation of these actions changes the state to /Deciding-- Header/.,setStatus,setHeader,redirect,setContentType,setLocation,setContentEncoding,setWWWAuthenticate-- ** Writing a response body-- |Computation of these actions changes the state to /Deciding-- Body/.,output,outputChunk,outputLBS,outputChunkLBS,driftTo)whereimportControl.Concurrent.STMimportControl.Monad.ReaderimportqualifiedData.ByteStringasStrict(ByteString)importqualifiedData.ByteString.LazyasLazy(ByteString)importqualifiedData.ByteString.Char8asC8hiding(ByteString)importqualifiedData.ByteString.Lazy.Char8asL8hiding(ByteString)importData.CharimportData.ListimportData.MaybeimportData.TimeimportqualifiedData.Time.HTTPasHTTPimportNetwork.HTTP.Lucu.AbortionimportNetwork.HTTP.Lucu.AuthorizationimportNetwork.HTTP.Lucu.ConfigimportNetwork.HTTP.Lucu.ContentCodingimportNetwork.HTTP.Lucu.DefaultPageimportNetwork.HTTP.Lucu.ETagimportqualifiedNetwork.HTTP.Lucu.HeadersasHimportNetwork.HTTP.Lucu.HttpVersionimportNetwork.HTTP.Lucu.InteractionimportNetwork.HTTP.Lucu.MultipartFormimportNetwork.HTTP.Lucu.ParserimportNetwork.HTTP.Lucu.PostprocessimportNetwork.HTTP.Lucu.RequestimportNetwork.HTTP.Lucu.ResponseimportNetwork.HTTP.Lucu.MIMETypeimportNetwork.HTTP.Lucu.UtilsimportNetwork.Sockethiding(accept)importNetwork.URIhiding(path)importOpenSSL.X509-- |The 'Resource' monad. This monad implements-- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'-- actions.newtypeResourcea=Resource{unRes::ReaderTInteractionIOa}instanceFunctorResourcewherefmapfc=Resource(fmapf(unResc))instanceMonadResourcewherec>>=f=Resource(unResc>>=unRes.f)return=Resource.returnfail=Resource.failinstanceMonadIOResourcewhereliftIO=Resource.liftIOrunRes::Resourcea->Interaction->IOarunResritr=runReaderT(unResr)itrgetInteraction::ResourceInteractiongetInteraction=Resourceask-- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for-- the httpd.getConfig::ResourceConfiggetConfig=doitr<-getInteractionreturn$!itrConfigitr-- |Get the 'Network.Socket.SockAddr' of the remote host. If you want-- a string representation instead of 'Network.Socket.SockAddr', use-- 'getRemoteAddr''.getRemoteAddr::ResourceSockAddrgetRemoteAddr=doitr<-getInteractionreturn$!itrRemoteAddritr-- |Get the string representation of the address of remote host. If-- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',-- use 'getRemoteAddr'.getRemoteAddr'::ResourceStringgetRemoteAddr'=doaddr<-getRemoteAddr(Juststr,_)<-liftIO$!getNameInfo[NI_NUMERICHOST]TrueFalseaddrreturnstr-- |Resolve an address to the remote host.getRemoteHost::ResourceStringgetRemoteHost=doaddr<-getRemoteAddr(Juststr,_)<-liftIO$!getNameInfo[]TrueFalseaddrreturnstr-- | Return the X.509 certificate of the client, or 'Nothing' if:---- * This request didn't came through an SSL stream.---- * The client didn't send us its certificate.---- * The 'OpenSSL.Session.VerificationMode' of-- 'OpenSSL.Session.SSLContext' in-- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to-- 'OpenSSL.Session.VerifyPeer'.getRemoteCertificate::Resource(MaybeX509)getRemoteCertificate=doitr<-getInteractionreturn$!itrRemoteCertitr-- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents-- the request header. In general you don't have to use this action.getRequest::ResourceRequestgetRequest=doitr<-getInteractionreq<-liftIO$!atomically$!readItritritrRequestfromJustreturnreq-- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.getMethod::ResourceMethodgetMethod=doreq<-getRequestreturn$!reqMethodreq-- |Get the URI of the request.getRequestURI::ResourceURIgetRequestURI=doreq<-getRequestreturn$!reqURIreq-- |Get the HTTP version of the request.getRequestVersion::ResourceHttpVersiongetRequestVersion=doreq<-getRequestreturn$!reqVersionreq-- |Get the path of this 'Resource' (to be exact,-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this-- action is the exact path in the tree even if the-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.---- Example:---- > main = let tree = mkResTree [ (["foo"], resFoo) ]-- > in runHttpd defaultConfig tree-- >-- > resFoo = ResourceDef {-- > resIsGreedy = True-- > , resGet = Just $ do requestURI <- getRequestURI-- > resourcePath <- getResourcePath-- > pathInfo <- getPathInfo-- > -- uriPath requestURI == "/foo/bar/baz"-- > -- resourcePath == ["foo"]-- > -- pathInfo == ["bar", "baz"]-- > ...-- > , ...-- > }getResourcePath::Resource[String]getResourcePath=doitr<-getInteractionreturn$!fromJust$!itrResourcePathitr-- |This is an analogy of CGI PATH_INFO. The result is-- URI-unescaped. It is always @[]@ if the-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See-- 'getResourcePath'.getPathInfo::Resource[String]getPathInfo=dorsrcPath<-getResourcePathuri<-getRequestURIletreqPathStr=uriPathurireqPath=[unEscapeStringx|x<-splitBy(=='/')reqPathStr,x/=""]-- rsrcPath と reqPath の共通する先頭部分を reqPath か-- ら全部取り除くと、それは PATH_INFO のやうなものにな-- る。rsrcPath は全部一致してゐるに決まってゐる（でな-- ければこの Resource が撰ばれた筈が無い）ので、-- rsrcPath の長さの分だけ削除すれば良い。return$!drop(lengthrsrcPath)reqPath-- |Assume the query part of request URI as-- application\/x-www-form-urlencoded, and parse it to pairs of-- @(name, formData)@. This action doesn't parse the request body. See-- 'inputForm'.getQueryForm::Resource[(String,FormData)]getQueryForm=liftMparse'getRequestURIwhereparse'=maptoPairWithFormData.parseWWWFormURLEncoded.snd.splitAt1.uriQuerytoPairWithFormData::(String,String)->(String,FormData)toPairWithFormData(name,value)=letfd=FormData{fdFileName=Nothing,fdContent=L8.packvalue}in(name,fd)-- |Get a value of given request header. Comparison of header name is-- case-insensitive. Note that this action is not intended to be used-- so frequently: there should be actions like 'getContentType' for-- every common headers.getHeader::Strict.ByteString->Resource(MaybeStrict.ByteString)getHeadername=name`seq`doreq<-getRequestreturn$!H.getHeadernamereq-- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on-- header \"Accept\".getAccept::Resource[MIMEType]getAccept=doacceptM<-getHeader(C8.pack"Accept")caseacceptMofNothing->return[]Justaccept->caseparsemimeTypeListP(L8.fromChunks[accept])of(#Successxs,_#)->returnxs(#_,_#)->abortBadRequest[](Just$"Unparsable Accept: "++C8.unpackaccept)-- |Get a list of @(contentCoding, qvalue)@ enumerated on header-- \"Accept-Encoding\". The list is sorted in descending order by-- qvalue.getAcceptEncoding::Resource[(String,MaybeDouble)]getAcceptEncoding=doaccEncM<-getHeader(C8.pack"Accept-Encoding")caseaccEncMofNothing-- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い-- ので安全の爲 identity が指定された事にする。HTTP/1.1-- の場合は何でも受け入れて良い事になってゐるので "*" が-- 指定された事にする。->dover<-getRequestVersioncaseverofHttpVersion10->return[("identity",Nothing)]HttpVersion11->return[("*",Nothing)]_->undefinedJustvalue->ifC8.nullvaluethen-- identity のみが許される。return[("identity",Nothing)]elsecaseparseacceptEncodingListP(L8.fromChunks[value])of(#Successx,_#)->return$reverse$sortByorderAcceptEncodingsx(#_,_#)->abortBadRequest[](Just$"Unparsable Accept-Encoding: "++C8.unpackvalue)-- |Check whether a given content-coding is acceptable.isEncodingAcceptable::String->ResourceBoolisEncodingAcceptablecoding=doaccList<-getAcceptEncodingreturn(flipanyaccList$\(c,q)->(c=="*"||C8.packc`H.noCaseEq`C8.packcoding)&&q/=Just0)-- |Get the header \"Content-Type\" as-- 'Network.HTTP.Lucu.MIMEType.MIMEType'.getContentType::Resource(MaybeMIMEType)getContentType=docTypeM<-getHeader(C8.pack"Content-Type")casecTypeMofNothing->returnNothingJustcType->caseparsemimeTypeP(L8.fromChunks[cType])of(#Successt,_#)->return$Justt(#_,_#)->abortBadRequest[](Just$"Unparsable Content-Type: "++C8.unpackcType)-- |Get the header \"Authorization\" as-- 'Network.HTTP.Lucu.Authorization.AuthCredential'.getAuthorization::Resource(MaybeAuthCredential)getAuthorization=doauthM<-getHeader(C8.pack"Authorization")caseauthMofNothing->returnNothingJustauth->caseparseauthCredentialP(L8.fromChunks[auth])of(#Successa,_#)->return$Justa(#_,_#)->returnNothing{- ExaminingRequest 時に使用するアクション群 -}-- |Tell the system that the 'Resource' found an entity for the-- request URI. If this is a GET or HEAD request, a found entity means-- a datum to be replied. If this is a PUT or DELETE request, it means-- a datum which was stored for the URI until now. It is an error to-- compute 'foundEntity' if this is a POST request.---- Computation of 'foundEntity' performs \"If-Match\" test or-- \"If-None-Match\" test if possible. When those tests fail, the-- computation of 'Resource' immediately aborts with status \"412-- Precondition Failed\" or \"304 Not Modified\" depending on the-- situation.---- If this is a GET or HEAD request, 'foundEntity' automatically puts-- \"ETag\" and \"Last-Modified\" headers into the response.foundEntity::ETag->UTCTime->Resource()foundEntitytagtimeStamp=tag`seq`timeStamp`seq`dodriftToExaminingRequestmethod<-getMethodwhen(method==GET||method==HEAD)$setHeader'(C8.pack"Last-Modified")(C8.pack$HTTP.formattimeStamp)when(method==POST)$abortInternalServerError[](Just"Illegal computation of foundEntity for a POST request.")foundETagtagdriftToGettingBody-- |Tell the system that the 'Resource' found an entity for the-- request URI. The only difference from 'foundEntity' is that-- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into-- the response.---- This action is not preferred. You should use 'foundEntity' whenever-- possible.foundETag::ETag->Resource()foundETagtag=tag`seq`dodriftToExaminingRequestmethod<-getMethodwhen(method==GET||method==HEAD)$setHeader'(C8.pack"ETag")(C8.pack$showtag)when(method==POST)$abortInternalServerError[](Just"Illegal computation of foundETag for POST request.")-- If-Match があればそれを見る。ifMatch<-getHeader(C8.pack"If-Match")caseifMatchofNothing->return()Justvalue->ifvalue==C8.pack"*"thenreturn()elsecaseparseeTagListP(L8.fromChunks[value])of(#Successtags,_#)-- tags の中に一致するものが無ければ-- PreconditionFailed で終了。->when(not$any(==tag)tags)$abortPreconditionFailed[]$!Just("The entity tag doesn't match: "++C8.unpackvalue)(#_,_#)->abortBadRequest[]$!Just("Unparsable If-Match: "++C8.unpackvalue)letstatusForNoneMatch=ifmethod==GET||method==HEADthenNotModifiedelsePreconditionFailed-- If-None-Match があればそれを見る。ifNoneMatch<-getHeader(C8.pack"If-None-Match")caseifNoneMatchofNothing->return()Justvalue->ifvalue==C8.pack"*"thenabortstatusForNoneMatch[]$!Just("The entity tag matches: *")elsecaseparseeTagListP(L8.fromChunks[value])of(#Successtags,_#)->when(any(==tag)tags)$abortstatusForNoneMatch[]$!Just("The entity tag matches: "++C8.unpackvalue)(#_,_#)->abortBadRequest[]$!Just("Unparsable If-None-Match: "++C8.unpackvalue)driftToGettingBody-- |Tell the system that the 'Resource' found an entity for the-- request URI. The only difference from 'foundEntity' is that-- 'foundTimeStamp' performs \"If-Modified-Since\" test or-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or-- \"If-None-Match\" test. Be aware that any tests based on last-- modification time are unsafe because it is possible to mess up such-- tests by modifying the entity twice in a second.---- This action is not preferred. You should use 'foundEntity' whenever-- possible.foundTimeStamp::UTCTime->Resource()foundTimeStamptimeStamp=timeStamp`seq`dodriftToExaminingRequestmethod<-getMethodwhen(method==GET||method==HEAD)$setHeader'(C8.pack"Last-Modified")(C8.pack$HTTP.formattimeStamp)when(method==POST)$abortInternalServerError[](Just"Illegal computation of foundTimeStamp for POST request.")letstatusForIfModSince=ifmethod==GET||method==HEADthenNotModifiedelsePreconditionFailed-- If-Modified-Since があればそれを見る。ifModSince<-getHeader(C8.pack"If-Modified-Since")caseifModSinceofJuststr->caseHTTP.parse(C8.unpackstr)ofJustlastTime->when(timeStamp<=lastTime)$abortstatusForIfModSince[]$!Just("The entity has not been modified since "++C8.unpackstr)Nothing->return()-- 不正な時刻は無視Nothing->return()-- If-Unmodified-Since があればそれを見る。ifUnmodSince<-getHeader(C8.pack"If-Unmodified-Since")caseifUnmodSinceofJuststr->caseHTTP.parse(C8.unpackstr)ofJustlastTime->when(timeStamp>lastTime)$abortPreconditionFailed[]$!Just("The entity has not been modified since "++C8.unpackstr)Nothing->return()-- 不正な時刻は無視Nothing->return()driftToGettingBody-- | Computation of @'foundNoEntity' mStr@ tells the system that the-- 'Resource' found no entity for the request URI. @mStr@ is an-- optional error message to be replied to the client.---- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"-- test and aborts with status \"412 Precondition Failed\" when it-- failed. If this is a GET, HEAD, POST or DELETE request,-- 'foundNoEntity' always aborts with status \"404 Not Found\".foundNoEntity::MaybeString->Resource()foundNoEntitymsgM=msgM`seq`dodriftToExaminingRequestmethod<-getMethodwhen(method/=PUT)$abortNotFound[]msgM-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな-- If-Match: 條件も滿たさない。ifMatch<-getHeader(C8.pack"If-Match")when(ifMatch/=Nothing)$abortPreconditionFailed[]msgMdriftToGettingBody{- GettingBody 時に使用するアクション群 -}-- | Computation of @'input' limit@ attempts to read the request body-- up to @limit@ bytes, and then make the 'Resource' transit to-- /Deciding Header/ state. When the actual size of body is larger-- than @limit@ bytes, computation of 'Resource' immediately aborts-- with status \"413 Request Entity Too Large\". When the request has-- no body, 'input' returns an empty string.---- @limit@ may be less than or equal to zero. In this case, the-- default limitation value-- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See-- 'defaultLimit'.---- Note that 'inputLBS' is more efficient than 'input' so you should-- use it whenever possible.input::Int->ResourceStringinputlimit=limit`seq`inputLBSlimit>>=return.L8.unpack-- | This is mostly the same as 'input' but is more-- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'-- but it's not really lazy: reading from the socket just happens at-- the computation of 'inputLBS', not at the evaluation of the-- 'Data.ByteString.Lazy.ByteString'. The same goes for-- 'inputChunkLBS'.inputLBS::Int->ResourceLazy.ByteStringinputLBSlimit=limit`seq`dodriftToGettingBodyitr<-getInteractionhasBody<-liftIO$!atomically$!readItritritrRequestHasBodyidchunk<-ifhasBodythenaskForInputitrelsedodriftToDecidingHeaderreturnL8.emptyreturnchunkwhereaskForInput::Interaction->ResourceLazy.ByteStringaskForInputitr=itr`seq`doletconfLimit=cnfMaxEntityLength$itrConfigitractualLimit=iflimit<=0thenconfLimitelselimitwhen(actualLimit<=0)$fail("inputLBS: limit must be positive: "++showactualLimit)-- Reader にリクエストliftIO$!atomically$!dochunkLen<-readItritritrReqChunkLengthidwriteItritritrWillReceiveBodyTrueiffmap(>actualLimit)chunkLen==JustTruethen-- 受信前から多過ぎる事が分かってゐるtooLargeactualLimitelsewriteItritritrReqBodyWanted$JustactualLimit-- 應答を待つ。トランザクションを分けなければ當然デッドロック。chunk<-liftIO$!atomically$!dochunk<-readItritritrReceivedBodyidchunkIsOver<-readItritritrReqChunkIsOveridifL8.lengthchunk<fromIntegralactualLimitthen-- 要求された量に滿たなくて、まだ殘り-- があるなら再試行。unlesschunkIsOver$retryelse-- 制限値一杯まで讀むやうに指示したの-- にまだ殘ってゐるなら、それは多過ぎ-- る。unlesschunkIsOver$tooLargeactualLimit-- 成功。itr 内にチャンクを置いたままにす-- るとメモリの無駄になるので除去。writeItritritrReceivedBodyL8.emptyreturnchunkdriftToDecidingHeaderreturnchunktooLarge::Int->STM()tooLargelim=lim`seq`abortSTMRequestEntityTooLarge[]$!Just("Request body must be smaller than "++showlim++" bytes.")-- | Computation of @'inputChunk' limit@ attempts to read a part of-- request body up to @limit@ bytes. You can read any large request by-- repeating computation of this action. When you've read all the-- request body, 'inputChunk' returns an empty string and then make-- the 'Resource' transit to /Deciding Header/ state.---- @limit@ may be less than or equal to zero. In this case, the-- default limitation value-- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See-- 'defaultLimit'.---- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you-- should use it whenever possible.inputChunk::Int->ResourceStringinputChunklimit=limit`seq`inputChunkLBSlimit>>=return.L8.unpack-- | This is mostly the same as 'inputChunk' but is more-- efficient. See 'inputLBS'.inputChunkLBS::Int->ResourceLazy.ByteStringinputChunkLBSlimit=limit`seq`dodriftToGettingBodyitr<-getInteractionhasBody<-liftIO$atomically$readItritritrRequestHasBodyidchunk<-ifhasBodythenaskForInputitrelsedodriftToDecidingHeaderreturnL8.emptyreturnchunkwhereaskForInput::Interaction->ResourceLazy.ByteStringaskForInputitr=itr`seq`doletconfLimit=cnfMaxEntityLength$!itrConfigitractualLimit=iflimit<0thenconfLimitelselimitwhen(actualLimit<=0)$fail("inputChunkLBS: limit must be positive: "++showactualLimit)-- Reader にリクエストliftIO$!atomically$!dowriteItritritrReqBodyWanted$!JustactualLimitwriteItritritrWillReceiveBodyTrue-- 應答を待つ。トランザクションを分けなければ當然デッドロック。chunk<-liftIO$!atomically$dochunk<-readItritritrReceivedBodyid-- 要求された量に滿たなくて、まだ殘りがあ-- るなら再試行。when(L8.lengthchunk<fromIntegralactualLimit)$dochunkIsOver<-readItritritrReqChunkIsOveridunlesschunkIsOver$retry-- 成功writeItritritrReceivedBodyL8.emptyreturnchunkwhen(L8.nullchunk)$driftToDecidingHeaderreturnchunk-- | Computation of @'inputForm' limit@ attempts to read the request-- body with 'input' and parse it as-- application\/x-www-form-urlencoded or multipart\/form-data. If the-- request header \"Content-Type\" is neither of them, 'inputForm'-- makes 'Resource' abort with status \"415 Unsupported Media-- Type\". If the request has no \"Content-Type\", it aborts with-- \"400 Bad Request\".inputForm::Int->Resource[(String,FormData)]inputFormlimit=limit`seq`docTypeM<-getContentTypecasecTypeMofNothing->abortBadRequest[](Just"Missing Content-Type")Just(MIMEType"application""x-www-form-urlencoded"_)->readWWWFormURLEncodedJust(MIMEType"multipart""form-data"params)->readMultipartFormDataparamsJustcType->abortUnsupportedMediaType[](Just$!"Unsupported media type: "++showcType)wherereadWWWFormURLEncoded=liftM(maptoPairWithFormData.parseWWWFormURLEncoded)(inputlimit)readMultipartFormDataparams=docasefind((=="boundary").maptoLower.fst)paramsofNothing->abortBadRequest[](Just"Missing boundary of multipart/form-data")Just(_,boundary)->dosrc<-inputLBSlimitcaseparse(multipartFormPboundary)srcof(#SuccessformList,_#)->returnformList(#_,_#)->abortBadRequest[](Just"Unparsable multipart/form-data")-- | This is just a constant @-1@. It's better to say @'input'-- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly-- the same.defaultLimit::IntdefaultLimit=(-1){- DecidingHeader 時に使用するアクション群 -}-- | Set the response status code. If you omit to compute this action,-- the status code will be defaulted to \"200 OK\".setStatus::StatusCode->Resource()setStatuscode=code`seq`dodriftToDecidingHeaderitr<-getInteractionliftIO$!atomically$!updateItritritrResponse$!\res->res{resStatus=code}-- | Set a value of given resource header. Comparison of header name-- is case-insensitive. Note that this action is not intended to be-- used so frequently: there should be actions like 'setContentType'-- for every common headers.---- Some important headers (especially \"Content-Length\" and-- \"Transfer-Encoding\") may be silently dropped or overwritten by-- the system not to corrupt the interaction with client at the-- viewpoint of HTTP protocol layer. For instance, if we are keeping-- the connection alive, without this process it causes a catastrophe-- to send a header \"Content-Length: 10\" and actually send a body of-- 20 bytes long. In this case the client shall only accept the first-- 10 bytes of response body and thinks that the residual 10 bytes is-- a part of header of the next response.setHeader::Strict.ByteString->Strict.ByteString->Resource()setHeadernamevalue=name`seq`value`seq`driftToDecidingHeader>>setHeader'namevaluesetHeader'::Strict.ByteString->Strict.ByteString->Resource()setHeader'namevalue=name`seq`value`seq`doitr<-getInteractionliftIO$atomically$updateItritritrResponse$H.setHeadernamevalue-- | Computation of @'redirect' code uri@ sets the response status to-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy-- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.redirect::StatusCode->URI->Resource()redirectcodeuri=code`seq`uri`seq`dowhen(code==NotModified||not(isRedirectioncode))$abortInternalServerError[]$!Just("Attempted to redirect with status "++showcode)setStatuscodesetLocationuri{-# INLINE redirect #-}-- | Computation of @'setContentType' mType@ sets the response header-- \"Content-Type\" to @mType@.setContentType::MIMEType->Resource()setContentTypemType=setHeader(C8.pack"Content-Type")(C8.pack$showmType)-- | Computation of @'setLocation' uri@ sets the response header-- \"Location\" to @uri@.setLocation::URI->Resource()setLocationuri=setHeader(C8.pack"Location")(C8.pack$uriToStringiduri$"")-- |Computation of @'setContentEncoding' codings@ sets the response-- header \"Content-Encoding\" to @codings@.setContentEncoding::[String]->Resource()setContentEncodingcodings=dover<-getRequestVersionlettr=caseverofHttpVersion10->unnormalizeCodingHttpVersion11->id_->undefinedsetHeader(C8.pack"Content-Encoding")(C8.pack$joinWith", "$maptrcodings)-- |Computation of @'setWWWAuthenticate' challenge@ sets the response-- header \"WWW-Authenticate\" to @challenge@.setWWWAuthenticate::AuthChallenge->Resource()setWWWAuthenticatechallenge=setHeader(C8.pack"WWW-Authenticate")(C8.pack$showchallenge){- DecidingBody 時に使用するアクション群 -}-- | Computation of @'output' str@ writes @str@ as a response body,-- and then make the 'Resource' transit to /Done/ state. It is safe to-- apply 'output' to an infinite string, such as a lazy stream of-- \/dev\/random.---- Note that 'outputLBS' is more efficient than 'output' so you should-- use it whenever possible.output::String->Resource()outputstr=outputLBS$!L8.packstr{-# INLINE output #-}-- | This is mostly the same as 'output' but is more efficient.outputLBS::Lazy.ByteString->Resource()outputLBSstr=dooutputChunkLBSstrdriftToDone{-# INLINE outputLBS #-}-- | Computation of @'outputChunk' str@ writes @str@ as a part of-- response body. You can compute this action multiple times to write-- a body little at a time. It is safe to apply 'outputChunk' to an-- infinite string.---- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so-- you should use it whenever possible.outputChunk::String->Resource()outputChunkstr=outputChunkLBS$!L8.packstr{-# INLINE outputChunk #-}-- | This is mostly the same as 'outputChunk' but is more efficient.outputChunkLBS::Lazy.ByteString->Resource()outputChunkLBSwholeChunk=wholeChunk`seq`dodriftToDecidingBodyitr<-getInteractionletlimit=cnfMaxOutputChunkLength$itrConfigitrwhen(limit<=0)$fail("cnfMaxOutputChunkLength must be positive: "++showlimit)discardBody<-liftIO$atomically$readItritritrWillDiscardBodyidunless(discardBody)$sendChunkswholeChunklimitunless(L8.nullwholeChunk)$liftIO$atomically$writeItritritrBodyIsNullFalsewhere-- チャンクの大きさは Config で制限されてゐる。もし例へば-- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま-- ResponseWriter に渡したりすると大變な事が起こる。何故なら-- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書-- く爲にチャンクの大きさを測る。sendChunks::Lazy.ByteString->Int->Resource()sendChunksstrlimit|L8.nullstr=return()|otherwise=dolet(chunk,remaining)=L8.splitAt(fromIntegrallimit)stritr<-getInteractionliftIO$atomically$dobuf<-readItritritrBodyToSendidifL8.nullbufthen-- バッファが消化されたwriteItritritrBodyToSendchunkelse-- 消化されるのを待つretry-- 殘りのチャンクについて繰り返すsendChunksremaininglimit{-
[GettingBody からそれ以降の状態に遷移する時]
body を讀み終へてゐなければ、殘りの body を讀み捨てる。
[DecidingHeader からそれ以降の状態に遷移する時]
postprocess する。
[Done に遷移する時]
bodyIsNull が False ならば何もしない。True だった場合は出力補完す
る。
-}driftTo::InteractionState->Resource()driftTonewState=newState`seq`doitr<-getInteractionliftIO$atomically$dooldState<-readItritritrStateidifnewState<oldStatethenthrowStateErroroldStatenewStateelsedoleta=[oldState..newState]b=tailac=zipabmapM_(uncurry$driftitr)cwriteItritritrStatenewStatewherethrowStateError::Monadm=>InteractionState->InteractionState->mathrowStateErrorDoneDecidingBody=fail"It makes no sense to output something after finishing to output."throwStateErroroldnew=fail("state error: "++showold++" ==> "++shownew)drift::Interaction->InteractionState->InteractionState->STM()driftitrGettingBody_=writeItritritrReqBodyWasteAllTruedriftitrDecidingHeader_=postprocessitrdriftitr_Done=dobodyIsNull<-readItritritrBodyIsNullidwhenbodyIsNull$writeDefaultPageitrdrift___=return()