source: project/release/4/intarweb/trunk/tests/run.scm @ 27102

Last change on this file since 27102 was 27102, checked in by sjamaan, 9 years ago

intarweb: Properly implement line limits and header count limits

File size: 51.8 KB
Line 
1(require-extension test extras uri-common intarweb srfi-18)
2
3(define-syntax test-error*
4  (syntax-rules ()
5    ((_ ?msg (?error-type ...) ?expr)
6     (let-syntax ((expression:
7                   (syntax-rules ()
8                     ((_ ?expr)
9                      (condition-case (begin ?expr "<no error thrown>")
10                                      ((?error-type ...) '(?error-type ...))
11                                      (exn () (##sys#slot exn 1)))))))
12       (test ?msg '(?error-type ...) (expression: ?expr))))
13    ((_ ?msg ?error-type ?expr)
14     (test-error* ?msg (?error-type) ?expr))
15    ((_ ?error-type ?expr)
16     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
17
18(header-parse-error-handler (lambda (header-name contents header exn)
19                              (raise exn)))
20
21(define (test-read-headers str)
22  (call-with-input-string str read-headers))
23
24(test-begin "Intarweb")
25(test-group "Headers"
26  (test-group "Single headers"
27   (parameterize ((single-headers '(foo qux))
28                  (header-parsers `((foo . ,(single identity))
29                                    (qux . ,(single identity)))))
30     (let ((headers (test-read-headers "foo: bar\r\nqux:\t   \tmooh\t   \r\n\r\n")))
31       (test "Basic test"
32             '("bar") (header-values 'foo headers))
33       ;; RFC 2616 4.2
34       (test "Extra spaces are ignored"
35             '("mooh") (header-values 'qux headers)))
36     (let ((headers (test-read-headers "foo: bar\r\n qux: mooh\r\nquux: mumble\r\n\r\n")))
37       ;; RFC 2616 2.2
38       (test "Continuation chars"
39             '("bar qux: mooh") (header-values 'foo headers)))
40     ;; Not in RFC but common behaviour - also, robustness principle
41     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\n")))
42       (test "Multiple headers for singular header types discarded"
43             '("qux") (header-values 'foo headers)))))
44  ;; All this RFC 2616 4.2
45  (test-group "Multi-headers"
46   (parameterize ((header-parsers `((foo . ,(multiple identity)))))
47     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\nquux: mumble\r\n\r\n")))
48       (test "Multiple headers"
49             '("bar" "qux") (header-values 'foo headers)))
50     (let ((headers (test-read-headers "Foo: bar\r\nFoO: qux\r\nquux: mumble\r\n\r\n")))
51       (test "Multiple headers: case insensitivity"
52             '("bar" "qux") (header-values 'foo headers)))
53     (let ((headers (test-read-headers "foo: bar, qux\r\nquux: mumble\r\n\r\n")))
54       (test "Comma-separated headers"
55             '("bar" "qux") (header-values 'foo headers)))
56     (let ((headers (test-read-headers "foo: \"ba\\\"r, qux\"\r\nfoo: mooh\r\n\r\n")))
57       (test "Quoted headers"
58             '("ba\"r, qux" "mooh") (header-values 'foo headers))))
59   ;; RFC 2616 4.5
60   ;; "Unrecognized header fields are treated as entity-header fields."
61   ;;
62   ;; RFC 2616 7.1
63   ;; "Unrecognized header fields SHOULD be ignored by the recipient and MUST be
64   ;;  forwarded by transparent proxies."
65   (let ((headers (test-read-headers "unknown: foo, bar\r\nunknown: blah\r\n\r\n")))
66     (test "Unknown headers are not parsed and put into lists"
67           '("foo, bar" "blah") (header-values 'unknown headers))))
68  (test-group "Miscellaneous"
69    (parameterize ((header-parsers `((foo . ,(multiple identity))
70                                     (bar . ,(lambda x (error "bad header")))))
71                   (http-header-limit 2))
72      (test-error "Missing header contents" (test-read-headers "foo\r\n\r\n"))
73      (test-error "Bad header w/ handler" (test-read-headers "bar: x\r\n\r\n"))
74      (parameterize ((header-parse-error-handler (lambda (n c h exn) h)))
75       (test "Bad header w/o handler" #t (headers? (test-read-headers "bar: x\r\n\r\n"))))
76      ;; RFC 2616 2.2
77      ;; "The backslash character ("\") MAY be used as a single-character
78      ;; quoting mechanism only within quoted-string and comment constructs."
79      ;;     quoted-pair = "\" CHAR
80      ;; CHAR implies any char, *including* CR/LF. This is clarified by RFC 822,
81      ;; on which RFC 2616 is based.
82      ;; Apparently, even \CRLF is allowed (as opposed to \CR\LF)
83      (test "Embedded newlines"
84            '("bar\r\nqux")
85            ;; It's unclear whether we should interpret the "\r\n" as EOL
86            ;; in "\\\r\n", or whether it should be seen as an embedded \r
87            ;; followed by a \n (which is then interpreted as a literal \n?)
88            (header-values 'foo (test-read-headers "Foo: \"bar\\\r\\\nqux\"")))
89      (test-error "Too many headers is an error"
90                  (test-read-headers "foo: bar\r\nfoo: qux\r\nfoo: hoohoo\r\n")))))
91
92(test-group "Specialized header parsers"
93  (test-group "Host/port"
94    (test "Hostname and port"
95          '(("foo.example.com" . 8080))
96          (header-values 'host (test-read-headers "Host: foo.example.com:8080")))
97    (test "Hostname, no port"
98          '(("foo.example.com" . #f))
99          (header-values 'host (test-read-headers "Host: foo.example.com"))))
100  (test-group "Quality parameter"
101   (let* ((headers (test-read-headers "Accept: text/plain; Q=0.5, text/html, text/plain; q=0.123456, application/pdf; q=1.2345, text/xml; q=-0.234, text/whatever; q="))
102          (accept  (header-contents 'accept headers)))
103     ;; RFC 2616 3.6: "All transfer-coding values are case insensitive".
104     ;; This includes the parameter name (attribute) and value.
105     (test "quality value (case-insensitive)"
106           0.5 (get-param 'q (first accept) 1.0))
107     (test "quality encoding value"
108           'text/plain (get-value (first accept)))
109     (test "quality values have only three digits"
110           0.123 (get-param 'q (third accept) 1.0))
111     (test "quality values maximum is 1.0"
112           1.0 (get-param 'q (fourth accept) 1.0))
113     (test "quality values minimum is 0.0"
114           0.0 (get-param 'q (fifth accept) 1.0))
115     (test "missing quality value ok"
116           1.0 (get-param 'q (sixth accept) 1.0))))
117  (test-group "Charset parameter"
118   (let* ((headers (test-read-headers "Content-Type: text/PLAIN; charset=ISO-8859-1"))
119          (content-type (header-contents 'content-type headers)))
120     (test "content-type value is lowercase symbol"
121           'text/plain (get-value (car content-type)))
122     ;; RFC 2616 3.4: "HTTP character sets are identified by
123     ;; case-insensitive tokens. The complete set of tokens is defined
124     ;; by the IANA Character Set registry."
125     (test "content-type charset is lowercase symbol"
126           'iso-8859-1 (get-param 'charset (car content-type)))))
127
128  (test-group "Symbol-parser-ci"
129    (let* ((headers (test-read-headers "Accept-Ranges: FoO")))
130      (test "Case-insensitive"
131            '(foo) (header-values 'accept-ranges headers))))
132 
133  (test-group "Symbol-parser"
134    (let* ((headers (test-read-headers "Allow: FoO, foo")))
135      (test "Case-sensitive"
136            '(FoO foo) (header-values 'allow headers))))
137
138  (test-group "Natnum-subparser"
139    (parameterize ((single-headers '(foo bar qux mooh))
140                   (header-parsers `((foo . ,(single natnum-subparser))
141                                     (bar . ,(single natnum-subparser))
142                                     (qux . ,(single natnum-subparser))
143                                     (mooh . ,(single natnum-subparser)))))
144     (let ((headers (test-read-headers "Foo: 10\r\nBar: abc\r\nQux: -10\r\nMooh: 1.6")))
145       (test "Simple test"
146             10 (header-value 'foo headers))
147       (test "No number defaults to 0"
148             0 (header-value 'bar headers))
149       (test "No negative numbers"
150             0 (header-value 'qux headers))
151       ;; This is a "feature" in the interest of the robustness principle
152       (test "Rounding of real numbers"
153             2 (header-value 'mooh headers)))))
154
155  (test-group "Cache-control-parser"
156    (let ((headers (test-read-headers "Cache-control: max-age=10, private")))
157      (test "max-age is a number"
158            '(max-age . 10) (assq 'max-age (header-values 'cache-control headers)))
159      (test "private without value"
160            '(private . #t) (assq 'private (header-values 'cache-control headers))))
161    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
162      (test "private with values"
163            '(private . (accept-encoding accept-ranges))
164            (assq 'private (header-values 'cache-control headers)))
165      (test "Acts like a multi-header"
166            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
167
168  (test-group "authorization-parser"
169    (test-group "basic auth"
170     (let ((headers (test-read-headers "Authorization: Basic QWxpIEJhYmE6b3BlbiBzZXNhbWU=\r\n")))
171       (test "basic"
172             'basic
173             (header-value 'authorization headers))
174       (test "username"
175             "Ali Baba"
176             (header-param 'username 'authorization headers))
177       (test "password"
178             "open sesame"
179             (header-param 'password 'authorization headers))))
180    (test-group "digest auth"
181      (let ((headers (test-read-headers "Authorization: Digest username=\"Mufasa\", realm=\"testrealm@host.com\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", uri=\"/dir/index.html\", qop=auth, nc=00000001, cnonce=\"0a4f113b\", response=\"6629fae49393a05397450978507c4ef1\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\", algorithm=MD5")))
182        (test "digest"
183              'digest
184              (header-value 'authorization headers))
185        (test "realm"
186              "testrealm@host.com"
187              (header-param 'realm 'authorization headers))
188        (test "nonce"
189              "dcd98b7102dd2f0e8b11d0f600bfb0c093"
190              (header-param 'nonce 'authorization headers))
191        (test "username"
192              "Mufasa"
193              (header-param 'username 'authorization headers))
194        (test "qop"
195              'auth
196              (header-param 'qop 'authorization headers))
197        (test "digest uri"
198              "/dir/index.html"
199              (uri->string (header-param 'uri 'authorization headers)))
200        (test "nonce count"
201              1
202              (header-param 'nc 'authorization headers))
203        (test "cnonce"
204              "0a4f113b"
205              (header-param 'cnonce 'authorization headers))
206        (test "response"
207              "6629fae49393a05397450978507c4ef1"
208              (header-param 'response 'authorization headers))
209        (test "opaque"
210              "5ccc069c403ebaf9f0171e9517f40e41"
211              (header-param 'opaque 'authorization headers))
212        (test "algorithm"
213              'md5
214              (header-param 'algorithm 'authorization headers))))
215    (test-group "custom authorization scheme"
216      (parameterize ((authorization-param-subparsers
217                      `((custom . ,(lambda (contents pos)
218                                     (receive (c p)
219                                       (parse-token contents pos)
220                                       (values `((contents . ,(http-name->symbol c))) p))))
221                        . ,(authorization-param-subparsers))))
222        (let ((headers (test-read-headers "Authorization: Custom Security-through-obscurity")))
223          (test "Custom"
224                'custom
225                (header-value 'authorization headers))
226          (test "Custom contents"
227                'security-through-obscurity
228                (header-param 'contents 'authorization headers))))))
229 
230  (test-group "authenticate parser"
231    (test-group "basic auth"
232      (let ((headers (test-read-headers "WWW-Authenticate: Basic realm=\"WallyWorld\"")))
233        (test "basic"
234              'basic
235              (header-value 'www-authenticate headers))
236        (test "realm"
237              "WallyWorld"
238              (header-param 'realm 'www-authenticate headers))))
239    (test-group "digest auth"
240      (let ((headers (test-read-headers "WWW-Authenticate: Digest realm=\"testrealm@host.com\", qop=\"auth, auth-int\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\"")))
241        (test "digest"
242              'digest
243              (header-value 'www-authenticate headers))
244        (test "realm"
245              "testrealm@host.com"
246              (header-param 'realm 'www-authenticate headers))
247        (test "qop"
248              '(auth auth-int)
249              (header-param 'qop 'www-authenticate headers))
250        (test "nonce"
251              "dcd98b7102dd2f0e8b11d0f600bfb0c093"
252              (header-param 'nonce 'www-authenticate headers))
253        (test "opaque"
254              "5ccc069c403ebaf9f0171e9517f40e41"
255              (header-param 'opaque 'www-authenticate headers))
256        (test "missing stale value"
257              #f
258              (header-param 'stale 'www-authenticate headers)))
259      (let ((headers (test-read-headers "WWW-Authenticate: Digest domain=\"/example http://foo.com/bar\", stale=TRUE")))
260        (test "domains"
261              '("/example" "http://foo.com/bar")
262              (map uri->string
263                   (header-param 'domain 'www-authenticate headers)))
264        (test "stale"
265              #t
266              (header-param 'stale 'www-authenticate headers)))
267      (let ((headers (test-read-headers "WWW-Authenticate: Digest stale=whatever")))
268        (test "non-true stale value"
269              #f
270              (header-param 'stale 'www-authenticate headers)))))
271 
272  (test-group "pragma-parser"
273    (let ((headers (test-read-headers "Pragma: custom-value=10, no-cache")))
274      (test "value"
275            '(custom-value . "10")
276            (assq 'custom-value (header-values 'pragma headers)))
277      (test "no value"
278            '(no-cache . #t) (assq 'no-cache (header-values 'pragma headers))))
279    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
280      (test "private with values"
281            '(private . (accept-encoding accept-ranges))
282            (assq 'private (header-values 'cache-control headers)))
283      (test "Acts like a multi-header"
284            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
285
286  ;; RFC 2616, 14.15  &  RFC 1864 (Base64)
287  (test-group "base64-parser"
288    (let ((headers (test-read-headers "Content-md5: Q2hlY2sgSW50ZWdyaXR5IQ==")))
289      (test "md5 is base64-decoded"
290            "Check Integrity!"
291            (header-value 'content-md5 headers))))
292
293  (test-group "Range-parser"
294    (let ((headers (test-read-headers "content-range: bytes 500-999/1234")))
295      (test "Simple range"
296            '(500 999 1234)
297            (header-value 'content-range headers))))
298
299  (test-group "Content-disposition"
300    (let ((headers (test-read-headers "Content-Disposition: attachment; filename=dir/foo.jpg")))
301      (test "Attachment with filename parameter containing directory"
302            `(attachment (filename . "foo.jpg"))
303            (cons (header-value  'content-disposition headers)
304                  (header-params 'content-disposition headers))))
305    (let ((headers (test-read-headers "Content-Disposition: inline; filename=foo.jpg; creation-date=Sun, 06 Nov 1994 08:49:37 GMT")))
306      (test "Inline with filename and (not quoted) creation-date parameter"
307            `(inline
308              (filename . "foo.jpg")
309              (creation-date . ,(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))))
310            (cons (header-value  'content-disposition headers)
311                  (map (lambda (x)
312                         (if (vector? (cdr x))
313                             (cons (car x) (utc-time->seconds (cdr x)))
314                             x))
315                       (header-params 'content-disposition headers)))))
316    (let ((headers (test-read-headers "Content-Disposition: inline; read-date=\"Sun, 06 Nov 1994 08:49:37 GMT\"; size=100")))
317      (test "Inline with size and (quoted) read-date parameter"
318            `(inline
319              (read-date . ,(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0)))
320              (size . 100))
321            (cons (header-value  'content-disposition headers)
322                  (map (lambda (x)
323                         (if (vector? (cdr x))
324                             (cons (car x) (utc-time->seconds (cdr x)))
325                             x))
326                       (header-params 'content-disposition headers))))))
327
328  (test-group "normalized-uri"
329    (let ((headers (test-read-headers "Location: http://example.com/foo")))
330      (test "Uri"
331            (uri-reference "http://example.com/foo")
332            (header-value 'location headers)))
333    (let ((headers (test-read-headers "Location: http://example.com/foo/../bar")))
334     (test "Auto-normalization"
335           (uri-reference "http://example.com/bar")
336           (header-value 'location headers))))
337
338  (test-group "etag-parser"
339    (let ((headers (test-read-headers "Etag: \"foo\"")))
340      (test "Strong tag"
341            '(strong . "foo")
342            (header-value 'etag headers)))
343    (let ((headers (test-read-headers "Etag: W/\"bar\"")))
344      (test "Weak tag"
345            '(weak . "bar")
346            (header-value 'etag headers)))
347    (let ((headers (test-read-headers "Etag: \"\"")))
348      (test "Empty tag"
349            '(strong . "")
350            (header-value 'etag headers)))
351    (let ((headers (test-read-headers "Etag: \"W/bar\"")))
352        (test "Strong tag, containing W/ prefix"
353              '(strong . "W/bar")
354              (header-value 'etag headers))))
355
356  (test-group "if-match parser"
357    (let ((headers (test-read-headers "If-match: foo")))
358      (test "Strong etag"
359            '(strong . "foo")
360            (header-value 'if-match headers)))
361    (let ((headers (test-read-headers "If-match: W/foo")))
362      (test "Weak etag"
363            '(weak . "foo")
364            (header-value 'if-match headers)))
365    (let ((headers (test-read-headers "If-match: W/foo bar")))
366      (test "Multiple etags"
367            '((weak . "foo") (strong . "bar"))
368            (header-values 'if-match headers)))
369    (let ((headers (test-read-headers "If-match: *")))
370      (test "Wildcard"
371            '*
372            (header-value 'if-match headers))))
373
374  (test-group "http-date-parser"
375    (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
376      (test "RFC1123 time"
377            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
378            (utc-time->seconds (header-value 'date headers))))
379    (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
380      (test "RFC850 time"
381            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
382            (utc-time->seconds (header-value 'date headers))))
383    (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
384      (test "asctime time"
385            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
386            (utc-time->seconds (header-value 'date headers)))))
387
388  ;; This seems a little excessive.. Maybe find a way to reduce the number
389  ;; of cases and still have a good representative test?
390  (test-group "If-Range parser"
391    (let ((headers (test-read-headers "If-Range: Sun, 06 Nov 1994 08:49:37 GMT")))
392      (test "RFC1123 time"
393            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
394            (utc-time->seconds (header-value 'if-range headers))))
395    (let ((headers (test-read-headers "If-Range: Sunday, 06-Nov-94 08:49:37 GMT")))
396      (test "RFC850 time"
397            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
398            (utc-time->seconds (header-value 'if-range headers))))
399    (let ((headers (test-read-headers "If-Range: Sun Nov  6 08:49:37 1994")))
400      (test "asctime time"
401            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
402            (utc-time->seconds (header-value 'if-range headers))))
403    (let ((headers (test-read-headers "If-Range: \"foo\"")))
404      (test "Strong Etag"
405            '(strong . "foo")
406            (header-value 'if-range headers)))
407    (let ((headers (test-read-headers "If-Range: W/\"bar\"")))
408      (test "Weak Etag"
409            '(weak . "bar")
410            (header-value 'if-range headers)))
411    (let ((headers (test-read-headers "If-Range: \"\"")))
412      (test "Empty Etag"
413            '(strong . "")
414            (header-value 'if-range headers)))
415    (let ((headers (test-read-headers "If-Range: \"W/bar\"")))
416        (test "Strong Etag, containing W/ prefix"
417              '(strong . "W/bar")
418              (header-value 'if-range headers)))    )
419
420  (test-group "Product parser"
421    (test "Simple product"
422          '(("Mozilla" "5.0" #f))
423          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla/5.0\r\n")))
424    (test "Product with comment"
425          '(("Mozilla" #f "foo"))
426          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla (foo)\r\n")))   
427    (test "Realistic product (comments, semicolons)"
428          '(("Mozilla" "5.0" "X11; U; NetBSD amd64; en-US; rv:1.9.0.3") ("Gecko" "2008110501" #f) ("Minefield" "3.0.3" #f))
429          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla/5.0 (X11; U; NetBSD amd64; en-US; rv:1.9.0.3) Gecko/2008110501 Minefield/3.0.3\r\n"))))
430
431  (test-group "Set-Cookie parser"
432    (let* ((headers (test-read-headers "Set-Cookie: foo=\"bar\"")))
433      (test "Simple name/value pair"
434            '("foo" . "bar")
435            (get-value (first (header-contents 'set-cookie headers)))))
436    (let* ((headers (test-read-headers "Set-Cookie: foo=qux\r\nSet-Cookie: Foo=\"bar\"")))
437      ;; XXX: Should intarweb remove these, or should the user code handle this?
438      ;; What if interacting with actual broken code on the other side?
439      (test "Multiple cookies with same name (CI) are all kept"
440            '(("foo" . "qux") ("Foo" . "bar"))
441            (map get-value (header-contents 'set-cookie headers))))
442    (let* ((headers (test-read-headers "Set-Cookie: Foo=bar")))
443      (test "Cookie names preserve case"
444            '("Foo" . "bar")
445            (get-value (first (header-contents 'set-cookie headers)))))
446    (let ((headers (test-read-headers "Set-Cookie: foo=bar=qux; max-age=10")))
447      (test "Cookie with = signs"
448            '("foo" . "bar=qux")
449            (get-value (first (header-contents 'set-cookie headers)))))
450    (let* ((headers (test-read-headers "Set-Cookie: foo=bar; Comment=\"Hi, there!\", qux=mooh\r\nSet-Cookie: mumble=mutter\r\n")))
451      (test "Comment"
452            "Hi, there!"
453            (get-param 'comment
454                       (first (header-contents 'set-cookie headers))))
455      (test "Multiple cookies in one header"
456            '("qux" . "mooh")
457            (get-value (second (header-contents 'set-cookie headers))))
458      (test "Multiple cookies in multiple headers"
459            '("mumble" . "mutter")
460            (get-value (third (header-contents 'set-cookie headers))))
461      (test "Missing \"secure\" value"
462            #f
463            (get-param 'secure
464                       (third (header-contents 'set-cookie headers)))))
465    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sunday, 20-Jul-08 15:23:42 GMT; secure; path = / ; Port=80,8080")))
466      (test "Missing value"
467            '("foo" . "")
468            (get-value (first (header-contents 'set-cookie headers))))
469      (test "Old-style cookie expires value"
470            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
471            (utc-time->seconds
472             (get-param 'expires
473                        (first (header-contents 'set-cookie headers)))))
474      (test "Secure value"
475            #t
476            (get-param 'secure
477                       (first (header-contents 'set-cookie headers))))
478      (test "Path"
479            (uri-reference "/")
480            (get-param 'path
481                       (first (header-contents 'set-cookie headers))))
482      (test "Port numbers"
483            '(80 8080)
484            (get-param 'port
485                       (first (header-contents 'set-cookie headers)))))
486    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sun, 20 Jul 2008 15:23:42 GMT; secure; path = / ")))
487      (test "Noncompliant syntax cookie expiry value (rfc1123)"
488            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
489            (utc-time->seconds
490             (get-param 'expires
491                        (first (header-contents 'set-cookie headers))))))
492    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sun, 20-Jul-2008 15:23:42 GMT; secure; path = / ")))
493      (test "Noncompliant syntax cookie expiry value (rfc850-like, abbrev day)"
494            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
495            (utc-time->seconds
496             (get-param 'expires
497                        (first (header-contents 'set-cookie headers)))))))
498 
499  (test-group "Cookie-parser"
500    (let* ((headers (test-read-headers "Cookie: Foo=bar; $Path=/; qux=mooh; $unknown=something")))
501      (test "Multiple cookies in the same header"
502            '(("Foo" . "bar") . ("qux" . "mooh"))
503            (cons
504             (get-value (first  (header-contents 'cookie headers)))
505             (get-value (second (header-contents 'cookie headers)))))
506      (test "Parameters of cookies (spaces stripped)"
507            (uri-reference "/")
508            (get-param 'path (first (header-contents 'cookie headers))))
509      (test "Parameters of cookies"
510            "something"
511            (get-param 'unknown (second (header-contents 'cookie headers)))))
512    (let* ((headers (test-read-headers "Cookie: $Version=\"1\"; Foo=bar; $Path=/; qux=mooh; $unknown=something")))
513      (test "Version string is used for all cookies"
514            (cons 1 1)
515            (cons
516             (get-param 'version (first (header-contents 'cookie headers)))
517             (get-param 'version (second (header-contents 'cookie headers))))))))
518
519(test-group "Headers"
520  (test "Simple test"
521        `(bar qux)
522        (header-values 'foo (headers `((foo bar qux)))))
523  (test "Multi headers are folded"
524        `(bar qux)
525        (header-values 'foo (headers `((foo bar)
526                                       (foo qux)))))
527  (test "Single headers are unique"
528        `(qux)
529        (header-values 'foo (parameterize ((single-headers '(foo)))
530                                    (headers `((foo bar)
531                                               (foo qux))))))
532  (test "Extra single headers are ignored"
533        `(qux)
534        (header-values 'foo (parameterize ((single-headers '(foo)))
535                                    (headers `((foo bar qux))))))
536  (test "Parameters"
537        `((bar . qux))
538        (get-params
539         (car (header-contents 'foo (headers `((foo #(mooh ((bar . qux))))))))))
540  (test "Multi headers are folded into old headers"
541        `(bar qux)
542        (header-values 'foo (headers `((foo qux))
543                                     (headers `((foo bar)))))))
544
545(define (test-unparse-headers h)
546  (call-with-output-string
547   (lambda (o)
548     (unparse-headers (headers h) o))))
549
550(test-group "Unparsers"
551  (test-group "Default unparser"
552    (test "String"
553          "Foo: bar\r\n"
554          (test-unparse-headers `((foo "bar"))))
555    (test "Multiple strings"
556          "Foo: bar, qux\r\n"
557          (test-unparse-headers `((foo "bar" "qux"))))
558    (test "Auto-quoting on commas and whitespace"
559          "Foo: \"bar, qux\", \"mooh blah\"\r\n"
560          (test-unparse-headers `((foo "bar, qux" "mooh blah"))))
561    ;; RFC 2616 2.2
562    (test "Escaping quotes"
563          "Foo: \"bar \\\" qux\", mooh\r\n"
564          (test-unparse-headers `((foo "bar \" qux" "mooh"))))
565    (test "Escaping control characters"
566          "Foo: \"bar\\\r\\\x01qux\"\r\n"
567          (test-unparse-headers `((foo "bar\r\x01qux"))))
568    ;; Unfortunately, there are no or very few HTTP implementations
569    ;; which understand that newlines can be escaped with a backslash
570    ;; in a quoted string. That's why we don't allow it.
571    ;; The user is expected to escape the newlines according to the type
572    ;; of header (URLencoding, removing the newlines from cookies, etc)
573    (test-error* "Embedded newlines throw an error"
574                 (http unencoded-header)
575                 (test-unparse-headers `((foo "bar\n\x01qux"))))
576    (test "Alist"
577          "Foo: Bar=qux, Mooh=mumble\r\n"
578          (test-unparse-headers `((foo (bar . qux) (mooh . mumble)))))
579    (test "Alist with escapes"
580          "Foo: Bar=qux, Mooh=\"mum, ble\"\r\n"
581          (test-unparse-headers `((foo (bar . "qux") (mooh . "mum, ble")))))
582    (test "URI"
583          "Foo: http://foo.com/bar;xyz?a=b\r\n"
584          (test-unparse-headers `((foo ,(uri-reference "http://foo.com/bar;xyz?a=b")))))
585    (test "Parameters"
586          "Foo: bar; qux=mooh; mumble=mutter; blah\r\n"
587          (test-unparse-headers `((foo #(bar ((qux . mooh)
588                                              (mumble . mutter)
589                                              (blah . #t)
590                                              (feh . #f))))))))
591  (test-group "Etag unparser"
592    (test "Weak tag"
593          "Etag: W/\"blah\"\r\n"
594          (test-unparse-headers `((etag (weak . "blah")))))
595    (test "Strong tag"
596          "Etag: \"blah\"\r\n"
597          (test-unparse-headers `((etag (strong . "blah")))))
598    (test "Strong tag starting with W/"
599          "Etag: \"W/blah\"\r\n"
600          (test-unparse-headers `((etag (strong . "W/blah"))))))
601  (test-group "If-match unparser"
602    (test "List of etags"
603          "If-Match: \"foo\", \"bar\", W/\"qux\"\r\n"
604          (test-unparse-headers
605           `((if-match (strong . "foo") (strong . "bar") (weak . "qux")))))
606    (test "Wildcard"
607          "If-Match: *\r\n"
608          (test-unparse-headers
609           `((if-match (strong . "foo") * (weak . "qux"))))))
610  ;; http-dates are all deserialized as rfc1123
611  (test-group "Date/time unparser"
612    (test "RFC1123 time"
613          "If-Modified-Since: Sun, 06 Nov 1994 08:49:37 GMT\r\n"
614          ;; Having to specify a vector here twice is sucky and counter-intuitive
615          (test-unparse-headers
616           `((if-modified-since #(#(37 49 08 06 10 94 0 310 #f 0) ()))))))
617  (test-group "Host/port unparser"
618    (test "No port specified"
619          "Host: foo.example.com\r\n"
620          (test-unparse-headers `((host ("foo.example.com" . #f)))))
621    (test "Different port"
622          "Host: foo.example.com:8080\r\n"
623          (test-unparse-headers `((host ("foo.example.com" . 8080))))))
624  (test-group "Product unparser"
625    (test "Product with comments"
626          "User-Agent: Mozilla (X11) Gecko/2008110501\r\n"
627          (test-unparse-headers `((user-agent (("Mozilla" #f "X11") ("Gecko" "2008110501" #f))))))
628    (test "Realistic product"
629          "User-Agent: Mozilla/5.0 (X11; U; NetBSD amd64; en-US; rv:1.9.0.3) Gecko/2008110501 Minefield/3.0.3\r\n"
630          (test-unparse-headers `((user-agent (("Mozilla" "5.0" "X11; U; NetBSD amd64; en-US; rv:1.9.0.3") ("Gecko" "2008110501" #f) ("Minefield" "3.0.3" #f)))))))
631  (test-group "Cookie unparser"
632    (test "Basic cookie"
633          "Cookie: foo=bar; $Path=/; Qux=mooh; $Unknown=something\r\n"
634          (test-unparse-headers `((cookie #(("foo" . "bar")
635                                            ((path . ,(uri-reference "/"))))
636                                          #(("Qux" . "mooh")
637                                            ((unknown . "something")))))))
638    (test "Port list"
639          "Cookie: Foo=bar; $Port=80,8080\r\n"
640          (test-unparse-headers `((cookie #(("Foo" . "bar")
641                                            ((port . (80 8080))))))))
642    (test "#t or #f values"
643          "Cookie: Foo=bar; $Port\r\n"
644          (test-unparse-headers `((cookie #(("Foo" . "bar")
645                                            ((port . #t) (domain . #f))))))))
646  (test-group "Set-Cookie unparser"
647    (test "Simple name/value pair"
648          "Set-Cookie: foo=\"bar with space\"\r\n"
649          (test-unparse-headers `((set-cookie ("foo" . "bar with space")))))
650    ;; XXX: Should intarweb remove these, or should the user code handle this?
651    ;; What if interacting with actual broken code on the other side?
652    (test "Multiple cookies with same name (CI) are all written"
653          "Set-Cookie: foo=qux\r\nSet-Cookie: Foo=bar\r\n"
654          (test-unparse-headers `((set-cookie ("foo" . "qux") ("Foo" . "bar")))))
655    (test "Cookie names preserve case"
656          "Set-Cookie: Foo=bar\r\n"
657          (test-unparse-headers `((set-cookie ("Foo" . "bar")))))
658    (test "Cookie with = signs"
659          "Set-Cookie: foo=\"bar=qux\"; Max-Age=10\r\n"
660          (test-unparse-headers `((set-cookie #(("foo" . "bar=qux") ((max-age . 10)))))))
661    (test "Comment"
662          "Set-Cookie: foo=bar; Comment=\"Hi, there!\"\r\n"
663          (test-unparse-headers `((set-cookie #(("foo" . "bar")
664                                                ((comment . "Hi, there!")))))))
665    (test "Old-style cookie expires value"
666          "Set-Cookie: foo=; Expires=Sunday, 20-Jul-08 15:23:42 GMT\r\n"
667          (test-unparse-headers `((set-cookie #(("foo" . "")
668                                                ((expires . #(42 23 15 20 6 108 0 309 #f 0))))))))   
669    (test "Secure (true)"
670          "Set-Cookie: foo=bar; Secure\r\n"
671          (test-unparse-headers `((set-cookie #(("foo" . "bar")
672                                                ((secure . #t)))))))
673    (test "Secure (false)"
674          "Set-Cookie: foo=bar\r\n"
675          (test-unparse-headers `((set-cookie #(("foo" . "bar")
676                                                ((secure . #f)))))))
677
678    (test "Path"
679          "Set-Cookie: foo=bar; Path=/blah\r\n"
680          (test-unparse-headers `((set-cookie #(("foo" . "bar")
681                                                ((path . ,(uri-reference "/blah"))
682                                                 (secure . #f)))))))) 
683  (test-group "authorization unparser"
684    (test "Basic auth"
685          "Authorization: Basic QWxpIEJhYmE6b3BlbiBzZXNhbWU=\r\n"
686          (test-unparse-headers
687           `((authorization #(basic
688                              ((username . "Ali Baba")
689                               (password . "open sesame")))))))
690    (test-error* "Basic auth with colon in username"
691                 (http username-with-colon)
692                 (test-unparse-headers
693                  `((authorization #(basic
694                                     ((username . "foo:bar")
695                                      (password . "qux")))))))
696    (test "Digest auth"
697          "Authorization: Digest username=\"Mufasa\", realm=\"testrealm@host.com\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", uri=\"/dir/index.html\", qop=\"auth\", cnonce=\"0a4f113b\", response=\"6629fae49393a05397450978507c4ef1\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\", nc=00000001, algorithm=\"md5\"\r\n"
698          (test-unparse-headers
699           `((authorization #(digest
700                              ((username . "Mufasa")
701                               (realm . "testrealm@host.com")
702                               (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
703                               (uri . ,(uri-reference "/dir/index.html"))
704                               (qop . auth)
705                               (cnonce . "0a4f113b")
706                               (response . "6629fae49393a05397450978507c4ef1")
707                               (opaque . "5ccc069c403ebaf9f0171e9517f40e41")
708                               (nc . 1)
709                               (algorithm . md5)))))))
710    (test "Custom auth"
711          "Authorization: Custom some-random-contents\r\n"
712          (parameterize ((authorization-param-subunparsers
713                          `((custom . ,(lambda (params)
714                                         (alist-ref 'contents params)))
715                            . ,(authorization-param-subparsers))))
716            (test-unparse-headers
717             `((authorization #(custom ((contents . some-random-contents)))))))))
718
719  (test-group "authenticate unparser"
720    (test-group "basic auth"
721      (test "basic"
722            "Www-Authenticate: Basic realm=\"WallyWorld\"\r\n"
723            (test-unparse-headers
724             `((www-authenticate #(basic
725                                   ((realm . "WallyWorld"))))))))
726    (test-group "digest auth"
727      (test "digest"
728            "Www-Authenticate: Digest realm=\"testrealm@host.com\", qop=\"auth,auth-int\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\"\r\n"
729            (test-unparse-headers
730             `((www-authenticate #(digest
731                                   ((realm . "testrealm@host.com")
732                                    (qop . (auth auth-int))
733                                    (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
734                                    (opaque . "5ccc069c403ebaf9f0171e9517f40e41")))))))
735      (test "domains"
736            "Www-Authenticate: Digest domain=\"/example http://foo.com/bar\"\r\n"
737            (test-unparse-headers
738             `((www-authenticate #(digest
739                                   ((domain . (,(uri-reference "/example")
740                                               ,(uri-reference "http://foo.com/bar")))))))))
741      (test "stale"
742            "Www-Authenticate: Digest realm=\"foo\", stale=TRUE\r\n"
743            (test-unparse-headers
744             `((www-authenticate #(digest
745                                   ((realm . "foo")
746                                    (stale . #t)))))))
747      (test "stale present but false"
748            "Www-Authenticate: Digest realm=\"foo\"\r\n"
749            (test-unparse-headers
750             `((www-authenticate #(digest
751                                   ((realm . "foo")
752                                    (stale . #f)))))))))
753  (test-group "Content-disposition unparser"
754    (test "Attributes are always fully quoted and filenames stripped"
755          "Content-Disposition: form-data; name=\"foo\"; filename=\"a b c\"\r\n"
756          (test-unparse-headers `((content-disposition
757                                   #(form-data ((name . "foo")
758                                                (filename . "blabla/a b c")))))))
759    (test "Size and dates are recognised correctly"
760          "Content-Disposition: inline; size=20; creation-date=\"Sun, 06 Nov 1994 08:49:37 GMT\"\r\n"
761          (test-unparse-headers `((content-disposition
762                                   #(inline ((size . 20)
763                                             (creation-date . #(37 49 08 06 10 94 0 310 #f 0))))))))))
764
765(define (test-read-request str)
766  (call-with-input-string str read-request))
767
768(test-group "Read-request"
769  (parameterize ((request-parsers `(,(lambda (line in)
770                                       (and (string=? line "foo") 'foo))
771                                    ,(lambda (line in)
772                                       (and (string=? line "bar") 'bar)))))
773    (test-error* (http unknown-protocol-line) (test-read-request "qux"))
774    (test-error* (http unknown-protocol-line) (test-read-request ""))
775    (test 'foo (test-read-request "foo"))
776    (test 'bar (test-read-request "bar")))
777  (test-group "HTTP/0.9"
778    (let ((req (test-read-request "GET /path/../to/stuff?arg1=val1&arg2=val2\r\n")))
779      (test 0 (request-major req))
780      (test 9 (request-minor req))
781      (test 'GET (request-method req))
782      ;; Path-normalized URI (dots removed)
783      (test (uri-reference "/to/stuff?arg1=val1&arg2=val2") (request-uri req))
784      (test (headers '()) (request-headers req)))
785    ; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
786    ; It only mentions it in the context of HTTP/1.x (section 5.1.1).
787    ; We obey the BNF syntax rule in 2.1:
788    ;     "literal" - Quotation marks surround literal text.
789    ;                 Unless stated otherwise, the text is case-insensitive.
790    ; Section 4.1 defines:
791    ;     Simple-Request  = "GET" SP Request-URI CRLF
792    (test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
793    (test-error "0.9 only knows GET" (test-read-request "PUT /path")))
794  (test-group "HTTP/1.0"
795    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
796      (test 1 (request-major req))
797      (test 0 (request-minor req))
798      (test 'GET (request-method req))
799      (test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
800      (test (headers '()) (request-headers req)))
801    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
802  (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
803   (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
804     (test 1 (request-major req))
805     (test 1 (request-minor req)))
806   (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
807   ; RFC 2616 5.1.1
808   (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
809   ; RFC 2616 3.1 + case-insensitivity BNF rule
810   (test "Protocol is case-insensitive" '1 (request-minor (test-read-request "GET /path htTP/1.1\r\n\r\n")))
811   ;; TODO: Test chunking
812   (test-error "Request line limit exceeded gives error"
813               (parameterize ((http-line-limit 5))
814                 (test-read-request "GET /path HTTP/1.1\r\n\r\n")))))
815
816(define (test-write-request req . outputs)
817  (call-with-output-string
818    (lambda (out)
819      (request-port-set! req out)
820      (let ((r (write-request req)))
821       (for-each (lambda (output)
822                   (display output (request-port r)))
823                 outputs)))))
824
825(test-group "Write request"
826  ;; This can also be called Simple-Request as per RFC 1945 4.1
827  ;; RFC 2616 19.6 also states we should recognise 0.9 requests, but if
828  ;; we understand those we should also be able to generate them because
829  ;; a 0.9 server does not understand 1.x requests.
830  (test-group "HTTP/0.9"
831    (let ((req (make-request major: 0 minor: 9
832                             method: 'GET
833                             uri: (uri-reference "/foo/bar.html"))))
834      (test "Always empty headers"
835            "GET /foo/bar.html\r\n"
836            (test-write-request (update-request req
837                                                headers:
838                                                (headers `((foo bar))))
839                                ""))
840      (test "Always GET"
841            "GET /foo/bar.html\r\n"
842            (test-write-request (update-request req method: 'POST)))))
843  (test-group "HTTP/1.0"
844    (let ((req (make-request major: 1 minor: 0
845                             method: 'GET
846                             uri: (uri-reference "/foo/bar.html"))))
847      (test "Headers"
848            "GET /foo/bar.html HTTP/1.0\r\nFoo: bar\r\n\r\ntest"
849            (test-write-request
850             (update-request req
851                             headers: (headers `((foo bar))))
852             "test"))
853      (test "Chunking ignored"
854            "GET /foo/bar.html HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\nfoobar"
855            (test-write-request
856             (update-request req
857                             headers: (headers `((transfer-encoding chunked))))
858             "foo" "bar"))))
859  (test-group "HTTP/1.1"
860    (let ((req (make-request major: 1 minor: 1
861                             method: 'GET
862                             uri: (uri-reference "/foo/bar.html"))))
863      (test "Headers"
864            "GET /foo/bar.html HTTP/1.1\r\nFoo: bar\r\n\r\ntest"
865            (test-write-request
866             (update-request req
867                             headers: (headers `((foo bar))))
868             "test"))
869      (test "Chunking"
870            "GET /foo/bar.html HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
871            (test-write-request
872             (update-request req
873                             headers: (headers `((transfer-encoding chunked))))
874             "foo" "1234567890")))))
875
876(define (test-read-response input-string)
877  (call-with-input-string input-string read-response))
878
879(test-group "Read response"
880  (test-group "HTTP/1.1"
881    (let ((res (test-read-response "HTTP/1.1 303 See other\r\nFoo: bar\r\n\r\nContents")))
882      (test "Version detection"
883            '(1 . 1)
884            (cons (response-major res) (response-minor res)))
885      (test "Status"
886            '(see-other 303 "See other")
887            (list (response-status res) (response-code res) (response-reason res)))
888      (test "Headers"
889            '("bar")
890            (header-values 'foo (response-headers res)))
891      (test "Contents"
892            "Contents"
893            (read-string #f (response-port res))))
894    (test-error "Response line limit exceeded gives error"
895                (parameterize ((http-line-limit 5))
896                  (test-read-response "HTTP/1.1 200 OK\r\n\r\n")))
897    (let ((res (test-read-response "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n")))
898      (test "Chunking"
899            "foo1234567890"
900            (read-string #f (response-port res)))))
901  (test-group "HTTP/1.0"
902    (let ((res (test-read-response "HTTP/1.0 303 See other\r\nFoo: bar\r\n\r\nContents")))
903      (test "Version detection"
904            '(1 . 0)
905            (cons (response-major res) (response-minor res)))
906      (test "Status"
907            '(303 . "See other")
908            (cons (response-code res) (response-reason res)))
909      (test "Headers"
910            '("bar")
911            (header-values 'foo (response-headers res)))
912      (test "Contents"
913            "Contents"
914            (read-string #f (response-port res))))
915    (let ((res (test-read-response "HTTP/1.0 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n")))
916      (test "Chunking ignored"
917            "3\r\nfoo\r\na\r\n1234567890\r\n"
918            (read-string #f (response-port res)))))
919  (test-group "HTTP/0.9"
920    (let ((res (test-read-response "Doesn't matter what's here\r\nLine 2")))
921      (test "Always OK status"
922            '(200 . "OK")
923            (cons (response-code res) (response-reason res)))
924      (test "Version detection; fallback to 0.9"
925            '(0 . 9)
926            (cons (response-major res) (response-minor res)))
927      (test "No headers"
928            (headers '()) (response-headers res))
929      (test "Contents"
930            "Doesn't matter what's here\r\nLine 2"
931            (read-string #f (response-port res))))))
932
933(define (test-write-response res . outputs)
934  (call-with-output-string
935    (lambda (out)
936      (response-port-set! res out)
937      (let ((r (write-response res)))
938       (for-each (lambda (output)
939                   (display output (response-port r)))
940                 outputs)))))
941
942(test-group "Write response"
943  (test-group "HTTP/0.9"
944    (let ((res (make-response major: 0 minor: 9
945                              code: 200 reason: "OK")))
946      (test "Headers ignored"
947            "These are the contents\r\n"
948            (test-write-response
949             (update-response res headers: (headers `((foo bar))))
950             "These are the contents\r\n"))))
951  (test-group "HTTP/1.0"
952    (let ((res (make-response major: 1 minor: 0
953                              code: 200 reason: "OK")))
954      (test "Headers used"
955            "HTTP/1.0 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
956            (test-write-response
957             (update-response res headers: (headers `((foo bar))))
958             "These are the contents\r\n"))
959      (test "Status code"
960            "HTTP/1.0 303 See other\r\n\r\nThese are the contents\r\n"
961            (test-write-response
962             (update-response res code: 303 reason: "See other")
963             "These are the contents\r\n"))
964      (test "Chunking ignored"
965            "HTTP/1.0 200 OK\r\nTransfer-Encoding: chunked\r\n\r\nfoo1234567890"
966            (test-write-response
967             (update-response
968              res
969              headers: (headers `((transfer-encoding chunked))))
970             "foo" "1234567890"))))
971  (test-group "HTTP/1.1"
972   (let ((res (make-response major: 1 minor: 1
973                             code: 200 reason: "OK")))
974     (test "Headers used"
975           "HTTP/1.1 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
976            (test-write-response
977             (update-response res headers: (headers `((foo bar))))
978             "These are the contents\r\n"))
979     (test "Status code"
980           "HTTP/1.1 303 See other\r\n\r\nThese are the contents\r\n"
981           (test-write-response
982            (update-response res code: 303 reason: "See other")
983            "These are the contents\r\n"))
984     (test "Chunking"
985           "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
986           (test-write-response
987            (update-response
988             res
989             headers: (headers `((transfer-encoding chunked))))
990            "foo" "1234567890"))))
991  (test-group "Status"
992    (let ((res (make-response major: 1 minor: 1)))
993      (test "reason and code are looked up by symbol properly"
994            "HTTP/1.1 409 Conflict\r\n\r\ntest"
995            (test-write-response (update-response res status: 'conflict)
996                                 "test"))
997      (test-error "an error is raised for unknown status codes"
998                  (update-response res status: 'unknown))
999      (test "any status can be used when code and reason are given directly"
1000            "HTTP/1.1 999 No Way\r\n\r\ntest"
1001            (test-write-response 
1002             (update-response res code: 999 reason: "No Way")
1003             "test"))
1004      (test "defaults can be parameterized"
1005            "HTTP/1.1 999 Say What\r\n\r\ntest"
1006            (parameterize ((http-status-codes
1007                            (alist-cons 'say-what (cons 999 "Say What")
1008                                        (http-status-codes))))
1009              (test-write-response (update-response res status: 'say-what)
1010                                   "test"))))))
1011
1012(test-group "Etag comparison procedures"
1013  (test-group "Weak comparison"
1014    (test-assert "Strong etag does not match list not containing it"
1015                 (not (etag-matches-weakly?
1016                       '(strong . "xyz") `((strong . "blabla")))))
1017    (test-assert "Weak etag does not match list not containing it"
1018                 (not (etag-matches-weakly?
1019                       '(weak . "xyz") `((weak . "blabla")))))
1020    (test-assert "Weak etag matches list containing it"
1021                 (etag-matches-weakly?
1022                  '(weak . "xyz") `((strong . "blabla") (weak . "xyz"))))
1023    (test-assert "Strong etag matches list containing it"
1024                 (etag-matches-weakly?
1025                  '(strong . "xyz") `((strong . "blabla") (strong . "xyz"))))
1026    (test-assert "Weak etag does not match list containing same tag but strong"
1027                 (not (etag-matches-weakly?
1028                       '(weak . "xyz") `((strong . "blabla") (strong . "xyz")))))
1029    (test-assert "Strong etag does not match list containing same tag but weak"
1030                 (not (etag-matches-weakly?
1031                       '(strong . "xyz") `((strong . "blabla") (weak . "xyz")))))
1032    (test-assert "Weak etag matches list containing wildcard"
1033                 (etag-matches-weakly?
1034                  '(weak . "xyz") `((strong . "blabla") *)))
1035    (test-assert "Strong etag matches list containing wildcard"
1036                 (etag-matches-weakly?
1037                  '(strong . "xyz") `((strong . "blabla") *))))
1038  (test-group "Strong comparison"
1039    (test-assert "Strong etag does not match list not containing it"
1040                 (not (etag-matches?
1041                       '(strong . "xyz") `((strong . "blabla")))))
1042    (test-assert "Weak etag does not match list not containing it"
1043                 (not (etag-matches?
1044                       '(weak . "xyz") `((weak . "blabla")))))
1045    (test-assert "Weak etag does *not* match list containing it"
1046                 (not (etag-matches?
1047                       '(weak . "xyz") `((strong . "blabla") (weak . "xyz")))))
1048    (test-assert "Strong etag matches list containing it"
1049                 (etag-matches?
1050                  '(strong . "xyz") `((strong . "blabla") (strong . "xyz"))))
1051    (test-assert "Weak etag does not match list containing same tag but strong"
1052                 (not (etag-matches?
1053                       '(weak . "xyz") `((strong . "blabla") (strong . "xyz")))))
1054    (test-assert "Strong etag does not match list containing same tag but weak"
1055                 (not (etag-matches?
1056                       '(strong . "xyz") `((strong . "blabla") (weak . "xyz")))))
1057    (test-assert "Weak etag matches list containing wildcard"
1058                 (etag-matches?
1059                  '(weak . "xyz") `((strong . "blabla") *)))
1060    (test-assert "Strong etag matches list containing wildcard"
1061                 (etag-matches?
1062                  '(strong . "xyz") `((strong . "blabla") *)))))
1063(test-end)
1064
1065(unless (zero? (test-failure-count)) (exit 1))
1066
1067;; TODO:
1068;; - Fix the parsing system so it's not so broken (more comfortable combinators)
1069;; - Test malformed headers
1070;; - Add parsing capability for quoted-pairs inside tokens and comments
1071;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level
Note: See TracBrowser for help on using the repository browser.