------------------------------------------------------------------------------- |-- 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 :: Bool
debug =Bool
False-- File that HTTP traffic logs go tohttpLogFile ::StringhttpLogFile :: String
httpLogFile =String
"http-debug.log"----------------------------------------------------------------------------------- Misc ------------------------------------------------------------------------------------------------------------ | Simple way to transmit a resource across a non-persistent connection.simpleHTTP ::Request_String ->IO(Result Response_String )simpleHTTP :: Request_String -> IO (Result Response_String)
simpleHTTP Request_String
r =doURIAuthority
auth <-Request_String -> IO URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request_String
r Connection
c <-String -> Int -> IO Connection
openTCPPort (URIAuthority -> String
host URIAuthority
auth )(Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybeInt
80(URIAuthority -> Maybe Int
port URIAuthority
auth ))Connection -> Request_String -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
simpleHTTP_ Connection
c Request_String
r -- | Like 'simpleHTTP', but acting on an already opened stream.simpleHTTP_ ::Stream s =>s ->Request_String ->IO(Result Response_String )simpleHTTP_ :: s -> Request_String -> IO (Result Response_String)
simpleHTTP_ s
s Request_String
r |Bool -> Bool
notBool
debug =s -> Request_String -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
sendHTTP s
s Request_String
r |Bool
otherwise=doStreamDebugger s
s' <-String -> s -> IO (StreamDebugger s)
forall a. Stream a => String -> a -> IO (StreamDebugger a)
debugStream String
httpLogFile s
s StreamDebugger s -> Request_String -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
sendHTTP StreamDebugger s
s' Request_String
r sendHTTP ::Stream s =>s ->Request_String ->IO(Result Response_String )sendHTTP :: s -> Request_String -> IO (Result Response_String)
sendHTTP s
conn Request_String
rq =s -> Request_String -> IO () -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify s
conn Request_String
rq (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return())sendHTTP_notify ::Stream s =>s ->Request_String ->IO()->IO(Result Response_String )sendHTTP_notify :: s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify s
conn Request_String
rq IO ()
onSendComplete =doBool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
whenBool
providedClose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$(s -> Bool -> IO ()
forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)IO (Result Response_String) -> IO () -> IO (Result Response_String)
forall a b. IO a -> IO b -> IO a
onException(s -> Request_String -> IO () -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendMain s
conn Request_String
rq IO ()
onSendComplete )(s -> IO ()
forall x. Stream x => x -> IO ()
close s
conn )whereprovidedClose :: Bool
providedClose =[Header] -> Bool
findConnClose (Request_String -> [Header]
forall a. Request a -> [Header]
rqHeaders Request_String
rq )-- 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 :: s -> Request_String -> IO () -> IO (Result Response_String)
sendMain s
conn Request_String
rqst IO ()
onSendComplete =do--let str = if null (rqBody rqst)-- then show rqst-- else show (insertHeader HdrExpect "100-continue" rqst)-- TODO review throwing away of resultResult ()
_<-s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Show a => a -> String
showRequest_String
rqst )-- write body immediately, don't wait for 100 CONTINUE-- TODO review throwing away of resultResult ()
_<-s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Request a -> a
rqBody Request_String
rqst )IO ()
onSendComplete Result ResponseData
rsp <-s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
TrueBool
FalseResult ResponseData
rsp Request_String
rqst -- reads and parses headersgetResponseHead ::Stream s =>s ->IO(Result ResponseData )getResponseHead :: s -> IO (Result ResponseData)
getResponseHead s
conn =doResult [String]
lor <-BufferOp String -> IO (Result String) -> IO (Result [String])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp String
stringBufferOp (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn )Result ResponseData -> IO (Result ResponseData)
forall (m :: * -> *) a. Monad m => a -> m a
return(Result ResponseData -> IO (Result ResponseData))
-> Result ResponseData -> IO (Result ResponseData)
forall a b. (a -> b) -> a -> b
$Result [String]
lor Result [String]
-> ([String] -> Result ResponseData) -> Result ResponseData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=[String] -> Result ResponseData
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 :: s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
_Bool
_Bool
_(LeftConnError
e )Request_String
_=Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(ConnError -> Result Response_String
forall a b. a -> Either a b
LeftConnError
e )-- 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.switchResponse s
conn Bool
allow_retry Bool
bdy_sent (Right(ResponseCode
cd ,String
rn ,[Header]
hdrs ))Request_String
rqst =caseRequestMethod -> ResponseCode -> ResponseNextStep
matchResponse (Request_String -> RequestMethod
forall a. Request a -> RequestMethod
rqMethod Request_String
rqst )ResponseCode
cd ofResponseNextStep
Continue |Bool -> Bool
notBool
bdy_sent ->{- Time to send the body -}do{Result ()
val <-s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Request a -> a
rqBody Request_String
rqst );caseResult ()
val ofLeftConnError
e ->Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(ConnError -> Result Response_String
forall a b. a -> Either a b
LeftConnError
e )Right()
_->do{Result ResponseData
rsp <-s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn ;s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
allow_retry Bool
TrueResult ResponseData
rsp Request_String
rqst }}|Bool
otherwise->{- keep waiting -}do{Result ResponseData
rsp <-s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn ;s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
allow_retry Bool
bdy_sent Result ResponseData
rsp Request_String
rqst }ResponseNextStep
Retry ->{- Request with "Expect" header failed.
 Trouble is the request contains Expects
 other than "100-Continue" -}do{-- TODO review throwing away of resultResult ()
_<-s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Show a => a -> String
showRequest_String
rqst String -> String -> String
forall a. [a] -> [a] -> [a]
++Request_String -> String
forall a. Request a -> a
rqBody Request_String
rqst );Result ResponseData
rsp <-s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn ;s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
FalseBool
bdy_sent Result ResponseData
rsp Request_String
rqst }ResponseNextStep
Done ->doBool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when([Header] -> Bool
findConnClose [Header]
hdrs )(s -> Bool -> IO ()
forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(Response_String -> Result Response_String
forall a b. b -> Either a b
Right(Response_String -> Result Response_String)
-> Response_String -> Result Response_String
forall a b. (a -> b) -> a -> b
$ResponseCode -> String -> [Header] -> String -> Response_String
forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn [Header]
hdrs String
"")DieHorribly String
str ->dos -> IO ()
forall x. Stream x => x -> IO ()
close s
conn Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(Result Response_String -> IO (Result Response_String))
-> Result Response_String -> IO (Result Response_String)
forall a b. (a -> b) -> a -> b
$String -> String -> Result Response_String
forall a. String -> String -> Result a
responseParseError String
"sendHTTP"(String
"Invalid response: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
str )ResponseNextStep
ExpectEntity ->lettc :: Maybe String
tc =HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrTransferEncoding [Header]
hdrs cl :: Maybe String
cl =HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentLength [Header]
hdrs indo{Result ([Header], String)
rslt <-caseMaybe String
tc ofMaybe String
Nothing->caseMaybe String
cl ofJustString
x ->(Int -> IO (Result String))
-> Int -> IO (Result ([Header], String))
forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn )(String -> Int
forall a. Read a => String -> a
readString
x ::Int)Maybe String
Nothing->BufferOp String
-> IO (Result String) -> [String] -> IO (Result ([Header], String))
forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp String
stringBufferOp {-null (++) []-}(s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn )[]JustString
x ->case(Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLower(String -> String
trim String
x )ofString
"chunked"->BufferOp String
-> IO (Result String)
-> (Int -> IO (Result String))
-> IO (Result ([Header], String))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp String
stringBufferOp (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn )(s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn )String
_->String -> IO (Result ([Header], String))
forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"sendHTTP";caseResult ([Header], String)
rslt ofLeftConnError
e ->s -> IO ()
forall x. Stream x => x -> IO ()
close s
conn IO () -> IO (Result Response_String) -> IO (Result Response_String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(ConnError -> Result Response_String
forall a b. a -> Either a b
LeftConnError
e )Right([Header]
ftrs ,String
bdy )->doBool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when([Header] -> Bool
findConnClose ([Header]
hdrs [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs ))(s -> Bool -> IO ()
forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(Response_String -> Result Response_String
forall a b. b -> Either a b
Right(ResponseCode -> String -> [Header] -> String -> Response_String
forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn ([Header]
hdrs [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs )String
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 :: s -> IO (Result Request_String)
receiveHTTP s
conn =IO (Result RequestData)
getRequestHead IO (Result RequestData)
-> (Result RequestData -> IO (Result Request_String))
-> IO (Result Request_String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=Result RequestData -> IO (Result Request_String)
processRequest where-- reads and parses headersgetRequestHead ::IO(Result RequestData )getRequestHead :: IO (Result RequestData)
getRequestHead =do{Result [String]
lor <-BufferOp String -> IO (Result String) -> IO (Result [String])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp String
stringBufferOp (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn );Result RequestData -> IO (Result RequestData)
forall (m :: * -> *) a. Monad m => a -> m a
return(Result RequestData -> IO (Result RequestData))
-> Result RequestData -> IO (Result RequestData)
forall a b. (a -> b) -> a -> b
$Result [String]
lor Result [String]
-> ([String] -> Result RequestData) -> Result RequestData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=[String] -> Result RequestData
parseRequestHead }processRequest :: Result RequestData -> IO (Result Request_String)
processRequest (LeftConnError
e )=Result Request_String -> IO (Result Request_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(Result Request_String -> IO (Result Request_String))
-> Result Request_String -> IO (Result Request_String)
forall a b. (a -> b) -> a -> b
$ConnError -> Result Request_String
forall a b. a -> Either a b
LeftConnError
e processRequest (Right(RequestMethod
rm ,URI
uri ,[Header]
hdrs ))=do-- FIXME : Also handle 100-continue.lettc :: Maybe String
tc =HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrTransferEncoding [Header]
hdrs cl :: Maybe String
cl =HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentLength [Header]
hdrs Result ([Header], String)
rslt <-caseMaybe String
tc ofMaybe String
Nothing->caseMaybe String
cl ofJustString
x ->(Int -> IO (Result String))
-> Int -> IO (Result ([Header], String))
forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn )(String -> Int
forall a. Read a => String -> a
readString
x ::Int)Maybe String
Nothing->Result ([Header], String) -> IO (Result ([Header], String))
forall (m :: * -> *) a. Monad m => a -> m a
return(([Header], String) -> Result ([Header], String)
forall a b. b -> Either a b
Right([],String
""))-- hopefulTransfer ""JustString
x ->case(Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLower(String -> String
trim String
x )ofString
"chunked"->BufferOp String
-> IO (Result String)
-> (Int -> IO (Result String))
-> IO (Result ([Header], String))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp String
stringBufferOp (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn )(s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn )String
_->String -> IO (Result ([Header], String))
forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"receiveHTTP"Result Request_String -> IO (Result Request_String)
forall (m :: * -> *) a. Monad m => a -> m a
return(Result Request_String -> IO (Result Request_String))
-> Result Request_String -> IO (Result Request_String)
forall a b. (a -> b) -> a -> b
$do([Header]
ftrs ,String
bdy )<-Result ([Header], String)
rslt Request_String -> Result Request_String
forall (m :: * -> *) a. Monad m => a -> m a
return(URI -> RequestMethod -> [Header] -> String -> Request_String
forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request URI
uri RequestMethod
rm ([Header]
hdrs [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs )String
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 :: s -> Response_String -> IO ()
respondHTTP s
conn Response_String
rsp =do-- TODO review throwing away of resultResult ()
_<-s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Response_String -> String
forall a. Show a => a -> String
showResponse_String
rsp )-- write body immediately, don't wait for 100 CONTINUE-- TODO review throwing away of resultResult ()
_<-s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Response_String -> String
forall a. Response a -> a
rspBody Response_String
rsp )() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return()