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
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
-----------------------------------------------------------------------------
-- |
-- Module : Network.HTTP.HandleStream
-- Copyright : See LICENSE file
-- License : BSD
--
-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>
-- Stability : experimental
-- Portability : non-portable (not tested)
--
-- A 'HandleStream'-based version of "Network.HTTP" interface.
--
-- 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.HandleStream
( simpleHTTP -- :: Request ty -> IO (Result (Response ty))
, simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
, sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
, sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
, receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty))
, respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO ()
, simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString)
) where
-----------------------------------------------------------------
------------------ Imports --------------------------------------
-----------------------------------------------------------------
import Network.BufferType
import Network.Stream ( fmapE, Result )
import Network.StreamDebugger ( debugByteStream )
import Network.TCP (HStream(..), HandleStream )
import Network.HTTP.Base
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim, readsOne )
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Control.Exception (onException)
import Control.Monad (when)
-----------------------------------------------------------------
------------------ Misc -----------------------------------------
-----------------------------------------------------------------
-- | @simpleHTTP@ transmits a resource across a non-persistent connection.
simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP r = do
auth <- getAuth r
failHTTPS (rqURI r)
c <- openStream (host auth) (fromMaybe 80 (port auth))
simpleHTTP_ c r
-- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs
-- the HTTP operation via the debug file @debugFile@.
simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty))
simpleHTTP_debug httpLogFile r = do
auth <- getAuth r
failHTTPS (rqURI 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 -> Request ty -> IO (Result (Response ty))
simpleHTTP_ s r = sendHTTP s r
-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over
-- @hStream@, but does not alter the status of the connection, nor request it to be
-- closed upon receiving the response.
sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
sendHTTP conn rq = sendHTTP_notify conn rq (return ())
-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but
-- lets you supply an IO @action@ to execute once the request has been successfully
-- transmitted over the connection. Useful when you want to set up tracing of
-- request transmission and its performance.
sendHTTP_notify :: HStream ty
=> HandleStream ty
-> Request ty
-> IO ()
-> IO (Result (Response ty))
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 :: HStream ty
=> HandleStream ty
-> Request ty
-> (IO ())
-> IO (Result (Response ty))
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 (buf_fromStr bufferOps $ 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
-- 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
-> Request ty
-> IO (Result (Response 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" -}
-- TODO review throwing away of result
_ <- writeBlock conn ((buf_append bufferOps)
(buf_fromStr bufferOps (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 (buf_empty bufferOps))
DieHorribly str -> do
close conn
return (responseParseError "Invalid response:" str)
ExpectEntity -> do
r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $
maybe (maybe (hopefulTransfer bo (readLine conn) [])
(\ x ->
readsOne (linearTransfer (readBlock conn))
(return$responseParseError "unrecognized content-length value" x)
x)
cl)
(ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))
(uglyDeathTransfer "sendHTTP"))
tc
case r of
Left{} -> do
close conn
return r
Right (Response _ _ hs _) -> do
when (findConnClose hs)
(closeOnEnd conn True)
return r
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 =
fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es))
(readTillEmpty1 bufferOps (readLine conn))
-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@
receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy))
receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest
where
-- reads and parses headers
getRequestHead :: IO (Result RequestData)
getRequestHead = do
fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es))
(readTillEmpty1 bufferOps (readLine conn))
processRequest (rm,uri,hdrs) =
fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $
maybe
(maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""
(\ x -> readsOne (linearTransfer (readBlock conn))
(return$responseParseError "unrecognized Content-Length value" x)
x)
cl)
(ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))
(uglyDeathTransfer "receiveHTTP"))
tc
where
-- FIXME : Also handle 100-continue.
tc = lookupHeader HdrTransferEncoding hdrs
cl = lookupHeader HdrContentLength hdrs
bo = bufferOps
-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over
-- the 'HandleStream' @hStream@. It could be used to implement simple web
-- server interactions, performing the dual role to 'sendHTTP'.
respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO ()
respondHTTP conn rsp = do
-- TODO: review throwing away of result
_ <- writeBlock conn (buf_fromStr bufferOps $ show rsp)
-- write body immediately, don't wait for 100 CONTINUE
-- TODO: review throwing away of result
_ <- writeBlock conn (rspBody rsp)
return ()
------------------------------------------------------------------------------
headerName :: String -> String
headerName x = map toLower (trim x)
ifChunked :: a -> a -> String -> a
ifChunked a b s =
case headerName s of
"chunked" -> a
_ -> b
|
