1----------------------------------------------------------------------------- 2-- | 3-- Module : Network.HTTP.Stream 4-- Copyright : See LICENSE file 5-- License : BSD 6-- 7-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> 8-- Stability : experimental 9-- Portability : non-portable (not tested) 10-- 11-- Transmitting HTTP requests and responses holding @String@ in their payload bodies. 12-- This is one of the implementation modules for the "Network.HTTP" interface, representing 13-- request and response content as @String@s and transmitting them in non-packed form 14-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. 15-- It is mostly here for backwards compatibility, representing how requests and responses 16-- were transmitted up until the 4.x releases of the HTTP package. 17-- 18-- For more detailed information about what the individual exports do, please consult 19-- the documentation for "Network.HTTP". /Notice/ however that the functions here do 20-- not perform any kind of normalization prior to transmission (or receipt); you are 21-- responsible for doing any such yourself, or, if you prefer, just switch to using 22-- "Network.HTTP" function instead. 23-- 24----------------------------------------------------------------------------- 25module Network.HTTP.Stream 26 ( module Network.Stream 27 28 , simpleHTTP -- :: Request_String -> IO (Result Response_String) 29 , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) 30 , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) 31 , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) 32 , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) 33 , respondHTTP -- :: Stream s => s -> Response_String -> IO () 34 35 ) where 36 37----------------------------------------------------------------- 38------------------ Imports -------------------------------------- 39----------------------------------------------------------------- 40 41import Network.Stream 42import Network.StreamDebugger (debugStream) 43import Network.TCP (openTCPPort) 44import Network.BufferType ( stringBufferOp ) 45 46import Network.HTTP.Base 47import Network.HTTP.Headers 48import Network.HTTP.Utils ( trim ) 49 50import Data.Char (toLower) 51import Data.Maybe (fromMaybe) 52import Control.Exception (onException) 53import Control.Monad (when) 54 55 56-- Turn on to enable HTTP traffic logging 57debug :: Bool 58debug = False 59 60-- File that HTTP traffic logs go to 61httpLogFile :: String 62httpLogFile = "http-debug.log" 63 64----------------------------------------------------------------- 65------------------ Misc ----------------------------------------- 66----------------------------------------------------------------- 67 68 69-- | Simple way to transmit a resource across a non-persistent connection. 70simpleHTTP :: Request_String -> IO (Result Response_String) 71simpleHTTP r = do 72 auth <- getAuth r 73 c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) 74 simpleHTTP_ c r 75 76-- | Like 'simpleHTTP', but acting on an already opened stream. 77simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) 78simpleHTTP_ s r 79 | not debug = sendHTTP s r 80 | otherwise = do 81 s' <- debugStream httpLogFile s 82 sendHTTP s' r 83 84sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) 85sendHTTP conn rq = sendHTTP_notify conn rq (return ()) 86 87sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) 88sendHTTP_notify conn rq onSendComplete = do 89 when providedClose $ (closeOnEnd conn True) 90 onException (sendMain conn rq onSendComplete) 91 (close conn) 92 where 93 providedClose = findConnClose (rqHeaders rq) 94 95-- From RFC 2616, section 8.2.3: 96-- 'Because of the presence of older implementations, the protocol allows 97-- ambiguous situations in which a client may send "Expect: 100- 98-- continue" without receiving either a 417 (Expectation Failed) status 99-- or a 100 (Continue) status. Therefore, when a client sends this 100-- header field to an origin server (possibly via a proxy) from which it 101-- has never seen a 100 (Continue) status, the client SHOULD NOT wait 102-- for an indefinite period before sending the request body.' 103-- 104-- Since we would wait forever, I have disabled use of 100-continue for now. 105sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) 106sendMain conn rqst onSendComplete = do 107 --let str = if null (rqBody rqst) 108 -- then show rqst 109 -- else show (insertHeader HdrExpect "100-continue" rqst) 110 -- TODO review throwing away of result 111 _ <- writeBlock conn (show rqst) 112 -- write body immediately, don't wait for 100 CONTINUE 113 -- TODO review throwing away of result 114 _ <- writeBlock conn (rqBody rqst) 115 onSendComplete 116 rsp <- getResponseHead conn 117 switchResponse conn True False rsp rqst 118 119-- reads and parses headers 120getResponseHead :: Stream s => s -> IO (Result ResponseData) 121getResponseHead conn = do 122 lor <- readTillEmpty1 stringBufferOp (readLine conn) 123 return $ lor >>= parseResponseHead 124 125-- Hmmm, this could go bad if we keep getting "100 Continue" 126-- responses... Except this should never happen according 127-- to the RFC. 128switchResponse :: Stream s 129 => s 130 -> Bool {- allow retry? -} 131 -> Bool {- is body sent? -} 132 -> Result ResponseData 133 -> Request_String 134 -> IO (Result Response_String) 135switchResponse _ _ _ (Left e) _ = return (Left e) 136 -- retry on connreset? 137 -- if we attempt to use the same socket then there is an excellent 138 -- chance that the socket is not in a completely closed state. 139switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = 140 case matchResponse (rqMethod rqst) cd of 141 Continue 142 | not bdy_sent -> {- Time to send the body -} 143 do { val <- writeBlock conn (rqBody rqst) 144 ; case val of 145 Left e -> return (Left e) 146 Right _ -> 147 do { rsp <- getResponseHead conn 148 ; switchResponse conn allow_retry True rsp rqst 149 } 150 } 151 | otherwise -> {- keep waiting -} 152 do { rsp <- getResponseHead conn 153 ; switchResponse conn allow_retry bdy_sent rsp rqst 154 } 155 156 Retry -> {- Request with "Expect" header failed. 157 Trouble is the request contains Expects 158 other than "100-Continue" -} 159 do { -- TODO review throwing away of result 160 _ <- writeBlock conn (show rqst ++ rqBody rqst) 161 ; rsp <- getResponseHead conn 162 ; switchResponse conn False bdy_sent rsp rqst 163 } 164 165 Done -> do 166 when (findConnClose hdrs) 167 (closeOnEnd conn True) 168 return (Right $ Response cd rn hdrs "") 169 170 DieHorribly str -> do 171 close conn 172 return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) 173 174 ExpectEntity -> 175 let tc = lookupHeader HdrTransferEncoding hdrs 176 cl = lookupHeader HdrContentLength hdrs 177 in 178 do { rslt <- case tc of 179 Nothing -> 180 case cl of 181 Just x -> linearTransfer (readBlock conn) (read x :: Int) 182 Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] 183 Just x -> 184 case map toLower (trim x) of 185 "chunked" -> chunkedTransfer stringBufferOp 186 (readLine conn) (readBlock conn) 187 _ -> uglyDeathTransfer "sendHTTP" 188 ; case rslt of 189 Left e -> close conn >> return (Left e) 190 Right (ftrs,bdy) -> do 191 when (findConnClose (hdrs++ftrs)) 192 (closeOnEnd conn True) 193 return (Right (Response cd rn (hdrs++ftrs) bdy)) 194 } 195 196-- | Receive and parse a HTTP request from the given Stream. Should be used 197-- for server side interactions. 198receiveHTTP :: Stream s => s -> IO (Result Request_String) 199receiveHTTP conn = getRequestHead >>= processRequest 200 where 201 -- reads and parses headers 202 getRequestHead :: IO (Result RequestData) 203 getRequestHead = 204 do { lor <- readTillEmpty1 stringBufferOp (readLine conn) 205 ; return $ lor >>= parseRequestHead 206 } 207 208 processRequest (Left e) = return $ Left e 209 processRequest (Right (rm,uri,hdrs)) = 210 do -- FIXME : Also handle 100-continue. 211 let tc = lookupHeader HdrTransferEncoding hdrs 212 cl = lookupHeader HdrContentLength hdrs 213 rslt <- case tc of 214 Nothing -> 215 case cl of 216 Just x -> linearTransfer (readBlock conn) (read x :: Int) 217 Nothing -> return (Right ([], "")) -- hopefulTransfer "" 218 Just x -> 219 case map toLower (trim x) of 220 "chunked" -> chunkedTransfer stringBufferOp 221 (readLine conn) (readBlock conn) 222 _ -> uglyDeathTransfer "receiveHTTP" 223 224 return $ do 225 (ftrs,bdy) <- rslt 226 return (Request uri rm (hdrs++ftrs) bdy) 227 228-- | Very simple function, send a HTTP response over the given stream. This 229-- could be improved on to use different transfer types. 230respondHTTP :: Stream s => s -> Response_String -> IO () 231respondHTTP conn rsp = do -- TODO review throwing away of result 232 _ <- writeBlock conn (show rsp) 233 -- write body immediately, don't wait for 100 CONTINUE 234 -- TODO review throwing away of result 235 _ <- writeBlock conn (rspBody rsp) 236 return () 237