----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Stream -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- 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. -- ----------------------------------------------------------------------------- module Network.HTTP.Stream ( module Network.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 -------------------------------------- ----------------------------------------------------------------- import Network.Stream import Network.StreamDebugger (debugStream) import Network.TCP (openTCPPort) import Network.BufferType ( stringBufferOp ) import Network.HTTP.Base import Network.HTTP.Headers import Network.HTTP.Utils ( trim ) import Data.Char (toLower) import Data.Maybe (fromMaybe) import Control.Exception (onException) import Control.Monad (when) -- Turn on to enable HTTP traffic logging debug :: Bool debug = False -- File that HTTP traffic logs go to httpLogFile :: String httpLogFile = "http-debug.log" ----------------------------------------------------------------- ------------------ Misc ----------------------------------------- ----------------------------------------------------------------- -- | Simple way to transmit a resource across a non-persistent connection. simpleHTTP :: Request_String -> IO (Result Response_String) simpleHTTP r = do auth <- getAuth r c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) 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 | not debug = sendHTTP s r | otherwise = do s' <- 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 = do when providedClose $ (closeOnEnd conn True) onException (sendMain conn rq onSendComplete) (close conn) where providedClose = findConnClose (rqHeaders 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 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 (show rqst) -- write body immediately, don't wait for 100 CONTINUE -- TODO review throwing away of result _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst -- reads and parses headers getResponseHead :: Stream s => s -> IO (Result ResponseData) getResponseHead conn = do lor <- 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 _ _ _ (Left e) _ = return (Left 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 conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> {- Time to send the body -} do { val <- writeBlock conn (rqBody rqst) ; case val of Left e -> return (Left e) Right _ -> do { rsp <- getResponseHead conn ; switchResponse conn allow_retry True rsp 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 (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst } Done -> do when (findConnClose hdrs) (closeOnEnd conn True) return (Right $ Response cd rn hdrs "") DieHorribly str -> do close conn return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity -> let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs in do { rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "sendHTTP" ; case rslt of Left e -> close conn >> return (Left e) Right (ftrs,bdy) -> do when (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 headers getRequestHead :: IO (Result RequestData) getRequestHead = do { lor <- readTillEmpty1 stringBufferOp (readLine conn) ; return $ lor >>= parseRequestHead } processRequest (Left e) = return $ Left e processRequest (Right (rm,uri,hdrs)) = do -- FIXME : Also handle 100-continue. let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) Nothing -> return (Right ([], "")) -- hopefulTransfer "" Just x -> case map toLower (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 (show rsp) -- write body immediately, don't wait for 100 CONTINUE -- TODO review throwing away of result _ <- writeBlock conn (rspBody rsp) return ()