1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
-----------------------------------------------------------------------------
-- |
-- 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.
--
-----------------------------------------------------------------------------
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 ()
|
