source: project/release/4/http-client/trunk/tests/run.scm @ 33917

Last change on this file since 33917 was 33917, checked in by sjamaan, 3 years ago

http-client: Fix handling of custom writer procedure: use chunked encoding

File size: 17.1 KB
Line 
1;; This can be dropped later
2(use setup-api)
3(when (version>=? (chicken-version) "4.6.0")
4  (register-feature! 'has-port-closed))
5
6(use extras)
7
8(include "../http-client.scm")
9(import http-client)
10
11(include "testlib.scm")
12
13(test-begin "http-client")
14
15;; TODO: This is messy and hard to read
16(test-group "simple GET requests"
17  (test-group "an empty response"
18    (let* ((log (with-server-response
19                 (lambda ()
20                   (test "Response is the empty string"
21                         ""
22                         (with-input-from-request
23                          "http://example.com/some/path#more"
24                          #f read-string)))
25                 "HTTP/1.0 200 OK\r\nContent-Length: 0\r\n"))
26           (req (log-request log)))
27
28      (test "Request method" 'GET (request-method req))
29      (test "URI is path without fragment"
30            "/some/path" (uri->string (request-uri req)))
31      (test "host header gets set"
32            '("example.com" . #f)
33            (header-value 'host (request-headers req)))
34      (test "HTTP request is version 1.1"
35            '(1 1)
36            (list (request-major req) (request-minor req)))))
37
38  (test-group "a response with trailing garbage"
39    (with-server-response
40     (lambda ()
41       (test "Response excludes garbage data"
42             "foo"
43             (with-input-from-request
44              "http://example.com" #f read-string)))
45     (conc "HTTP/1.0 200 OK\r\nContent-Length: 3\r\n"
46           "\r\nfoobar")))
47
48  ;; This is (mostly) an intarweb test...
49  (test-group "a short chunked response with trailing garbage"
50    (with-server-response
51     (lambda ()
52       (test "Response is the chunked data"
53             "one, two three"
54             (with-input-from-request "http://example.com"
55                                      #f read-string)))
56     (conc "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n"
57           "\r\n5\r\none, \r\n2\r\ntw\r\n7\r\no three\r\n0\r\n"
58           "IGNORED TRAILING GARBAGE")))
59
60  (test-group "400 series"
61    (with-server-response
62     (lambda ()
63       (test-error* "404 results in client error"
64                    (exn http client-error)
65                    (with-input-from-request "http://example.com" #f #f)))
66     (conc "HTTP/1.0 404 Not Found\r\n"))))
67
68
69(test-group "request body encoding"
70  (test-group "simple string body"
71    (let* ((log (with-server-response
72                 (lambda ()
73                   (test "Response is read back"
74                         "Your response, sir"
75                         (with-input-from-request
76                          "http://example.com" "testing" read-string)))
77                 "HTTP/1.0 200 OK\r\n\r\nYour response, sir"))
78           (req (log-request log)))
79
80      (test "Request method" 'POST (request-method req))
81      (test "Content type is not set"
82            #f
83            (header-value 'content-type (request-headers req)))
84      (test "Content-length is string length"
85            7 (header-value 'content-length (request-headers req)))
86      (test "String was sent as body" "testing" (log-body log))))
87
88  (test-group "string body with custom request method"
89    (let* ((log (with-server-response
90                 (lambda ()
91                   (let* ((uri (uri-reference "http://example.com"))
92                          (req (make-request uri: uri method: 'LALA)))
93                     (test "Response is read back"
94                           "Your response, sir"
95                           (with-input-from-request
96                            req "testing" read-string))))
97                 "HTTP/1.0 200 OK\r\n\r\nYour response, sir"))
98           (req (log-request log)))
99
100      (test "Request method is custom" 'LALA (request-method req))
101      (test "Content type is not set"
102            #f
103            (header-value 'content-type (request-headers req)))
104      (test "Content-length is string length"
105            7 (header-value 'content-length (request-headers req)))
106      (test "String was sent as body" "testing" (log-body log))))
107
108  (test-group "alist form data body"
109    (let* ((log (with-server-response
110                 (lambda ()
111                   (with-input-from-request
112                    "http://example.com"
113                    '((lala . "testing")
114                      (another . "data")
115                      ("more" . stuff))
116                    read-string))
117                 "HTTP/1.0 200 OK\r\n\r\n"))
118           (req (log-request log)))
119
120      (test "Request method" 'POST (request-method req))
121      (test "Content type is form encoding"
122            'application/x-www-form-urlencoded
123            (header-value 'content-type (request-headers req)))
124      (test "Content-length was set correctly"
125            36 (header-value 'content-length (request-headers req)))
126      (test "Body was sent correctly"
127            "lala=testing&another=data&more=stuff" (log-body log))))
128
129  (test-group "alist form data body with file port"
130    (let* ((string-port (open-input-string "the file's contents"))
131           (log (with-server-response
132                 (lambda ()
133                   (with-input-from-request
134                    "http://example.com"
135                    `((lala . "testing")
136                      (the-file file: ,string-port
137                                filename: "str")
138                      ("more" . stuff))
139                    read-string))
140                 "HTTP/1.0 200 OK\r\n\r\n"))
141           (req (log-request log))
142           (h (request-headers req))
143           (boundary (header-param 'boundary 'content-type h))
144           (expected-data
145            (conc
146             "--" boundary "\r\n"
147             "Content-Disposition: form-data; name=\"lala\"\r\n\r\n"
148             "testing\r\n"
149             "--" boundary "\r\n"
150             "Content-Disposition: form-data; name=\"the-file\"; "
151             "filename=\"str\"\r\n"
152             "Content-Type: application/octet-stream\r\n\r\n"
153             "the file's contents\r\n"
154             "--" boundary "\r\n"
155             "Content-Disposition: form-data; name=\"more\"\r\n\r\n"
156             "stuff\r\n"
157             "--" boundary "--\r\n")))
158
159      (test "Request method" 'POST (request-method req))
160      (test "Content type is multipart"
161            'multipart/form-data
162            (header-value 'content-type h))
163      (test "Content-length was not set"
164            #f (header-value 'content-length h))
165      (test "Body contains the file and other data, delimited by the boundary"
166            expected-data (log-body log))))
167
168  (test-group "alist form data body with filename"
169    (let* ((tmpfile (create-temporary-file))
170           (log (with-server-response
171                 (lambda ()
172                   (with-output-to-file tmpfile
173                     (lambda () (display "the file's contents")))
174                   (with-input-from-request
175                    "http://example.com"
176                    `((lala . "testing")
177                      (the-file file: ,tmpfile filename: "tmpfile")
178                      ("more" . stuff))
179                    read-string))
180                 "HTTP/1.0 200 OK\r\n\r\n"))
181           (req (log-request log))
182           (h (request-headers req))
183           (boundary (header-param 'boundary 'content-type h))
184           (expected-data
185            (conc
186             "--" boundary "\r\n"
187             "Content-Disposition: form-data; name=\"lala\"\r\n\r\n"
188             "testing\r\n"
189             "--" boundary "\r\n"
190             "Content-Disposition: form-data; name=\"the-file\"; "
191             "filename=\"tmpfile\"\r\n"
192             "Content-Type: application/octet-stream\r\n\r\n"
193             "the file's contents\r\n"
194             "--" boundary "\r\n"
195             "Content-Disposition: form-data; name=\"more\"\r\n\r\n"
196             "stuff\r\n"
197             "--" boundary "--\r\n")))
198
199      (test "Request method" 'POST (request-method req))
200      (test "Content type is multipart"
201            'multipart/form-data
202            (header-value 'content-type h))
203      (test "Content-length was set to the entire body size"
204            (string-length expected-data)
205            (header-value 'content-length h))
206      (test "Body contains the file and other data, delimited by the boundary"
207            expected-data (log-body log))))
208
209  (test-group "custom writer procedure"
210    (let* ((log (with-server-response
211                 (lambda ()
212                   (test "Response is read back"
213                         "Your response, sir"
214                         (with-input-from-request
215                          "http://example.com"
216                          (lambda ()
217                            (display "test, ")
218                            (display "test, 123"))
219                          read-string)))
220                 "HTTP/1.0 200 OK\r\n\r\nYour response, sir"))
221           (req (log-request log)))
222
223      (test "Request method" 'POST (request-method req))
224      (test "Content type is not set"
225            #f
226            (header-value 'content-type (request-headers req)))
227      (test "Transfer encoding is chunked"
228            'chunked
229            (header-value 'transfer-encoding (request-headers req)))
230      (test "Content-length is not set"
231            #f (header-value 'content-length (request-headers req)))
232      (test "All writes were received"
233            "test, test, 123" (log-body log))))
234
235    (test-group "custom writer procedure with content-length header"
236      (let* ((req (make-request uri: (uri-reference "http://example.com")
237                                headers: (headers `((content-length 15)))
238                                method: 'POST))
239             (log (with-server-response
240                 (lambda ()
241                   (test "Response is read back"
242                         "Your response, sir"
243                         (with-input-from-request
244                          req
245                          (lambda ()
246                            (display "test, ")
247                            (display "test, 123"))
248                          read-string)))
249                 "HTTP/1.0 200 OK\r\n\r\nYour response, sir"))
250           (req (log-request log)))
251
252      (test "Request method" 'POST (request-method req))
253      (test "Content type is not set"
254            #f
255            (header-value 'content-type (request-headers req)))
256      (test "Transfer encoding is not set"
257            #f
258            (header-value 'transfer-encoding (request-headers req)))
259      (test "Content-length is taken from user-supplied header"
260            15 (header-value 'content-length (request-headers req)))
261      (test "All writes were received"
262            "test, test, 123" (log-body log)))))
263
264(test-group "Redirects"
265  (test-group "single permanent GET redirect"
266    (let* ((logs (with-server-responses
267                  (lambda ()
268                    (test "Final response matches final request"
269                          "Got here"
270                          (with-input-from-request
271                           "http://example.com/some/path#more"
272                           #f read-string)))
273                  (conc "HTTP/1.0 301 Moved Permanently\r\n"
274                        "Location: http://example.org/different/path\r\n"
275                        "Content-Length: 8\r\n\r\nIgnored!")
276                  (conc "HTTP/1.0 200 OK\r\nContent-Length: 8\r\n\r\n"
277                        "Got here")))
278           (req1 (log-request (car logs)))
279           (req2 (log-request (cadr logs))))
280
281      (test "Redirected URI is new path"
282            "/different/path" (uri->string (request-uri req2)))
283      (test "host header gets set on second request"
284            '("example.org" . #f)
285            (header-value 'host (request-headers req2)))
286      (test "HTTP request is version 1.1 (even though response was 1.0)"
287            '(1 1)
288            (list (request-major req2) (request-minor req2)))))
289
290  (test-group "single permanent POST redirect"
291    (let* ((logs (with-server-responses
292                  (lambda ()
293                    (test "Final response matches final request"
294                          "Got here"
295                          (with-input-from-request
296                           "http://example.com/some/path#more"
297                           '((foo . "bar")) read-string)))
298                  (conc "HTTP/1.0 301 Moved Permanently\r\n"
299                        "Location: http://example.org/different/path\r\n"
300                        "Content-Length: 8\r\n\r\nIgnored!")
301                  (conc "HTTP/1.0 200 OK\r\nContent-Length: 8\r\n\r\n"
302                        "Got here")))
303           (req1 (log-request (car logs)))
304           (req2 (log-request (cadr logs))))
305
306      (test "Redirected URI is new path"
307            "/different/path" (uri->string (request-uri req2)))
308      (test "HTTP method is still POST" 'POST (request-method req2))
309      (test "Correct content-length on both requests"
310            '(7 7)
311            (list (header-value 'content-length (request-headers req1))
312                  (header-value 'content-length (request-headers req2))))
313      (test "Body got sent to target" "foo=bar" (log-body (cadr logs)))))
314
315  (test-group "single \"see other\" POST redirect"
316    (let* ((logs (with-server-responses
317                  (lambda ()
318                    (test "Final response matches final request"
319                          "Got here"
320                          (with-input-from-request
321                           "http://example.com/some/path#more"
322                           '((foo . "bar")) read-string)))
323                  (conc "HTTP/1.0 303 See Other\r\n"
324                        "Location: http://example.org/different/path\r\n"
325                        "Content-Length: 8\r\n\r\nIgnored!")
326                  (conc "HTTP/1.0 200 OK\r\nContent-Length: 8\r\n\r\n"
327                        "Got here")))
328           (req1 (log-request (car logs)))
329           (req2 (log-request (cadr logs))))
330
331      (test "Redirected URI is new path"
332            "/different/path" (uri->string (request-uri req2)))
333      (test "HTTP method switched to GET" 'GET (request-method req2))
334      (test "Zero content-length on target"
335            0
336            (header-value 'content-length (request-headers req2)))
337      (test "No body got sent to target" "" (log-body (cadr logs)))))
338
339  (test-group "Multiple redirects, just below maximum"
340    (parameterize ((max-redirect-depth 3))
341      (let* ((logs (with-server-responses
342                    (lambda ()
343                      (test "Final response matches final request"
344                            "Got here"
345                            (with-input-from-request
346                             "http://example.com/some/path#more"
347                             #f read-string)))
348                    (conc "HTTP/1.0 301 Moved Permanently\r\n"
349                          "Location: http://example.org/different/path\r\n"
350                          "Content-Length: 8\r\n\r\nIgnored!")
351                    (conc "HTTP/1.0 301 Moved Permanently\r\n"
352                          "Location: http://example.org/new/path\r\n"
353                          "Content-Length: 8\r\n\r\nIgnored!")
354                    (conc "HTTP/1.0 301 Moved Permanently\r\n"
355                          "Location: http://example.net/newer/path\r\n"
356                          "Content-Length: 8\r\n\r\nIgnored!")
357                    (conc "HTTP/1.0 200 OK\r\nContent-Length: 8\r\n\r\n"
358                          "Got here")))
359             (req (log-request (last logs))))
360
361        (test "Redirected URI is new path"
362              "/newer/path" (uri->string (request-uri req)))
363        (test "host header gets set on last request"
364              '("example.net" . #f)
365              (header-value 'host (request-headers req)))
366        (test "HTTP request is still version 1.1"
367              '(1 1) (list (request-major req) (request-minor req))))))
368
369  (test-group "Exceeding maximum redirects"
370    (parameterize ((max-redirect-depth 2))
371      (test-error* "results in a client redirect error"
372                   (exn http redirect-depth-exceeded)
373                   (with-server-responses
374                    (lambda ()
375                      (with-input-from-request "http://example.com"
376                                               #f read-string))
377                    (conc "HTTP/1.0 301 Moved Permanently\r\n"
378                          "Location: http://example.org/different/path\r\n"
379                          "Content-Length: 8\r\n\r\nIgnored!")
380                    (conc "HTTP/1.0 301 Moved Permanently\r\n"
381                          "Location: http://example.org/new/path\r\n"
382                          "Content-Length: 8\r\n\r\nIgnored!")
383                    (conc "HTTP/1.0 301 Moved Permanently\r\n"
384                          "Location: http://example.net/newer/path\r\n"
385                          "Content-Length: 8\r\n\r\nIgnored!")
386                    (conc "HTTP/1.0 200 OK\r\nContent-Length: 19\r\n\r\n"
387                          "Should not get here"))))))
388
389(test-group "error handling"
390  (with-server-responses
391   (lambda ()
392     (test-error* "Invalid uri"
393                  (exn http bad-uri)
394                  (with-input-from-request "%" #f read-string))))
395  ;; TODO: Why shouldn't empty POST be allowed?
396  (with-server-responses
397   (lambda ()
398     (test-error* "Invalid form data"
399                  (exn http form-data-error)
400                  (with-input-from-request
401                   "http://example.com" '() read-string)))))
402
403
404(test-end "http-client")
405
406(test-exit)
Note: See TracBrowser for help on using the repository browser.