----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.HandleStream -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne -- License : BSD -- -- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- -- A HandleStream version of Network.HTTP.Stream's public offerings. -- ----------------------------------------------------------------------------- module Network.HTTP.HandleStream ( simpleHTTP -- :: HTTPRequest ty -> IO (Result (HTTPResponse ty)) , simpleHTTP_ -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) , sendHTTP -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTResponse ty)) , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (HTTPRequest ty)) , respondHTTP -- :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO () , simpleHTTP_debug -- :: FilePath -> HTTPRequest DebugString -> IO (HTTPResponse DebugString) ) where ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- import Network.BufferType import Network.Stream ( ConnError(..), bindE, Result ) import Network.StreamDebugger ( debugByteStream ) import Network.TCP (HStream(..), HandleStream ) import Network.HTTP.Base import Network.HTTP.Headers import Network.HTTP.Utils ( trim ) import Data.Char (toLower) import Data.Maybe (fromMaybe) import Control.Monad (when) ----------------------------------------------------------------- ------------------ Misc ----------------------------------------- ----------------------------------------------------------------- -- | 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 :: HStream ty => HTTPRequest ty -> IO (Result (HTTPResponse ty)) simpleHTTP r = do auth <- getAuth r c <- openStream (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r simpleHTTP_debug :: HStream ty => FilePath -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) simpleHTTP_debug httpLogFile r = do auth <- getAuth r c0 <- openStream (host auth) (fromMaybe 80 (port auth)) c <- debugByteStream httpLogFile c0 simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) simpleHTTP_ s r = do auth <- getAuth r let r' = normalizeRequestURI auth r rsp <- sendHTTP s r' return rsp sendHTTP :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) sendHTTP conn rq = do let a_rq = normalizeHostHeader rq rsp <- catchIO (sendMain conn a_rq) (\e -> do { close conn; ioError e }) let fn list = when (or $ map findConnClose list) (close conn) either (\_ -> fn [rqHeaders rq]) (\r -> fn [rqHeaders rq,rspHeaders r]) rsp return rsp -- 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 :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) sendMain conn rqst = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst) writeBlock conn (buf_fromStr bufferOps $ show rqst) -- write body immediately, don't wait for 100 CONTINUE writeBlock conn (rqBody rqst) rsp <- getResponseHead conn switchResponse conn True False rsp rqst -- Hmmm, this could go bad if we keep getting "100 Continue" -- responses... Except this should never happen according -- to the RFC. switchResponse :: HStream ty => HandleStream ty -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) 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 -> do {- Time to send the body -} writeBlock conn (rqBody rqst) >>= either (return . Left) (\ _ -> do rsp <- getResponseHead conn switchResponse conn allow_retry True rsp rqst) | otherwise -> do {- keep waiting -} rsp <- getResponseHead conn switchResponse conn allow_retry bdy_sent rsp rqst Retry -> do {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -} writeBlock conn ((buf_append bufferOps) (buf_fromStr bufferOps (show rqst)) (rqBody rqst)) rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst Done -> return (Right $ Response cd rn hdrs (buf_empty bufferOps)) DieHorribly str -> return $ Left $ ErrorParse ("Invalid response: " ++ str) ExpectEntity -> do rslt <- case tc of Nothing -> case cl of Nothing -> hopefulTransfer bo (readLine conn) [] Just x -> case reads x of ((v,_):_) -> linearTransfer (readBlock conn) v _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x))) Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn) _ -> uglyDeathTransfer return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) where tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs bo = bufferOps -- reads and parses headers getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData) getResponseHead conn = do lor <- readTillEmpty1 bufferOps (readLine conn) return $ lor `bindE` \es -> parseResponseHead (map (buf_toStr bufferOps) es) -- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions. receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (HTTPRequest bufTy)) receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest where -- reads and parses headers getRequestHead :: IO (Result RequestData) getRequestHead = do { lor <- readTillEmpty1 bufferOps (readLine conn) ; return $ lor `bindE` \es -> parseRequestHead (map (buf_toStr bufferOps) es) } processRequest (rm,uri,hdrs) = do rslt <- case tc of Nothing -> case cl of Nothing -> return (Right ([], buf_empty bo)) -- hopefulTransfer "" Just x -> case reads x of ((v,_):_) -> linearTransfer (readBlock conn) v _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x))) Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn) _ -> uglyDeathTransfer return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy) where -- FIXME : Also handle 100-continue. tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs bo = bufferOps -- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO () respondHTTP conn rsp = do writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE writeBlock conn (rspBody rsp) return ()