------------------------------------------------------------------------------- |-- Module : Network.HTTP-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop-- License : BSD-- -- Maintainer : bjorn@bringert.net-- Stability : experimental-- Portability : non-portable (not tested)---- An easy HTTP interface enjoy.---- * Changes by Robin Bate Boerop <robin@bateboerop.name>:-- - Made dependencies explicit in import statements.-- - Removed false dependencies in import statements.-- - Added missing type signatures.-- - Moved Header-related code to Network.HTTP.Headers module.---- * Changes by Simon Foster:-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules-- - Created functions receiveHTTP and responseHTTP to allow server side interactions-- (although 100-continue is unsupported and I haven't checked for standard compliancy).-- - Pulled the transfer functions from sendHTTP to global scope to allow access by-- above functions.---- * Changes by Graham Klyne:-- - export httpVersion-- - use new URI module (similar to old, but uses revised URI datatype)---- * Changes by Bjorn Bringert:---- - handle URIs with a port number-- - added debugging toggle-- - disabled 100-continue transfers to get HTTP\/1.0 compatibility-- - change 'ioError' to 'throw'-- - Added simpleHTTP_, which takes a stream argument.---- * Changes from 0.1-- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.-- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.-- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic-- and the addition of a debugging stream.-- - simplified error handling.-- -- * TODO-- - request pipelining-- - https upgrade (includes full TLS, i.e. SSL, implementation)-- - use of Stream classes will pay off-- - consider C implementation of encryption\/decryption-- - comm timeouts-- - MIME & entity stuff (happening in separate module)-- - support \"*\" uri-request-string for OPTIONS request method-- -- -- * Header notes:---- [@Host@]-- Required by HTTP\/1.1, if not supplied as part-- of a request a default Host value is extracted-- from the request-uri.-- -- [@Connection@] -- If this header is present in any request or-- response, and it's value is "close", then-- the current request\/response is the last -- to be allowed on that connection.-- -- [@Expect@]-- Should a request contain a body, an Expect-- header will be added to the request. The added-- header has the value \"100-continue\". After-- a 417 \"Expectation Failed\" response the request-- is attempted again without this added Expect-- header.-- -- [@TransferEncoding,ContentLength,...@]-- if request is inconsistent with any of these-- header values then you may not receive any response-- or will generate an error response (probably 4xx).------ * Response code notes-- Some response codes induce special behaviour:---- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent.-- \"101 Upgrade\" will be returned.-- Other 1xx responses are ignored.-- -- [@417@] The reason for this code is \"Expectation failed\", indicating-- that the server did not like the Expect \"100-continue\" header-- added to a request. Receipt of 417 will induce another-- request attempt (without Expect header), unless no Expect header-- had been added (in which case 417 response is returned).-------------------------------------------------------------------------------moduleNetwork.HTTP(moduleNetwork.Stream,moduleNetwork.TCP,-- ** ConstantshttpVersion,-- ** HTTP Request(..),RequestData,Response(..),RequestMethod(..),ResponseCode,simpleHTTP,simpleHTTP_,sendHTTP,receiveHTTP,processRequest,getRequestHead,respondHTTP,-- ** Header FunctionsmoduleNetwork.HTTP.Headers,-- ** URL EncodingurlEncode,urlDecode,urlEncodeVars,-- ** URI authority parsingURIAuthority(..),getAuth,parseURIAuthority)where----------------------------------------------------------------------------------- Imports -------------------------------------------------------------------------------------------------------importNetwork.URI(URI(URI,uriScheme,uriAuthority,uriPath),URIAuth(uriUserInfo,uriRegName,uriPort),parseURIReference,unEscapeString,escapeURIString,isUnescapedInURI)importNetwork.HTTP.HeadersimportNetwork.StreamimportNetwork.StreamDebugger(debugStream)importNetwork.TCP(openTCPPort)importControl.ExceptionasException(catch,throw)importData.Bits((.&.))importData.Char(isSpace,intToDigit,digitToInt,ord,chr,toLower)importData.List(partition,intersperse)importData.Maybe(listToMaybe,fromMaybe)importControl.Monad(when,guard)importNumeric(readHex)importText.Read.Lex(readDecP)importText.ParserCombinators.ReadP(ReadP,readP_to_S,char,(<++),look,munch)-- Turn on to enable HTTP traffic loggingdebug::Booldebug=False-- File that HTTP traffic logs go tohttpLogFile::StringhttpLogFile="http-debug.log"----------------------------------------------------------------------------------- Misc ------------------------------------------------------------------------------------------------------------ remove leading and trailing whitespace.trim::String->Stringtrim=letdropspace=dropWhileisSpaceinreverse.dropspace.reverse.dropspacecrlf,sp::Stringcrlf="\r\n"sp=" "----------------------------------------------------------------------------------- URI Authority parsing -----------------------------------------------------------------------------------------dataURIAuthority=URIAuthority{user::MaybeString,password::MaybeString,host::String,port::MaybeInt}deriving(Eq,Show)-- | Parse the authority part of a URL.---- > RFC 1738, 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----------------------------------------------------------------------------------- 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|CustomStringderiving(Show,Eq)rqMethodMap::[(String,RequestMethod)]rqMethodMap=[("HEAD",HEAD),("PUT",PUT),("GET",GET),("POST",POST),("DELETE",DELETE),("OPTIONS",OPTIONS),("TRACE",TRACE)]-- | An HTTP Request.-- The 'Show' instance of this type is used for message serialisation,-- which means no body data is output.dataRequest=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::String}-- 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.instanceShowRequestwhereshow(Requestumh_)=showm++sp++alt_uri++sp++httpVersion++crlf++foldr(++)[](mapshowh)++crlfwherealt_uri=show$ifnull(uriPathu)||head(uriPathu)/='/'thenu{uriPath='/':uriPathu}elseuinstanceHasHeadersRequestwheregetHeaders=rqHeaderssetHeadersrqhdrs=rq{rqHeaders=hdrs}typeResponseCode=(Int,Int,Int)typeResponseData=(ResponseCode,String,[Header])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.dataResponse=Response{rspCode::ResponseCode,rspReason::String,rspHeaders::[Header],rspBody::String}-- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1instanceShowResponsewhereshow(Response(a,b,c)reasonheaders_)=httpVersion++' ':mapintToDigit[a,b,c]++' ':reason++crlf++foldr(++)[](mapshowheaders)++crlfinstanceHasHeadersResponsewheregetHeaders=rspHeaderssetHeadersrsphdrs=rsp{rspHeaders=hdrs}----------------------------------------------------------------------------------- Parsing --------------------------------------------------------------------------------------------------------- Parsing a requestparseRequestHead::[String]->ResultRequestDataparseRequestHead[]=LeftErrorClosedparseRequestHead(com:hdrs)=requestCommandcom`bindE`\(version,rqm,uri)->parseHeadershdrs`bindE`\hdrs'->Right(rqm,uri,hdrs')whererequestCommandline=casewordslineofyes@(rqm:uri:version)->case(parseURIReferenceuri,lookuprqmrqMethodMap)of(Justu,Justr)->Right(version,r,u)_->Left(ErrorParse$"Request command line parse failure: "++line)no->ifnulllinethenLeftErrorClosedelseLeft(ErrorParse$"Request command line parse failure: "++line)-- Parsing a responseparseResponseHead::[String]->ResultResponseDataparseResponseHead[]=LeftErrorClosedparseResponseHead(sts:hdrs)=responseStatussts`bindE`\(version,code,reason)->parseHeadershdrs`bindE`\hdrs'->Right(code,reason,hdrs')whereresponseStatusline=casewordslineofyes@(version:code:reason)->Right(version,matchcode,concatMap(++" ")reason)no->ifnulllinethenLeftErrorClosed-- an assumptionelseLeft(ErrorParse$"Response status line parse failure: "++line)match[a,b,c]=(digitToInta,digitToIntb,digitToIntc)match_=(-1,-1,-1)-- will create appropriate behaviour----------------------------------------------------------------------------------- HTTP Send / Recv ---------------------------------------------------------------------------------------------------dataBehaviour=Continue|Retry|Done|ExpectEntity|DieHorriblyStringmatchResponse::RequestMethod->ResponseCode->BehaviourmatchResponserqstrsp=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-- | Simple way to get a resource across a non-persistant connection.-- Headers that may be altered:-- Host Altered only if no Host header is supplied, HTTP\/1.1-- requires a Host header.-- Connection Where no allowance is made for persistant connections-- the Connection header will be set to "close"simpleHTTP::Request->IO(ResultResponse)simpleHTTPr=doauth<-getAuthrc<-openTCPPort(hostauth)(fromMaybe80(portauth))simpleHTTP_cr-- | Like 'simpleHTTP', but acting on an already opened stream.simpleHTTP_::Streams=>s->Request->IO(ResultResponse)simpleHTTP_sr=doauth<-getAuthrletr'=fixReqauthrrsp<-ifdebugthendos'<-debugStreamhttpLogFilessendHTTPs'r'elsesendHTTPsr'-- already done by sendHTTP because of "Connection: close" header--; close s returnrspwhere{- 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.fixReq::URIAuthority->Request->RequestfixReqURIAuthority{host=h,port=p}r=leth'=h++maybe""((':':).show)pinreplaceHeaderHdrConnection"close"$insertHeaderIfMissingHdrHosth'$r{rqURI=(rqURIr){uriScheme="",uriAuthority=Nothing}}getAuth::Monadm=>Request->mURIAuthoritygetAuthr=caseparseURIAuthorityauthofJustx->returnxNothing->fail$"Error parsing URI authority '"++auth++"'"whereauth=casefindHeaderHdrHostrofJusth->hNothing->uriToAuthorityString(rqURIr)sendHTTP::Streams=>s->Request->IO(ResultResponse)sendHTTPconnrq=do{leta_rq=fixHostHeaderrq;rsp<-Exception.catch(maina_rq)(\e->do{closeconn;throwe});letfnlist=when(or$mapfindConnCloselist)(closeconn);either(\_->fn[rqHeadersrq])(\r->fn[rqHeadersrq,rspHeadersr])rsp;returnrsp}where-- From RFC 2616, section 8.2.3:-- 'Because of the presence of older implementations, the protocol allows-- ambiguous situations in which a client may send "Expect: 100--- continue" without receiving either a 417 (Expectation Failed) status-- or a 100 (Continue) status. Therefore, when a client sends this-- header field to an origin server (possibly via a proxy) from which it-- has never seen a 100 (Continue) status, the client SHOULD NOT wait-- for an indefinite period before sending the request body.'---- Since we would wait forever, I have disabled use of 100-continue for now.main::Request->IO(ResultResponse)mainrqst=do--let str = if null (rqBody rqst)-- then show rqst-- else show (insertHeader HdrExpect "100-continue" rqst)writeBlockconn(showrqst)-- write body immediately, don't wait for 100 CONTINUEwriteBlockconn(rqBodyrqst)rsp<-getResponseHeadswitchResponseTrueFalsersprqst-- reads and parses headersgetResponseHead::IO(ResultResponseData)getResponseHead=do{lor<-readTillEmpty1conn;return$lor`bindE`parseResponseHead}-- Hmmm, this could go bad if we keep getting "100 Continue"-- responses... Except this should never happen according-- to the RFC.switchResponse::Bool{- allow retry? -}->Bool{- is body sent? -}->ResultResponseData->Request->IO(ResultResponse)switchResponse__(Lefte)_=return(Lefte)-- retry on connreset?-- if we attempt to use the same socket then there is an excellent-- chance that the socket is not in a completely closed state.switchResponseallow_retrybdy_sent(Right(cd,rn,hdrs))rqst=casematchResponse(rqMethodrqst)cdofContinue|notbdy_sent->{- Time to send the body -}do{val<-writeBlockconn(rqBodyrqst);casevalofLefte->return(Lefte)Right_->do{rsp<-getResponseHead;switchResponseallow_retryTruersprqst}}|otherwise->{- keep waiting -}do{rsp<-getResponseHead;switchResponseallow_retrybdy_sentrsprqst}Retry->{- Request with "Expect" header failed.
Trouble is the request contains Expects
other than "100-Continue" -}do{writeBlockconn(showrqst++rqBodyrqst);rsp<-getResponseHead;switchResponseFalsebdy_sentrsprqst}Done->return(Right$Responsecdrnhdrs"")DieHorriblystr->return$Left$ErrorParse("Invalid response: "++str)ExpectEntity->lettc=lookupHeaderHdrTransferEncodinghdrscl=lookupHeaderHdrContentLengthhdrsindo{rslt<-casetcofNothing->caseclofJustx->linearTransferconn(readx::Int)Nothing->hopefulTransferconn""Justx->casemaptoLower(trimx)of"chunked"->chunkedTransferconn_->uglyDeathTransferconn;return$rslt`bindE`\(ftrs,bdy)->Right(Responsecdrn(hdrs++ftrs)bdy)}-- Adds a Host header if one is NOT ALREADY PRESENTfixHostHeader::Request->RequestfixHostHeaderrq=leturi=rqURIrqhost=uriToAuthorityStringuriininsertHeaderIfMissingHdrHosthostrq-- Looks for a "Connection" header with the value "close".-- Returns True when this is found.findConnClose::[Header]->BoolfindConnClosehdrs=caselookupHeaderHdrConnectionhdrsofNothing->FalseJustx->maptoLower(trimx)=="close"-- This function duplicates old Network.URI.authority behaviour.uriToAuthorityString::URI->StringuriToAuthorityStringURI{uriAuthority=Nothing}=""uriToAuthorityStringURI{uriAuthority=Justua}=uriUserInfoua++uriRegNameua++uriPortua-- | Receive and parse a HTTP request from the given Stream. Should be used-- for server side interactions.receiveHTTP::Streams=>s->IO(ResultRequest)receiveHTTPconn=dorq<-getRequestHeadconncaserqofLefte->return(Lefte)Rightr->processRequestconnr-- | Reads and parses request headers.getRequestHead::Streams=>s->IO(ResultRequestData)getRequestHeadconn=do{lor<-readTillEmpty1conn;return$lor`bindE`parseRequestHead}-- | Process request body (called after successful getRequestHead)processRequest::Streams=>s->RequestData->IO(ResultRequest)processRequestconn(rm,uri,hdrs)=do-- FIXME : Also handle 100-continue.lettc=lookupHeaderHdrTransferEncodinghdrscl=lookupHeaderHdrContentLengthhdrsrslt<-casetcofNothing->caseclofJustx->linearTransferconn(readx::Int)Nothing->return(Right([],""))-- hopefulTransfer ""Justx->casemaptoLower(trimx)of"chunked"->chunkedTransferconn_->uglyDeathTransferconnreturn$rslt`bindE`\(ftrs,bdy)->Right(Requesturirm(hdrs++ftrs)bdy)-- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types.respondHTTP::Streams=>s->Response->IO()respondHTTPconnrsp=dowriteBlockconn(showrsp)-- write body immediately, don't wait for 100 CONTINUEwriteBlockconn(rspBodyrsp)return()-- The following functions were in the where clause of sendHTTP, they have-- been moved to global scope so other functions can access them. -- | Used when we know exactly how many bytes to expect.linearTransfer::Streams=>s->Int->IO(Result([Header],String))linearTransferconnn=doinfo<-readBlockconnnreturn$info`bindE`\str->Right([],str)-- | 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::Streams=>s->String->IO(Result([Header],String))hopefulTransferconnstr=readLineconn>>=either(\v->return$Leftv)(\more->ifnullmorethenreturn(Right([],str))elsehopefulTransferconn(str++more))-- | A necessary feature of HTTP\/1.1-- Also the only transfer variety likely to-- return any footers.chunkedTransfer::Streams=>s->IO(Result([Header],String))chunkedTransferconn=chunkedTransferCconn0>>=\v->return$v`bindE`\(ftrs,count,info)->letmyftrs=HeaderHdrContentLength(showcount):ftrsinRight(myftrs,info)chunkedTransferC::Streams=>s->Int->IO(Result([Header],Int,String))chunkedTransferCconnn=readLineconn>>=\v->casevofLefte->return(Lefte)Rightline->letsize=(ifnulllinethen0elsecasereadHexlineof(n,_):_->n_->0)inifsize==0thendo{rs<-readTillEmpty2conn[];return$rs`bindE`\strs->parseHeadersstrs`bindE`\ftrs->Right(ftrs,n,"")}elsedo{some<-readBlockconnsize;readLineconn;more<-chunkedTransferCconn(n+size);return$some`bindE`\cdata->more`bindE`\(ftrs,m,mdata)->Right(ftrs,m,cdata++mdata)}-- | Maybe in the future we will have a sensible thing-- to do here, at that time we might want to change-- the name.uglyDeathTransfer::Streams=>s->IO(Result([Header],String))uglyDeathTransferconn=return$Left$ErrorParse"Unknown Transfer-Encoding"-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)readTillEmpty1::Streams=>s->IO(Result[String])readTillEmpty1conn=do{line<-readLineconn;caselineofLefte->return$LefteRights->ifs==crlfthenreadTillEmpty1connelsereadTillEmpty2conn[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::Streams=>s->[String]->IO(Result[String])readTillEmpty2connlist=do{line<-readLineconn;caselineofLefte->return$LefteRights->ifs==crlf||nullsthenreturn(Right$reverse(s:list))elsereadTillEmpty2conn(s:list)}----------------------------------------------------------------------------------- A little friendly funtionality ---------------------------------------------------------------------------------- | Formats name-value pairs as application\/x-www-form-urlencoded.urlEncodeVars::[(String,String)]->StringurlEncodeVarsxs=concat$intersperse"&"[urlEncoden++"="++urlEncodev|(n,v)<-xs]-- | Converts a single value to the application\/x-www-form-urlencoded encoding.urlEncode::String->StringurlEncode=replace' ''+'.escapeURIStringokCharwhereokCharc=c==' '||(isUnescapedInURIc&&c`notElem`"&=+")-- | Converts a single value from the -- application\/x-www-form-urlencoded encoding.urlDecode::String->StringurlDecode=unEscapeString.replace'+'' '-- | Replaces all instances of a value in a list by another value.replace::Eqa=>a-- ^ Value to look for->a-- ^ Value to replace it with->[a]-- ^ Input list->[a]-- ^ Output listreplacexy=map(\z->ifz==xthenyelsez)