------------------------------------------------------------------------------- |-- Module : Network.HTTP.Stream-- Copyright : See LICENSE file-- License : BSD-- -- Maintainer : Ganesh Sittampalam <ganesh@earth.li>-- Stability : experimental-- Portability : non-portable (not tested)---- Transmitting HTTP requests and responses holding @String@ in their payload bodies.-- This is one of the implementation modules for the "Network.HTTP" interface, representing-- request and response content as @String@s and transmitting them in non-packed form-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles.-- It is mostly here for backwards compatibility, representing how requests and responses-- were transmitted up until the 4.x releases of the HTTP package.---- For more detailed information about what the individual exports do, please consult-- the documentation for "Network.HTTP". /Notice/ however that the functions here do-- not perform any kind of normalization prior to transmission (or receipt); you are-- responsible for doing any such yourself, or, if you prefer, just switch to using-- "Network.HTTP" function instead.-- -----------------------------------------------------------------------------moduleNetwork.HTTP.Stream(moduleNetwork.Stream ,simpleHTTP -- :: Request_String -> IO (Result Response_String),simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String),sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String),sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String),receiveHTTP -- :: Stream s => s -> IO (Result Request_String),respondHTTP -- :: Stream s => s -> Response_String -> IO ())where----------------------------------------------------------------------------------- Imports -------------------------------------------------------------------------------------------------------importNetwork.Stream importNetwork.StreamDebugger (debugStream )importNetwork.TCP (openTCPPort )importNetwork.BufferType (stringBufferOp )importNetwork.HTTP.Base importNetwork.HTTP.Headers importNetwork.HTTP.Utils (trim )importData.Char(toLower)importData.Maybe(fromMaybe)importControl.Exception(onException)importControl.Monad(when)-- Turn on to enable HTTP traffic loggingdebug::Booldebug =False-- File that HTTP traffic logs go tohttpLogFile::StringhttpLogFile ="http-debug.log"----------------------------------------------------------------------------------- Misc ------------------------------------------------------------------------------------------------------------ | Simple way to transmit a resource across a non-persistent connection.simpleHTTP::Request_String ->IO(Result Response_String )simpleHTTP r =doauth <-getAuth r c <-openTCPPort (hostauth )(fromMaybe80(portauth ))simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream.simpleHTTP_::Stream s =>s ->Request_String ->IO(Result Response_String )simpleHTTP_ s r |notdebug =sendHTTP s r |otherwise=dos' <-debugStream httpLogFile s sendHTTP s' r sendHTTP::Stream s =>s ->Request_String ->IO(Result Response_String )sendHTTP conn rq =sendHTTP_notify conn rq (return())sendHTTP_notify::Stream s =>s ->Request_String ->IO()->IO(Result Response_String )sendHTTP_notify conn rq onSendComplete =dowhenprovidedClose $(closeOnEnd conn True)onException(sendMain conn rq onSendComplete )(close conn )whereprovidedClose =findConnClose (rqHeadersrq )-- 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.sendMain::Stream s =>s ->Request_String ->IO()->IO(Result Response_String )sendMain conn rqst onSendComplete =do--let str = if null (rqBody rqst)-- then show rqst-- else show (insertHeader HdrExpect "100-continue" rqst)-- TODO review throwing away of result_<-writeBlock conn (showrqst )-- write body immediately, don't wait for 100 CONTINUE-- TODO review throwing away of result_<-writeBlock conn (rqBodyrqst )onSendComplete rsp <-getResponseHead conn switchResponse conn TrueFalsersp rqst -- reads and parses headersgetResponseHead::Stream s =>s ->IO(Result ResponseData )getResponseHead conn =dolor <-readTillEmpty1 stringBufferOp (readLine conn )return$lor >>=parseResponseHead -- Hmmm, this could go bad if we keep getting "100 Continue"-- responses... Except this should never happen according-- to the RFC.switchResponse::Stream s =>s ->Bool{- allow retry? -}->Bool{- is body sent? -}->Result ResponseData ->Request_String ->IO(Result Response_String )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.switchResponseconn allow_retry bdy_sent (Right(cd ,rn ,hdrs ))rqst =casematchResponse (rqMethodrqst )cd ofContinue |notbdy_sent ->{- Time to send the body -}do{val <-writeBlock conn (rqBodyrqst );caseval ofLefte ->return(Lefte )Right_->do{rsp <-getResponseHead conn ;switchResponse conn allow_retry Truersp rqst }}|otherwise->{- keep waiting -}do{rsp <-getResponseHead conn ;switchResponse conn allow_retry bdy_sent rsp rqst }Retry ->{- Request with "Expect" header failed.
 Trouble is the request contains Expects
 other than "100-Continue" -}do{-- TODO review throwing away of result_<-writeBlock conn (showrqst ++rqBodyrqst );rsp <-getResponseHead conn ;switchResponse conn Falsebdy_sent rsp rqst }Done ->dowhen(findConnClose hdrs )(closeOnEnd conn True)return(Right$Response cd rn hdrs "")DieHorribly str ->doclose conn return$responseParseError "sendHTTP"("Invalid response: "++str )ExpectEntity ->lettc =lookupHeader HdrTransferEncoding hdrs cl =lookupHeader HdrContentLength hdrs indo{rslt <-casetc ofNothing->casecl ofJustx ->linearTransfer (readBlock conn )(readx ::Int)Nothing->hopefulTransfer stringBufferOp {-null (++) []-}(readLine conn )[]Justx ->casemaptoLower(trim x )of"chunked"->chunkedTransfer stringBufferOp (readLine conn )(readBlock conn )_->uglyDeathTransfer "sendHTTP";caserslt ofLefte ->close conn >>return(Lefte )Right(ftrs ,bdy )->dowhen(findConnClose (hdrs ++ftrs ))(closeOnEnd conn True)return(Right(Response cd rn (hdrs ++ftrs )bdy ))}-- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions.receiveHTTP::Stream s =>s ->IO(Result Request_String )receiveHTTP conn =getRequestHead >>=processRequest where-- reads and parses headersgetRequestHead::IO(Result RequestData )getRequestHead =do{lor <-readTillEmpty1 stringBufferOp (readLine conn );return$lor >>=parseRequestHead }processRequest (Lefte )=return$Lefte processRequest(Right(rm ,uri ,hdrs ))=do-- FIXME : Also handle 100-continue.lettc =lookupHeader HdrTransferEncoding hdrs cl =lookupHeader HdrContentLength hdrs rslt <-casetc ofNothing->casecl ofJustx ->linearTransfer (readBlock conn )(readx ::Int)Nothing->return(Right([],""))-- hopefulTransfer ""Justx ->casemaptoLower(trim x )of"chunked"->chunkedTransfer stringBufferOp (readLine conn )(readBlock conn )_->uglyDeathTransfer "receiveHTTP"return$do(ftrs ,bdy )<-rslt return(Request uri rm (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::Stream s =>s ->Response_String ->IO()respondHTTP conn rsp =do-- TODO review throwing away of result_<-writeBlock conn (showrsp )-- write body immediately, don't wait for 100 CONTINUE-- TODO review throwing away of result_<-writeBlock conn (rspBodyrsp )return()