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

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

Also allow disabling of limits

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