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