------------------------------------------------------------------------------- |-- Module : Network.HTTP.Base-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne-- License : BSD-- -- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>-- Stability : experimental-- Portability : non-portable (not tested)---- Definitions of @Request@ and @Response@ types along with functions-- for normalizing them. It is assumed to be an internal module; user-- code should, if possible, import @Network.HTTP@ to access the functionality-- that this module provides.---- Additionally, the module exports internal functions for working with URLs,-- and for handling the processing of requests and responses coming back.-------------------------------------------------------------------------------moduleNetwork.HTTP.Base(-- ** ConstantshttpVersion-- :: String-- ** HTTP,Request(..),Response(..),RequestMethod(..),Request_String,Response_String,HTTPRequest,HTTPResponse-- ** URL Encoding,urlEncode,urlDecode,urlEncodeVars-- ** URI authority parsing,URIAuthority(..),parseURIAuthority-- internal,uriToAuthorityString-- :: URI -> String,uriAuthToString-- :: URIAuth -> String,uriAuthPort-- :: Maybe URI -> URIAuth -> Int,reqURIAuth-- :: Request ty -> URIAuth,parseResponseHead-- :: [String] -> Result ResponseData,parseRequestHead-- :: [String] -> Result RequestData,ResponseNextStep(..),matchResponse,ResponseData,ResponseCode,RequestData,NormalizeRequestOptions(..),defaultNormalizeRequestOptions-- :: NormalizeRequestOptions ty,RequestNormalizer,normalizeRequest-- :: NormalizeRequestOptions ty -> Request ty -> Request ty,splitRequestURI,getAuth,normalizeRequestURI,normalizeHostHeader,findConnClose-- internal export (for the use by Network.HTTP.{Stream,ByteStream} ),linearTransfer,hopefulTransfer,chunkedTransfer,uglyDeathTransfer,readTillEmpty1,readTillEmpty2,defaultGETRequest,defaultGETRequest_,mkRequest,defaultUserAgent,libUA{- backwards compatibility, will disappear..soon -},catchIO,catchIO_,responseParseError,getRequestVersion,getResponseVersion,setRequestVersion,setResponseVersion)whereimportNetwork.URI(URI(uriAuthority,uriPath,uriScheme),URIAuth(URIAuth,uriUserInfo,uriRegName,uriPort),parseURIReference)importControl.Monad(guard)importControl.Monad.Error()importData.Char(digitToInt,intToDigit,toLower,isDigit,isAscii,isAlphaNum)importData.List(partition,find)importData.Maybe(listToMaybe,fromMaybe)importNumeric(readHex)importNetwork.StreamimportNetwork.BufferType(BufferOp(..),BufferType(..))importNetwork.HTTP.HeadersimportNetwork.HTTP.Utils(trim,crlf,sp,readsOne)importText.Read.Lex(readDecP)importText.ParserCombinators.ReadP(ReadP,readP_to_S,char,(<++),look,munch)importControl.ExceptionasException(IOException)----------------------------------------------------------------------------------- URI Authority parsing -----------------------------------------------------------------------------------------dataURIAuthority=URIAuthority{user::MaybeString,password::MaybeString,host::String,port::MaybeInt}deriving(Eq,Show)-- | Parse the authority part of a URL.---- > RFC 1732, section 3.1:-- >-- > //<user>:<password>@<host>:<port>/<url-path>-- > Some or all of the parts "<user>:<password>@", ":<password>",-- > ":<port>", and "/<url-path>" may be excluded.parseURIAuthority::String->MaybeURIAuthorityparseURIAuthoritys=listToMaybe(mapfst(readP_to_SpURIAuthoritys))pURIAuthority::ReadPURIAuthoritypURIAuthority=do(u,pw)<-(pUserInfo`before`char'@')<++return(Nothing,Nothing)h<-munch(/=':')p<-orNothing(char':'>>readDecP)look>>=guard.nullreturnURIAuthority{user=u,password=pw,host=h,port=p}pUserInfo::ReadP(MaybeString,MaybeString)pUserInfo=dou<-orNothing(munch(`notElem`":@"))p<-orNothing(char':'>>munch(/='@'))return(u,p)before::Monadm=>ma->mb->mabeforeab=a>>=\x->b>>returnxorNothing::ReadPa->ReadP(Maybea)orNothingp=fmapJustp<++returnNothing-- This function duplicates old Network.URI.authority behaviour.uriToAuthorityString::URI->StringuriToAuthorityStringu=maybe""uriAuthToString(uriAuthorityu)uriAuthToString::URIAuth->StringuriAuthToStringua=concat[uriUserInfoua,uriRegNameua,uriPortua]uriAuthPort::MaybeURI->URIAuth->InturiAuthPortmbURIu=caseuriPortuof(':':s)->readsOneid(default_portmbURI)s_->default_portmbURIwheredefault_portNothing=default_httpdefault_port(Justurl)=casemaptoLower$uriSchemeurlof"http:"->default_http"https:"->default_https-- todo: refine_->default_httpdefault_http=80default_https=443-- Fish out the authority from a possibly normalized Request, i.e.,-- the information may either be in the request's URI or inside-- the Host: header.reqURIAuth::Requestty->URIAuthreqURIAuthreq=caseuriAuthority(rqURIreq)ofJustua->ua_->caselookupHeaderHdrHost(rqHeadersreq)ofNothing->error("reqURIAuth: no URI authority for: "++showreq)Justh->casetoHostPorthof(ht,p)->URIAuth{uriUserInfo="",uriRegName=ht,uriPort=p}where-- Note: just in case you're wondering..the convention is to include the ':'-- in the port part..toHostPorth=break(==':')h----------------------------------------------------------------------------------- HTTP Messages --------------------------------------------------------------------------------------------------- Protocol versionhttpVersion::StringhttpVersion="HTTP/1.1"-- | The HTTP request method, to be used in the 'Request' object.-- We are missing a few of the stranger methods, but these are-- not really necessary until we add full TLS.dataRequestMethod=HEAD|PUT|GET|POST|DELETE|OPTIONS|TRACE|CONNECT|CustomStringderiving(Eq)instanceShowRequestMethodwhereshowx=casexofHEAD->"HEAD"PUT->"PUT"GET->"GET"POST->"POST"DELETE->"DELETE"OPTIONS->"OPTIONS"TRACE->"TRACE"CONNECT->"CONNECT"Customc->crqMethodMap::[(String,RequestMethod)]rqMethodMap=[("HEAD",HEAD),("PUT",PUT),("GET",GET),("POST",POST),("DELETE",DELETE),("OPTIONS",OPTIONS),("TRACE",TRACE),("CONNECT",CONNECT)]-- -- for backwards-ish compatibility; suggest-- migrating to new Req/Resp by adding type param.-- typeRequest_String=RequestStringtypeResponse_String=ResponseString-- Hmm..I really want to use these for the record-- type, but it will upset codebases wanting to-- migrate (and live with using pre-HTTPbis versions.)typeHTTPRequesta=RequestatypeHTTPResponsea=Responsea-- | An HTTP Request.-- The 'Show' instance of this type is used for message serialisation,-- which means no body data is output.dataRequesta=Request{rqURI::URI-- ^ might need changing in future-- 1) to support '*' uri in OPTIONS request-- 2) transparent support for both relative-- & absolute uris, although this should-- already work (leave scheme & host parts empty).,rqMethod::RequestMethod,rqHeaders::[Header],rqBody::a}-- Notice that request body is not included,-- this show function is used to serialise-- a request for the transport link, we send-- the body separately where possible.instanceShow(Requesta)whereshowreq@(Requestumh_)=showm++sp++alt_uri++sp++ver++crlf++foldr(++)[](mapshow(dropHttpVersionh))++crlfwherever=fromMaybehttpVersion(getRequestVersionreq)alt_uri=show$ifnull(uriPathu)||head(uriPathu)/='/'thenu{uriPath='/':uriPathu}elseuinstanceHasHeaders(Requesta)wheregetHeaders=rqHeaderssetHeadersrqhdrs=rq{rqHeaders=hdrs}-- | For easy pattern matching, HTTP response codes @xyz@ are-- represented as @(x,y,z)@.typeResponseCode=(Int,Int,Int)-- | @ResponseData@ contains the head of a response payload;-- HTTP response code, accompanying text description + header-- fields.typeResponseData=(ResponseCode,String,[Header])-- | @RequestData@ contains the head of a HTTP request; method,-- its URL along with the auxillary/supporting header data.typeRequestData=(RequestMethod,URI,[Header])-- | An HTTP Response.-- The 'Show' instance of this type is used for message serialisation,-- which means no body data is output, additionally the output will-- show an HTTP version of 1.1 instead of the actual version returned-- by a server.dataResponsea=Response{rspCode::ResponseCode,rspReason::String,rspHeaders::[Header],rspBody::a}-- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1instanceShow(Responsea)whereshowrsp@(Response(a,b,c)reasonheaders_)=ver++' ':mapintToDigit[a,b,c]++' ':reason++crlf++foldr(++)[](mapshow(dropHttpVersionheaders))++crlfwherever=fromMaybehttpVersion(getResponseVersionrsp)instanceHasHeaders(Responsea)wheregetHeaders=rspHeaderssetHeadersrsphdrs=rsp{rspHeaders=hdrs}------------------------------------------------------------------------------------ Request Building ------------------------------------------------------------------------------------------------libUA::StringlibUA="hs-HTTP-4000.0.9"defaultUserAgent::StringdefaultUserAgent=libUAdefaultGETRequest::URI->Request_StringdefaultGETRequesturi=defaultGETRequest_uridefaultGETRequest_::BufferTypea=>URI->RequestadefaultGETRequest_uri=mkRequestGETuri-- | 'mkRequest method uri' constructs a well formed-- request for the given HTTP method and URI. It does not-- normalize the URI for the request _nor_ add the required -- Host: header. That is done either explicitly by the user-- or when requests are normalized prior to transmission.mkRequest::BufferTypety=>RequestMethod->URI->RequesttymkRequestmethuri=reqwherereq=Request{rqURI=uri,rqBody=empty,rqHeaders=[HeaderHdrContentLength"0",HeaderHdrUserAgentdefaultUserAgent],rqMethod=meth}empty=buf_empty(toBufOpsreq){-
-- stub out the user info.
updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri)
withHost =
case uriToAuthorityString uri{uriAuthority=updAuth} of
"" -> id
h -> ((Header HdrHost h):)
uri_req
| forProxy = uri
| otherwise = snd (splitRequestURI uri)
-}toBufOps::BufferTypea=>Requesta->BufferOpatoBufOps_=bufferOps----------------------------------------------------------------------------------- Parsing --------------------------------------------------------------------------------------------------------- Parsing a requestparseRequestHead::[String]->ResultRequestDataparseRequestHead[]=LeftErrorClosedparseRequestHead(com:hdrs)=do(version,rqm,uri)<-requestCommandcom(wordscom)hdrs'<-parseHeadershdrsreturn(rqm,uri,withVerversionhdrs')wherewithVer[]hs=hswithVer(h:_)hs=withVersionhhsrequestCommandl_yes@(rqm:uri:version)=case(parseURIReferenceuri,lookuprqmrqMethodMap)of(Justu,Justr)->return(version,r,u)(Justu,Nothing)->return(version,Customrqm,u)_->parse_errlrequestCommandl_|nulll=failWithErrorClosed|otherwise=parse_errlparse_errl=responseParseError"parseRequestHead"("Request command line parse failure: "++l)-- Parsing a responseparseResponseHead::[String]->ResultResponseDataparseResponseHead[]=failWithErrorClosedparseResponseHead(sts:hdrs)=do(version,code,reason)<-responseStatussts(wordssts)hdrs'<-parseHeadershdrsreturn(code,reason,withVersionversionhdrs')whereresponseStatus_l_yes@(version:code:reason)=return(version,matchcode,concatMap(++" ")reason)responseStatusl_no|nulll=failWithErrorClosed-- an assumption|otherwise=parse_errlparse_errl=responseParseError"parseResponseHead"("Response status line parse failure: "++l)match[a,b,c]=(digitToInta,digitToIntb,digitToIntc)match_=(-1,-1,-1)-- will create appropriate behaviour-- To avoid changing the @RequestData@ and @ResponseData@ types-- just for this (and the upstream backwards compat. woes that-- will result in), encode version info as a custom header.-- Used by 'parseResponseData' and 'parseRequestData'.---- Note: the Request and Response types do not currently represent-- the version info explicitly in their record types. You have to use-- {get,set}{Request,Response}Version for that.withVersion::String->[Header]->[Header]withVersionvhs|v==httpVersion=hs-- don't bother adding it if the default.|otherwise=(Header(HdrCustom"X-HTTP-Version")v):hs-- | @getRequestVersion req@ returns the HTTP protocol version of-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed.getRequestVersion::Requesta->MaybeStringgetRequestVersionr=getHttpVersionr-- | @setRequestVersion v req@ returns a new request, identical to-- @req@, but with its HTTP version set to @v@.setRequestVersion::String->Requesta->RequestasetRequestVersionsr=setHttpVersionrs-- | @getResponseVersion rsp@ returns the HTTP protocol version of-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be -- assumed.getResponseVersion::Responsea->MaybeStringgetResponseVersionr=getHttpVersionr-- | @setResponseVersion v rsp@ returns a new response, identical to-- @rsp@, but with its HTTP version set to @v@.setResponseVersion::String->Responsea->ResponseasetResponseVersionsr=setHttpVersionrs-- internal functions for accessing HTTP-version info in-- requests and responses. Not exported as it exposes ho-- version info is represented internally.getHttpVersion::HasHeadersa=>a->MaybeStringgetHttpVersionr=fmaptoVersion$findisHttpVersion$getHeadersrwheretoVersion(Header_x)=xsetHttpVersion::HasHeadersa=>a->String->asetHttpVersionrv=setHeadersr$withVersionv$dropHttpVersion$getHeadersrdropHttpVersion::[Header]->[Header]dropHttpVersionhs=filter(not.isHttpVersion)hsisHttpVersion::Header->BoolisHttpVersion(Header(HdrCustom"X-HTTP-Version")_)=TrueisHttpVersion_=False----------------------------------------------------------------------------------- HTTP Send / Recv ---------------------------------------------------------------------------------------------------dataResponseNextStep=Continue|Retry|Done|ExpectEntity|DieHorriblyStringmatchResponse::RequestMethod->ResponseCode->ResponseNextStepmatchResponserqstrsp=caserspof(1,0,0)->Continue(1,0,1)->Done-- upgrade to TLS(1,_,_)->Continue-- default(2,0,4)->Done(2,0,5)->Done(2,_,_)->ans(3,0,4)->Done(3,0,5)->Done(3,_,_)->ans(4,1,7)->Retry-- Expectation failed(4,_,_)->ans(5,_,_)->ans(a,b,c)->DieHorribly("Response code "++mapintToDigit[a,b,c]++" not recognised")whereans|rqst==HEAD=Done|otherwise=ExpectEntity----------------------------------------------------------------------------------- A little friendly funtionality --------------------------------------------------------------------------------{-
I had a quick look around but couldn't find any RFC about
the encoding of data on the query string. I did find an
IETF memo, however, so this is how I justify the urlEncode
and urlDecode methods.
Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)
Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.
Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"
URI delims: "<" | ">" | "#" | "%" | <">
Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>
<US-ASCII coded character 20 hexadecimal>
Also unallowed: any non-us-ascii character
Escape method: char -> '%' a b where a, b :: Hex digits
-}urlDecode::String->StringurlDecode('%':a:b:rest)=toEnum(16*digitToInta+digitToIntb):urlDecoderesturlDecode(h:t)=h:urlDecodeturlDecode[]=[]urlEncode::String->StringurlEncode[]=[]urlEncode(ch:t)|(isAsciich&&isAlphaNumch)||ch`elem`"-_.~"=ch:urlEncodet|not(isAsciich)=foldrescape(urlEncodet)(eightBs[](fromEnumch))|otherwise=escape(fromEnumch)(urlEncodet)whereescapebrs='%':showH(b`div`16)(showH(b`mod`16)rs)showHxxs|x<=9=toEnum(o_0+x):xs|otherwise=toEnum(o_A+(x-10)):xswhereo_0=fromEnum'0'o_A=fromEnum'A'eightBs::[Int]->Int->[Int]eightBsaccx|x<=0xff=(x:acc)|otherwise=eightBs((x`mod`256):acc)(x`div`256)-- Encode form variables, useable in either the-- query part of a URI, or the body of a POST request.-- I have no source for this information except experience,-- this sort of encoding worked fine in CGI programming.urlEncodeVars::[(String,String)]->StringurlEncodeVars((n,v):t)=let(same,diff)=partition((==n).fst)tinurlEncoden++'=':foldl(\xy->x++',':urlEncodey)(urlEncode$v)(mapsndsame)++urlEncodeRestdiffwhereurlEncodeRest[]=[]urlEncodeRestdiff='&':urlEncodeVarsdiffurlEncodeVars[]=[]-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@-- header.getAuth::Monadm=>Requestty->mURIAuthoritygetAuthr=-- ToDo: verify that Network.URI functionality doesn't take care of this (now.)caseparseURIAuthorityauthofJustx->returnxNothing->fail$"Network.HTTP.Base.getAuth: Error parsing URI authority '"++auth++"'"whereauth=maybe(uriToAuthorityStringuri)id(findHeaderHdrHostr)uri=rqURIr{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-}normalizeRequestURI::Bool{-do close-}->{-URI-}String->Requestty->RequesttynormalizeRequestURIdoClosehr=(ifdoClosethenreplaceHeaderHdrConnection"close"elseid)$insertHeaderIfMissingHdrHosth$r{rqURI=(rqURIr){uriScheme="",uriAuthority=Nothing}}-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of optiondataNormalizeRequestOptionsty=NormalizeRequestOptions{normDoClose::Bool,normForProxy::Bool,normUserAgent::MaybeString,normCustoms::[RequestNormalizerty]}-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites-- a request into some normalized form.typeRequestNormalizerty=NormalizeRequestOptionsty->Requestty->RequesttydefaultNormalizeRequestOptions::NormalizeRequestOptionstydefaultNormalizeRequestOptions=NormalizeRequestOptions{normDoClose=False,normForProxy=False,normUserAgent=JustdefaultUserAgent,normCustoms=[]}-- | @normalizeRequest opts req@ is the entry point to use to normalize your-- request prior to transmission (or other use.) Normalization is controlled-- via the @NormalizeRequestOptions@ record.normalizeRequest::NormalizeRequestOptionsty->Requestty->RequesttynormalizeRequestoptsreq=foldr(\f->fopts)reqnormalizerswhere--normalizers :: [RequestNormalizer ty]normalizers=(normalizeHostURI:normalizeConnectionClose:normalizeUserAgent:normCustomsopts)-- | @normalizeUserAgent ua x req@ augments the request @req@ with -- a @User-Agent: ua@ header if @req@ doesn't already have a -- a @User-Agent:@ set.normalizeUserAgent::RequestNormalizertynormalizeUserAgentoptsreq=casenormUserAgentoptsofNothing->reqJustua->casefindHeaderHdrUserAgentreqofJustu|u/=defaultUserAgent->req_->replaceHeaderHdrUserAgentuareq-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ -- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then-- _replaces_ any an existing @Connection:@ header in @req@.normalizeConnectionClose::RequestNormalizertynormalizeConnectionCloseoptsreq|normDoCloseopts=replaceHeaderHdrConnection"close"req|otherwise=req-- | @normalizeHostURI forProxy req@ rewrites your request to have it-- follow the expected formats by the receiving party (proxy or server.)-- normalizeHostURI::RequestNormalizertynormalizeHostURIoptsreq=casesplitRequestURIuriof("",_uri_abs)|forProxy->casefindHeaderHdrHostreqofNothing->req-- no host/authority in sight..not much we can do.Justh->req{rqURI=uri{uriAuthority=JustURIAuth{uriUserInfo="",uriRegName=hst,uriPort=pNum},uriScheme=if(null(uriSchemeuri))then"http"elseuriSchemeuri}}wherehst=casespan(/='@')user_hstof(as,'@':bs)->casespan(/=':')asof(_,_:_)->bs_->user_hst_->user_hst(user_hst,pNum)=casespanisDigit(reverseh)of(ds,':':bs)->(reversebs,':':reverseds)_->(h,"")|otherwise->casefindHeaderHdrHostreqofNothing->req-- no host/authority in sight..not much we can do...complain?Just{}->req(h,uri_abs)|forProxy->insertHeaderIfMissingHdrHosthreq|otherwise->replaceHeaderHdrHosthreq{rqURI=uri_abs}-- Note: _not_ stubbing out user:passwhereuri0=rqURIreq-- stub out the user:pass uri=uri0{uriAuthority=fmap(\x->x{uriUserInfo=""})(uriAuthorityuri0)}forProxy=normForProxyopts{- Comments re: above rewriting:
RFC 2616, section 5.1.2:
"The most common form of Request-URI is that used to identify a
resource on an origin server or gateway. In this case the absolute
path of the URI MUST be transmitted (see section 3.2.1, abs_path) as
the Request-URI, and the network location of the URI (authority) MUST
be transmitted in a Host header field."
We assume that this is the case, so we take the host name from
the Host header if there is one, otherwise from the request-URI.
Then we make the request-URI an abs_path and make sure that there
is a Host header.
-}splitRequestURI::URI->({-authority-}String,URI)splitRequestURIuri=(uriToAuthorityStringuri,uri{uriScheme="",uriAuthority=Nothing})-- Adds a Host header if one is NOT ALREADY PRESENT..{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-}normalizeHostHeader::Requestty->RequesttynormalizeHostHeaderrq=insertHeaderIfMissingHdrHost(uriToAuthorityString$rqURIrq)rq-- Looks for a "Connection" header with the value "close".-- Returns True when this is found.findConnClose::[Header]->BoolfindConnClosehdrs=maybeFalse(\x->maptoLower(trimx)=="close")(lookupHeaderHdrConnectionhdrs)-- | Used when we know exactly how many bytes to expect.linearTransfer::(Int->IO(Resulta))->Int->IO(Result([Header],a))linearTransferreadBlkn=fmapE(\str->Right([],str))(readBlkn)-- | Used when nothing about data is known,-- Unfortunately waiting for a socket closure-- causes bad behaviour. Here we just-- take data once and give up the rest.hopefulTransfer::BufferOpa->IO(Resulta)->[a]->IO(Result([Header],a))hopefulTransferbufOpsreadLstrs=readL>>=either(\v->return$Leftv)(\more->if(buf_isEmptybufOpsmore)thenreturn(Right([],foldr(flip(buf_appendbufOps))(buf_emptybufOps)strs))elsehopefulTransferbufOpsreadL(more:strs))-- | A necessary feature of HTTP\/1.1-- Also the only transfer variety likely to-- return any footers.chunkedTransfer::BufferOpa->IO(Resulta)->(Int->IO(Resulta))->IO(Result([Header],a))chunkedTransferbufOpsreadLreadBlk=chunkedTransferCbufOpsreadLreadBlk[]0chunkedTransferC::BufferOpa->IO(Resulta)->(Int->IO(Resulta))->[a]->Int->IO(Result([Header],a))chunkedTransferCbufOpsreadLreadBlkaccn=dov<-readLcasevofLefte->return(Lefte)Rightline|size==0->-- last chunk read; look for trailing headers..fmapE(\strs->doftrs<-parseHeaders(map(buf_toStrbufOps)strs)-- insert (computed) Content-Length header.letftrs'=HeaderHdrContentLength(shown):ftrsreturn(ftrs',buf_concatbufOps(reverseacc)))(readTillEmpty2bufOpsreadL[])|otherwise->dosome<-readBlksizecasesomeofLefte->return(Lefte)Rightcdata->doreadL-- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?chunkedTransferCbufOpsreadLreadBlk(cdata:acc)(n+size)wheresize|buf_isEmptybufOpsline=0|otherwise=casereadHex(buf_toStrbufOpsline)of(hx,_):_->hx_->0-- | Maybe in the future we will have a sensible thing-- to do here, at that time we might want to change-- the name.uglyDeathTransfer::String->IO(Result([Header],a))uglyDeathTransferloc=return(responseParseErrorloc"Unknown Transfer-Encoding")-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)readTillEmpty1::BufferOpa->IO(Resulta)->IO(Result[a])readTillEmpty1bufOpsreadL=readL>>=either(return.Left)(\s->ifbuf_isLineTermbufOpssthenreadTillEmpty1bufOpsreadLelsereadTillEmpty2bufOpsreadL[s])-- | Read lines until an empty line (CRLF),-- also accepts a connection close as end of-- input, which is not an HTTP\/1.1 compliant-- thing to do - so probably indicates an-- error condition.readTillEmpty2::BufferOpa->IO(Resulta)->[a]->IO(Result[a])readTillEmpty2bufOpsreadLlist=readL>>=either(return.Left)(\s->ifbuf_isLineTermbufOpss||buf_isEmptybufOpssthenreturn(Right$reverse(s:list))elsereadTillEmpty2bufOpsreadL(s:list))---- Misc---- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific-- tweaks better go here.catchIO::IOa->(IOException->IOa)->IOacatchIOah=Prelude.catchahcatchIO_::IOa->IOa->IOacatchIO_ah=Prelude.catcha(consth)responseParseError::String->String->ResultaresponseParseErrorlocv=failWith(ErrorParse(loc++' ':v))