-
Notifications
You must be signed in to change notification settings - Fork 50
/
Ghttp.chs
326 lines (282 loc) · 9.77 KB
/
Ghttp.chs
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
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
-- GhttpHS: Haskell binding to the Gnome HTTP library -*-haskell-*-
--
-- Author : Manuel M. T. Chakravarty
-- Created: 5 August 99
--
-- Copyright (c) [1999..2000] Manuel M. T. Chakravarty
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Library General Public
-- License as published by the Free Software Foundation; either
-- version 2 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Library General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
-- The C library `libghttp' provides a set of common http functions needed at
-- the client and the server end of an http connection. The Haskell binding
-- is generated with the help of the C->Haskell tool - always modify the
-- original .chs file, _not_ the generated .hs file.
--
-- This library is fully compliant with HTTP 1.1 as defined in the draft 5
-- update of RFC 2068.
--
--- DOCU ----------------------------------------------------------------------
--
-- language: Haskell 98 & C->HS binding hooks (v0.7.5)
--
-- ** Stylistic warning: In the definition of `CurrentStatus', the field
-- labels do not contain the name of the data type to which they belong.
-- This is _not_ good practice in larger interfaces, because in Haskell
-- such field labels pollute the global name space.
--
--- TODO ----------------------------------------------------------------------
--
-- * When and by whom is the memory area passed to `ghttp_set_body' be freed;
-- how about the string returned from `ghttp_get_body'?
--
-- * Conversion of `time_t' misses for `parseDate'.
--
module Ghttp (Request, URI, Type(..), SyncMode(..), Status(..), Proc(..),
CurrentStatus(..),
requestNew, requestDestroy, uriValidate, setURI, setProxy,
setType, setBody, setSync, prepare, setChunksize, setHeader,
process, getStatus, getHeader, close, clean, getSocket, getBody,
getError, {-parseDate,-} setAuthinfo, setProxyAuthinfo)
where
-- C->HS marshalling library
--
import C2HS
import Monad (liftM, when)
import IOExts (unsafePerformIO)
{#context lib="libghttp" prefix="ghttp"#}
-- data structures
-- ---------------
-- abstract handle for a http request object (EXPORTED ABSTRACTLY)
--
newtype Request = Request Addr
-- Uniform Resource Indicators (EXPORTED)
--
type URI = String
-- body type (EXPORTED)
--
{#enum ghttp_type as Type {underscoreToCase}#}
-- synchronous/asynchronous mode (EXPORTED)
--
{#enum sync_mode as SyncMode {underscoreToCase}#}
-- request status (EXPORTED)
--
{#enum status as Status {underscoreToCase}#}
-- describes the activity of a request (EXPORTED)
--
{#enum proc as Proc {underscoreToCase}#}
-- status descriptor (EXPORTED)
--
data CurrentStatus = CurrentStatus {
proc :: Proc, -- What's it doing?
bytesRead :: Int, -- How many bytes have been read?
bytesTotal :: Int -- How many bytes total?
}
-- error types
--
invalidURI, illegalRequest :: String
invalidURI = "Ghttp: The Uniform Resource Indicator is invalid."
illegalRequest = "Ghttp: The request is illegal or unsupported."
-- functions
-- ---------
-- create a new request object (EXPORTED)
--
requestNew :: IO Request
requestNew = liftM Request {#call unsafe request_new#}
-- delete a current request object (EXPORTED)
--
requestDestroy :: Request -> IO ()
requestDestroy (Request reqa) = {#call unsafe request_destroy#} reqa
-- validate a uri (EXPORTED)
--
uriValidate :: URI -> Bool
uriValidate uri =
let res = unsafePerformIO $
{#call unsafe uri_validate#} `marsh1_` (stdAddr uri :> free)
in
res == -1
-- set a uri in a request (EXPORTED)
--
-- * raise an exception if the URI is not valid
--
setURI :: Request -> URI -> IO ()
setURI (Request reqa) uri =
{#call unsafe set_uri#} reqa `marsh1_` (stdAddr uri :> free)
`ifNegRaise_` invalidURI
-- set a proxy for a request (EXPORTED)
--
-- * raise an exception if the request is not valid
--
setProxy :: Request -> URI -> IO ()
setProxy (Request reqa) uri =
{#call unsafe set_proxy#} reqa `marsh1_` (stdAddr uri :> free)
`ifNegRaise_` illegalRequest
-- set a request type (EXPORTED)
--
-- * raise an exception if the request is not valid
--
setType :: Request -> Type -> IO ()
setType (Request reqa) rtype =
{#call unsafe set_type#} reqa (cFromEnum rtype)
`ifNegRaise_` illegalRequest
-- set the body (EXPORTED)
--
-- * raise an exception if the request is not valid
--
setBody :: Request -> String -> IO ()
setBody (Request reqa) body =
do
(box, len) <- listToAddrWithLen body
{#call unsafe set_body#} reqa box (cFromInt len)
`ifNegRaise_` illegalRequest
-- set whether or not you want to use sync or async mode (EXPORTED)
--
-- * raise an exception if the request is not valid
--
setSync :: Request -> SyncMode -> IO ()
setSync (Request reqa) smode =
{#call unsafe set_sync#} reqa (cFromEnum smode)
`ifNegRaise_` illegalRequest
-- Prepare a request; call this before trying to process a request or if you
-- change the uri (EXPORTED)
--
-- * raise an exception if the request is not valid
--
prepare :: Request -> IO ()
prepare (Request reqa) =
{#call unsafe prepare#} reqa
`ifNegRaise_` illegalRequest
-- set the chunk size; you might want to do this to optimize for different
-- connection speeds (EXPORTED)
--
setChunksize :: Request -> Int -> IO ()
setChunksize (Request reqa) size =
{#call unsafe set_chunksize#} reqa (cFromInt size)
-- set a random request header (EXPORTED)
--
setHeader :: Request -> String -> String -> IO ()
setHeader (Request reqa) hdr val =
{#call unsafe set_header#} reqa
`marsh2_` (stdAddr hdr :> free)
$ (stdAddr val :> free)
-- process a request (EXPORTED)
--
process :: Request -> IO Status
process (Request reqa) = liftM cToEnum $ {#call unsafe process#} reqa
-- get the status of a request (EXPORTED)
--
getStatus :: Request -> IO CurrentStatus
getStatus (Request reqa) =
{#call unsafe ghttpHS_get_status #} reqa >>= cFromCurrentStatus
-- get the value of a random response header (EXPORTED)
--
getHeader :: Request -> String -> IO String
getHeader (Request reqa) hdr =
{#call unsafe get_header#} reqa `marsh1_` (stdAddr hdr :> free)
>>= addrStd
-- abort a currently running request (EXPORTED)
--
-- * raise an exception if the request is not valid
--
close :: Request -> IO ()
close (Request reqa) = {#call unsafe close#} reqa
`ifNegRaise_` illegalRequest
-- clean a request (EXPORTED)
--
clean :: Request -> IO ()
clean (Request reqa) = {#call unsafe clean#} reqa
-- get the socket associated with a particular connection (EXPORTED)
--
-- * raise an exception if the request is not valid
--
getSocket :: Request -> IO Int
getSocket (Request reqa) = {#call unsafe get_socket#} reqa
`ifNegRaise` illegalRequest
-- get the return entity body (EXPORTED)
--
-- * this includes getting the length with `ghttp_get_body_len', as the string
-- is not necessarily \0 terminated
--
getBody :: Request -> IO String
getBody (Request reqa) =
do
bodyAddr <- {#call unsafe get_body#} reqa
`ifNullRaise` illegalRequest
bodyLen <- {#call unsafe get_body_len#} reqa
addrWithLenToList bodyAddr (cToInt bodyLen)
-- get an error message for a request that has failed (EXPORTED)
--
getError :: Request -> IO String
getError (Request reqa) =
{#call unsafe get_error#} reqa >>= addrStd
-- parse a date string that is one of the standard date formats (EXPORTED)
--
{-parseDate :: String -> CalendarTime
parseDate str =
do
time_t <- {#call unsafe parse_date#} `fromString` str
time <- toCalendarTime
-}
-- return the status code (EXPORTED)
--
statusCode :: Request -> IO Int
statusCode (Request reqa) =
liftM cToInt $ {#call unsafe status_code#} reqa
-- return the reason phrase (EXPORTED)
--
-- * raise an exception if the request is not valid
--
reasonPhrase :: Request -> IO String
reasonPhrase (Request reqa) =
({#call unsafe reason_phrase#} reqa
`ifNullRaise` illegalRequest
) >>= addrStd
-- set your username/password pair (EXPORTED)
--
-- * raise an exception if the request is not valid
--
setAuthinfo :: Request -> String -> String -> IO ()
setAuthinfo (Request reqa) user pass =
({#call unsafe set_authinfo#} reqa
`marsh2_` (stdAddr user :> free)
$ (stdAddr pass :> free)
)
`ifNegRaise_` illegalRequest
-- set your username/password pair for proxy (EXPORTED)
--
-- * raise an exception if the request is not valid
--
setProxyAuthinfo :: Request -> String -> String -> IO ()
setProxyAuthinfo (Request reqa) user pass =
({#call unsafe set_proxy_authinfo#} reqa
`marsh2_` (stdAddr user :> free)
$ (stdAddr pass :> free)
)
`ifNegRaise_` illegalRequest
-- auxiliary marshalling function
-- -------------------------------
-- marshal the elements of a `ghttp_current_status' struct to Haskell land
--
-- * frees the C struct
--
cFromCurrentStatus :: Addr -> IO CurrentStatus
cFromCurrentStatus csPtr =
do
proc <- liftM cToEnum$ {#get current_status.proc#} csPtr
read <- liftM cToInt $ {#get current_status.bytes_read#} csPtr
total<- liftM cToInt $ {#get current_status.bytes_total#} csPtr
free csPtr
return $ CurrentStatus {
proc = proc,
bytesRead = read,
bytesTotal = total
}