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

Last change on this file since 15327 was 15327, checked in by sjamaan, 10 years ago

Add exception for URIs: those will probably never be quoted (but we should test with other special chars like quotes)

File size: 39.9 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-group "Headers"
25  (test-group "Single headers"
26   (parameterize ((single-headers '(foo qux))
27                  (header-parsers `((foo . ,(single identity))
28                                    (qux . ,(single identity)))))
29     (let ((headers (test-read-headers "foo: bar\r\nqux:\t   \tmooh\t   \r\n\r\n")))
30       (test "Basic test"
31             '("bar") (header-values 'foo headers))
32       ;; RFC 2616 4.2
33       (test "Extra spaces are ignored"
34             '("mooh") (header-values 'qux headers)))
35     (let ((headers (test-read-headers "foo: bar\r\n qux: mooh\r\nquux: mumble\r\n\r\n")))
36       ;; RFC 2616 2.2
37       (test "Continuation chars"
38             '("bar qux: mooh") (header-values 'foo headers)))
39     ;; Not in RFC but common behaviour - also, robustness principle
40     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\n")))
41       (test "Multiple headers for singular header types discarded"
42             '("qux") (header-values 'foo headers)))))
43  ;; All this RFC 2616 4.2
44  (test-group "Multi-headers"
45   (parameterize ((header-parsers `((foo . ,(multiple identity)))))
46     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\nquux: mumble\r\n\r\n")))
47       (test "Multiple headers"
48             '("bar" "qux") (header-values 'foo headers)))
49     (let ((headers (test-read-headers "Foo: bar\r\nFoO: qux\r\nquux: mumble\r\n\r\n")))
50       (test "Multiple headers: case insensitivity"
51             '("bar" "qux") (header-values 'foo headers)))
52     (let ((headers (test-read-headers "foo: bar, qux\r\nquux: mumble\r\n\r\n")))
53       (test "Comma-separated headers"
54             '("bar" "qux") (header-values 'foo headers)))
55     (let ((headers (test-read-headers "foo: \"ba\\\"r, qux\"\r\nfoo: mooh\r\n\r\n")))
56       (test "Quoted headers"
57             '("ba\"r, qux" "mooh") (header-values 'foo headers))))
58   ;; RFC 2616 4.5
59   ;; "Unrecognized header fields are treated as entity-header fields."
60   ;;
61   ;; RFC 2616 7.1
62   ;; "Unrecognized header fields SHOULD be ignored by the recipient and MUST be
63   ;;  forwarded by transparent proxies."
64   (let ((headers (test-read-headers "unknown: foo, bar\r\nunknown: blah\r\n\r\n")))
65     (test "Unknown headers are not parsed and put into lists"
66           '("foo, bar" "blah") (header-values 'unknown headers))))
67  (test-group "Miscellaneous"
68    (parameterize ((header-parsers `((foo . ,(multiple identity))
69                                     (bar . ,(lambda x (error "bad header"))))))
70      (test-error "Missing header contents" (test-read-headers "foo\r\n\r\n"))
71      (test-error "Bad header w/ handler" (test-read-headers "bar: x\r\n\r\n"))
72      (parameterize ((header-parse-error-handler (lambda (n c h exn) h)))
73       (test "Bad header w/o handler" #t (headers? (test-read-headers "bar: x\r\n\r\n"))))
74      ;; RFC 2616 2.2
75      ;; "The backslash character ("\") MAY be used as a single-character
76      ;; quoting mechanism only within quoted-string and comment constructs."
77      ;;     quoted-pair = "\" CHAR
78      ;; CHAR implies any char, *including* CR/LF. This is clarified by RFC 822,
79      ;; on which RFC 2616 is based.
80      ;; Apparently, even \CRLF is allowed (as opposed to \CR\LF)
81      (test "Embedded newlines"
82            '("bar\r\nqux")
83            ;; It's unclear whether we should interpret the "\r\n" as EOL
84            ;; in "\\\r\n", or whether it should be seen as an embedded \r
85            ;; followed by a \n (which is then interpreted as a literal \n?)
86            (header-values 'foo (test-read-headers "Foo: \"bar\\\r\\\nqux\""))))))
87
88(test-group "Specialized header parsers"
89  (test-group "Host/port"
90    (test "Hostname and port"
91          '(("foo.example.com" . 8080))
92          (header-values 'host (test-read-headers "Host: foo.example.com:8080")))
93    (test "Hostname, no port"
94          '(("foo.example.com" . 80))
95          (header-values 'host (test-read-headers "Host: foo.example.com"))))
96  (test-group "Quality parameter"
97   (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="))
98          (accept  (header-contents 'accept headers)))
99     ;; RFC 2616 3.6: "All transfer-coding values are case insensitive".
100     ;; This includes the parameter name (attribute) and value.
101     (test "quality value (case-insensitive)"
102           0.5 (get-param 'q (first accept) 1.0))
103     (test "quality encoding value"
104           'text/plain (get-value (first accept)))
105     (test "quality values have only three digits"
106           0.123 (get-param 'q (third accept) 1.0))
107     (test "quality values maximum is 1.0"
108           1.0 (get-param 'q (fourth accept) 1.0))
109     (test "quality values minimum is 0.0"
110           0.0 (get-param 'q (fifth accept) 1.0))
111     (test "missing quality value ok"
112           1.0 (get-param 'q (sixth accept) 1.0))))
113
114  (test-group "Symbol-parser-ci"
115    (let* ((headers (test-read-headers "Accept-Ranges: FoO")))
116      (test "Case-insensitive"
117            '(foo) (header-values 'accept-ranges headers))))
118 
119  (test-group "Symbol-parser"
120    (let* ((headers (test-read-headers "Allow: FoO, foo")))
121      (test "Case-sensitive"
122            '(FoO foo) (header-values 'allow headers))))
123
124  (test-group "Natnum-subparser"
125    (parameterize ((single-headers '(foo bar qux mooh))
126                   (header-parsers `((foo . ,(single natnum-subparser))
127                                     (bar . ,(single natnum-subparser))
128                                     (qux . ,(single natnum-subparser))
129                                     (mooh . ,(single natnum-subparser)))))
130     (let ((headers (test-read-headers "Foo: 10\r\nBar: abc\r\nQux: -10\r\nMooh: 1.6")))
131       (test "Simple test"
132             10 (header-value 'foo headers))
133       (test "No number defaults to 0"
134             0 (header-value 'bar headers))
135       (test "No negative numbers"
136             0 (header-value 'qux headers))
137       ;; This is a "feature" in the interest of the robustness principle
138       (test "Rounding of real numbers"
139             2 (header-value 'mooh headers)))))
140
141  (test-group "Cache-control-parser"
142    (let ((headers (test-read-headers "Cache-control: max-age=10, private")))
143      (test "max-age is a number"
144            '(max-age . 10) (assq 'max-age (header-values 'cache-control headers)))
145      (test "private without value"
146            '(private . #t) (assq 'private (header-values 'cache-control headers))))
147    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
148      (test "private with values"
149            '(private . (accept-encoding accept-ranges))
150            (assq 'private (header-values 'cache-control headers)))
151      (test "Acts like a multi-header"
152            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
153
154  (test-group "authorization-parser"
155    (test-group "basic auth"
156     (let ((headers (test-read-headers "Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==\r\n")))
157       (test "basic"
158             'basic
159             (header-value 'authorization headers))
160       (test "username"
161             "Aladdin"
162             (header-param 'username 'authorization headers))
163       (test "password"
164             "open sesame"
165             (header-param 'password 'authorization headers))))
166    (test-group "digest auth"
167      (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")))
168        (test "digest"
169              'digest
170              (header-value 'authorization headers))
171        (test "realm"
172              "testrealm@host.com"
173              (header-param 'realm 'authorization headers))
174        (test "nonce"
175              "dcd98b7102dd2f0e8b11d0f600bfb0c093"
176              (header-param 'nonce 'authorization headers))
177        (test "username"
178              "Mufasa"
179              (header-param 'username 'authorization headers))
180        (test "qop"
181              'auth
182              (header-param 'qop 'authorization headers))
183        (test "digest uri"
184              "/dir/index.html"
185              (uri->string (header-param 'uri 'authorization headers)))
186        (test "nonce count"
187              1
188              (header-param 'nc 'authorization headers))
189        (test "cnonce"
190              "0a4f113b"
191              (header-param 'cnonce 'authorization headers))
192        (test "response"
193              "6629fae49393a05397450978507c4ef1"
194              (header-param 'response 'authorization headers))
195        (test "opaque"
196              "5ccc069c403ebaf9f0171e9517f40e41"
197              (header-param 'opaque 'authorization headers))
198        (test "algorithm"
199              'md5
200              (header-param 'algorithm 'authorization headers)))))
201 
202  (test-group "authenticate parser"
203    (test-group "basic auth"
204      (let ((headers (test-read-headers "WWW-Authenticate: Basic realm=\"WallyWorld\"")))
205        (test "basic"
206              'basic
207              (header-value 'www-authenticate headers))
208        (test "realm"
209              "WallyWorld"
210              (header-param 'realm 'www-authenticate headers))))
211    (test-group "digest auth"
212      (let ((headers (test-read-headers "WWW-Authenticate: Digest realm=\"testrealm@host.com\", qop=\"auth, auth-int\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\"")))
213        (test "digest"
214              'digest
215              (header-value 'www-authenticate headers))
216        (test "realm"
217              "testrealm@host.com"
218              (header-param 'realm 'www-authenticate headers))
219        (test "qop"
220              '(auth auth-int)
221              (header-param 'qop 'www-authenticate headers))
222        (test "nonce"
223              "dcd98b7102dd2f0e8b11d0f600bfb0c093"
224              (header-param 'nonce 'www-authenticate headers))
225        (test "opaque"
226              "5ccc069c403ebaf9f0171e9517f40e41"
227              (header-param 'opaque 'www-authenticate headers))
228        (test "missing stale value"
229              #f
230              (header-param 'stale 'www-authenticate headers)))
231      (let ((headers (test-read-headers "WWW-Authenticate: Digest domain=\"/example http://foo.com/bar\", stale=TRUE")))
232        (test "domains"
233              '("/example" "http://foo.com/bar")
234              (map uri->string
235                   (header-param 'domain 'www-authenticate headers)))
236        (test "stale"
237              #t
238              (header-param 'stale 'www-authenticate headers)))
239      (let ((headers (test-read-headers "WWW-Authenticate: Digest stale=whatever")))
240        (test "non-true stale value"
241              #f
242              (header-param 'stale 'www-authenticate headers)))))
243 
244  (test-group "pragma-parser"
245    (let ((headers (test-read-headers "Pragma: custom-value=10, no-cache")))
246      (test "value"
247            '(custom-value . "10")
248            (assq 'custom-value (header-values 'pragma headers)))
249      (test "no value"
250            '(no-cache . #t) (assq 'no-cache (header-values 'pragma headers))))
251    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
252      (test "private with values"
253            '(private . (accept-encoding accept-ranges))
254            (assq 'private (header-values 'cache-control headers)))
255      (test "Acts like a multi-header"
256            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
257
258  ;; RFC 2616, 14.15  &  RFC 1864 (Base64)
259  (test-group "base64-parser"
260    (let ((headers (test-read-headers "Content-md5: Q2hlY2sgSW50ZWdyaXR5IQ==")))
261      (test "md5 is base64-decoded"
262            "Check Integrity!"
263            (header-value 'content-md5 headers))))
264
265  (test-group "Range-parser"
266    (let ((headers (test-read-headers "content-range: bytes 500-999/1234")))
267      (test "Simple range"
268            '(500 999 1234)
269            (header-value 'content-range headers))))
270
271  (test-group "normalized-uri"
272    (let ((headers (test-read-headers "Location: http://example.com/foo")))
273      (test "Uri"
274            (uri-reference "http://example.com/foo")
275            (header-value 'location headers)))
276    (let ((headers (test-read-headers "Location: http://example.com/foo/../bar")))
277     (test "Auto-normalization"
278           (uri-reference "http://example.com/bar")
279           (header-value 'location headers))))
280
281  (test-group "entity-tag-parser"
282    (let ((headers (test-read-headers "Etag: \"foo\"")))
283      (test "Strong tag"
284            '(strong . "foo")
285            (header-value 'etag headers)))
286    (let ((headers (test-read-headers "Etag: W/\"bar\"")))
287      (test "Weak tag"
288            '(weak . "bar")
289            (header-value 'etag headers)))
290    (let ((headers (test-read-headers "Etag: \"\"")))
291      (test "Empty tag"
292            '(strong . "")
293            (header-value 'etag headers)))
294    (let ((headers (test-read-headers "Etag: \"W/bar\"")))
295        (test "Strong tag, containing W/ prefix"
296              '(strong . "W/bar")
297              (header-value 'etag headers))))
298
299  (test-group "if-match parser"
300    (let ((headers (test-read-headers "If-match: foo")))
301      (test "Strong etag"
302            '(strong . "foo")
303            (header-value 'if-match headers)))
304    (let ((headers (test-read-headers "If-match: W/foo")))
305      (test "Weak etag"
306            '(weak . "foo")
307            (header-value 'if-match headers)))
308    (let ((headers (test-read-headers "If-match: W/foo bar")))
309      (test "Multiple etags"
310            '((weak . "foo") (strong . "bar"))
311            (header-values 'if-match headers)))
312    (let ((headers (test-read-headers "If-match: *")))
313      (test "Wildcard"
314            '*
315            (header-value 'if-match headers))))
316
317  (test-group "http-date-parser"
318    (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
319      (test "RFC1123 time"
320            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
321            (utc-time->seconds (header-value 'date headers))))
322    (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
323      (test "RFC850 time"
324            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
325            (utc-time->seconds (header-value 'date headers))))
326    (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
327      (test "asctime time"
328            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
329            (utc-time->seconds (header-value 'date headers)))))
330
331  ;; This seems a little excessive.. Maybe find a way to reduce the number
332  ;; of cases and still have a good representative test?
333  (test-group "If-Range parser"
334    (let ((headers (test-read-headers "If-Range: Sun, 06 Nov 1994 08:49:37 GMT")))
335      (test "RFC1123 time"
336            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
337            (utc-time->seconds (header-value 'if-range headers))))
338    (let ((headers (test-read-headers "If-Range: Sunday, 06-Nov-94 08:49:37 GMT")))
339      (test "RFC850 time"
340            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
341            (utc-time->seconds (header-value 'if-range headers))))
342    (let ((headers (test-read-headers "If-Range: Sun Nov  6 08:49:37 1994")))
343      (test "asctime time"
344            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
345            (utc-time->seconds (header-value 'if-range headers))))
346    (let ((headers (test-read-headers "If-Range: \"foo\"")))
347      (test "Strong Etag"
348            '(strong . "foo")
349            (header-value 'if-range headers)))
350    (let ((headers (test-read-headers "If-Range: W/\"bar\"")))
351      (test "Weak Etag"
352            '(weak . "bar")
353            (header-value 'if-range headers)))
354    (let ((headers (test-read-headers "If-Range: \"\"")))
355      (test "Empty Etag"
356            '(strong . "")
357            (header-value 'if-range headers)))
358    (let ((headers (test-read-headers "If-Range: \"W/bar\"")))
359        (test "Strong Etag, containing W/ prefix"
360              '(strong . "W/bar")
361              (header-value 'if-range headers)))    )
362
363  (test-group "Product parser"
364    (test "Simple product"
365          '(("Mozilla" "5.0" #f))
366          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla/5.0\r\n")))
367    (test "Product with comment"
368          '(("Mozilla" #f "foo"))
369          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla (foo)\r\n")))   
370    (test "Realistic product (comments, semicolons)"
371          '(("Mozilla" "5.0" "X11; U; NetBSD amd64; en-US; rv:1.9.0.3") ("Gecko" "2008110501" #f) ("Minefield" "3.0.3" #f))
372          (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"))))
373
374  (test-group "Set-Cookie-parser"
375    (let* ((headers (test-read-headers "Set-Cookie: foo=\"bar\"")))
376      (test "Simple name/value pair"
377            '(foo . "bar")
378            (get-value (first (header-contents 'set-cookie headers)))))
379    (let ((headers (test-read-headers "Set-Cookie: foo=bar=qux; max-age=10")))
380      (test "Cookie with = signs"
381            '(foo . "bar=qux")
382            (get-value (first (header-contents 'set-cookie headers)))))
383    (let* ((headers (test-read-headers "Set-Cookie: foo=bar; Comment=\"Hi, there!\", qux=mooh\r\nSet-Cookie: mumble=mutter")))
384      (test "Comment"
385            "Hi, there!"
386            (get-param 'comment
387                       (first (header-contents 'set-cookie headers))))
388      (test "Multiple cookies in one header"
389            '(qux . "mooh")
390            (get-value (second (header-contents 'set-cookie headers))))
391      (test "Multiple cookies in multiple headers"
392            '(mumble . "mutter")
393            (get-value (third (header-contents 'set-cookie headers))))
394      (test "Missing \"secure\" value"
395            #f
396            (get-param 'secure
397                       (third (header-contents 'set-cookie headers)))))
398    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sunday, 20-Jul-08 15:23:42 GMT; secure; path = / ; Port=80,8080")))
399      (test "Missing value"
400            '(foo . "")
401            (get-value (first (header-contents 'set-cookie headers))))
402      (test "Old-style cookie expires value"
403            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
404            (utc-time->seconds
405             (get-param 'expires
406                        (first (header-contents 'set-cookie headers)))))
407      (test "Secure value"
408            #t
409            (get-param 'secure
410                       (first (header-contents 'set-cookie headers))))
411      (test "Path"
412            "/"
413            (get-param 'path
414                       (first (header-contents 'set-cookie headers))))
415      (test "Port numbers"
416            '(80 8080)
417            (get-param 'port
418                       (first (header-contents 'set-cookie headers)))))
419    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sun, 20 Jul 2008 15:23:42 GMT; secure; path = / ")))
420      (test "Noncompliant syntax cookie expiry value (rfc1123)"
421            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
422            (utc-time->seconds
423             (get-param 'expires
424                        (first (header-contents 'set-cookie headers))))))
425    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sun, 20-Jul-2008 15:23:42 GMT; secure; path = / ")))
426      (test "Noncompliant syntax cookie expiry value (rfc850-like, abbrev day)"
427            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
428            (utc-time->seconds
429             (get-param 'expires
430                        (first (header-contents 'set-cookie headers)))))))
431 
432  (test-group "Cookie-parser"
433    (let* ((headers (test-read-headers "Cookie: foo=bar; $Path=/; qux=mooh; $unknown=something")))
434      (test "Multiple cookies in the same header"
435            '((foo . "bar") . (qux . "mooh"))
436            (cons
437             (get-value (first  (header-contents 'cookie headers)))
438             (get-value (second (header-contents 'cookie headers)))))
439      (test "Parameters of cookies (spaces stripped)"
440            "/"
441            (get-param 'path (first (header-contents 'cookie headers))))
442      (test "Parameters of cookies"
443            "something"
444            (get-param 'unknown (second (header-contents 'cookie headers)))))
445    (let* ((headers (test-read-headers "Cookie: $Version=\"1\"; foo=bar; $Path=/; qux=mooh; $unknown=something")))
446      (test "Version string is used for all cookies"
447            (cons 1 1)
448            (cons
449             (get-param 'version (first (header-contents 'cookie headers)))
450             (get-param 'version (second (header-contents 'cookie headers))))))))
451
452(test-group "Headers"
453  (test "Simple test"
454        `(bar qux)
455        (header-values 'foo (headers `((foo bar qux)))))
456  (test "Multi headers are folded"
457        `(bar qux)
458        (header-values 'foo (headers `((foo bar)
459                                       (foo qux)))))
460  (test "Single headers are unique"
461        `(qux)
462        (header-values 'foo (parameterize ((single-headers '(foo)))
463                                    (headers `((foo bar)
464                                               (foo qux))))))
465  (test "Extra single headers are ignored"
466        `(qux)
467        (header-values 'foo (parameterize ((single-headers '(foo)))
468                                    (headers `((foo bar qux))))))
469  (test "Parameters"
470        `((bar . qux))
471        (get-params
472         (car (header-contents 'foo (headers `((foo #(mooh ((bar . qux))))))))))
473  (test "Multi headers are folded into old headers"
474        `(bar qux)
475        (header-values 'foo (headers `((foo qux))
476                                     (headers `((foo bar)))))))
477
478(define (test-unparse-headers h)
479  (call-with-output-string
480   (lambda (o)
481     (unparse-headers (headers h) o))))
482
483(test-group "Unparsers"
484  (test-group "Default unparser"
485    (test "String"
486          "Foo: bar\r\n"
487          (test-unparse-headers `((foo "bar"))))
488    (test "Multiple strings"
489          "Foo: bar, qux\r\n"
490          (test-unparse-headers `((foo "bar" "qux"))))
491    (test "Auto-quoting on commas and whitespace"
492          "Foo: \"bar, qux\", \"mooh blah\"\r\n"
493          (test-unparse-headers `((foo "bar, qux" "mooh blah"))))
494    ;; RFC 2616 2.2
495    (test "Escaping quotes"
496          "Foo: \"bar \\\" qux\", mooh\r\n"
497          (test-unparse-headers `((foo "bar \" qux" "mooh"))))
498    (test "Escaping control characters"
499          "Foo: \"bar\\\r\\\x01qux\"\r\n"
500          (test-unparse-headers `((foo "bar\r\x01qux"))))
501    ;; Unfortunately, there are no or very few HTTP implementations
502    ;; which understand that newlines can be escaped with a backslash
503    ;; in a quoted string. That's why we don't allow it.
504    ;; The user is expected to escape the newlines according to the type
505    ;; of header (URLencoding, removing the newlines from cookies, etc)
506    (test-error* "Embedded newlines throw an error"
507                 (http unencoded-header)
508                 (test-unparse-headers `((foo "bar\n\x01qux"))))
509    (test "Alist"
510          "Foo: Bar=qux, Mooh=mumble\r\n"
511          (test-unparse-headers `((foo (bar . qux) (mooh . mumble)))))
512    (test "Alist with escapes"
513          "Foo: Bar=qux, Mooh=\"mum, ble\"\r\n"
514          (test-unparse-headers `((foo (bar . "qux") (mooh . "mum, ble")))))
515    (test "URI"
516          "Foo: http://foo.com/bar;xyz?a=b\r\n"
517          (test-unparse-headers `((foo ,(uri-reference "http://foo.com/bar;xyz?a=b")))))
518    (test "Parameters"
519          "Foo: bar; Qux=mooh; Mumble=mutter; Blah\r\n"
520          (test-unparse-headers `((foo #(bar ((qux . mooh)
521                                              (mumble . mutter)
522                                              (blah . #t)
523                                              (feh . #f))))))))
524  (test-group "Entity-tag unparser"
525    (test "Weak tag"
526          "Etag: W/blah\r\n"
527          (test-unparse-headers `((etag (weak . "blah")))))
528    (test "Strong tag"
529          "Etag: blah\r\n"
530          (test-unparse-headers `((etag (strong . "blah")))))
531    (test "Strong tag starting with W/"
532          "Etag: \"W/blah\"\r\n"
533          (test-unparse-headers `((etag (strong . "W/blah"))))))
534  ;; http-dates are all deserialized as rfc1123
535  (test-group "Date/time unparser"
536    (test "RFC1123 time"
537          "If-Modified-Since: Sun, 06 Nov 1994 08:49:37 GMT\r\n"
538          ;; Having to specify a vector here twice is sucky and counter-intuitive
539          (test-unparse-headers
540           `((if-modified-since #(#(37 49 08 06 10 94 0 310 #f 0) ()))))))
541  (test-group "Host/port unparser"
542    (test "Default port is 80, left out"
543          "Host: foo.example.com\r\n"
544          (test-unparse-headers `((host ("foo.example.com" . 80)))))
545    (test "Different port"
546          "Host: foo.example.com:8080\r\n"
547          (test-unparse-headers `((host ("foo.example.com" . 8080))))))
548  (test-group "Product unparser"
549    (test "Product with comments"
550          "User-Agent: Mozilla (X11) Gecko/2008110501\r\n"
551          (test-unparse-headers `((user-agent (("Mozilla" #f "X11") ("Gecko" "2008110501" #f))))))
552    (test "Realistic product"
553          "User-Agent: Mozilla/5.0 (X11; U; NetBSD amd64; en-US; rv:1.9.0.3) Gecko/2008110501 Minefield/3.0.3\r\n"
554          (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)))))))
555  (test-group "Cookie unparser"
556    (test "Basic cookie"
557          "Cookie: foo=bar; $Path=/; qux=mooh; $Unknown=something\r\n"
558          (test-unparse-headers `((cookie #((foo . "bar") ((path . "/")))
559                                          #((qux . "mooh") ((unknown . "something")))))))
560    (test "Port list"
561          "Cookie: foo=bar; $Port=80,8080\r\n"
562          (test-unparse-headers `((cookie #((foo . "bar")
563                                            ((port . (80 8080))))))))
564    (test "#t or #f values"
565          "Cookie: foo=bar; $Port\r\n"
566          (test-unparse-headers `((cookie #((foo . "bar")
567                                            ((port . #t) (domain . #f))))))))
568  (test-group "Authorization unparser"
569    (test "Basic auth"
570          "Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==\r\n"
571          (test-unparse-headers
572           `((authorization #(basic
573                              ((username . "Aladdin")
574                               (password . "open sesame")))))))
575    (test-error* "Basic auth with colon in username"
576                 (http username-with-colon)
577                 (test-unparse-headers
578                  `((authorization #(basic
579                                     ((username . "foo:bar")
580                                      (password . "qux")))))))
581    (test "Digest auth"
582          "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"
583          (test-unparse-headers
584           `((authorization #(digest
585                              ((username . "Mufasa")
586                               (realm . "testrealm@host.com")
587                               (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
588                               (uri . ,(uri-reference "/dir/index.html"))
589                               (qop . auth)
590                               (cnonce . "0a4f113b")
591                               (response . "6629fae49393a05397450978507c4ef1")
592                               (opaque . "5ccc069c403ebaf9f0171e9517f40e41")
593                               (nc . 1)
594                               (algorithm . md5))))))))
595
596  (test-group "authenticate unparser"
597    (test-group "basic auth"
598      (test "basic"
599            "Www-Authenticate: Basic Realm=WallyWorld\r\n"
600            (test-unparse-headers
601             `((www-authenticate #(basic
602                                   ((realm . "WallyWorld"))))))))
603    (test-group "digest auth"
604      (test "digest"
605            "Www-Authenticate: Digest Realm=testrealm@host.com, Qop=\"auth,auth-int\", Nonce=dcd98b7102dd2f0e8b11d0f600bfb0c093, Opaque=5ccc069c403ebaf9f0171e9517f40e41\r\n"
606            (test-unparse-headers
607             `((www-authenticate #(digest
608                                   ((realm . "testrealm@host.com")
609                                    (qop . (auth auth-int))
610                                    (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
611                                    (opaque . "5ccc069c403ebaf9f0171e9517f40e41")))))))
612      (test "domains"
613            "Www-Authenticate: Digest Domain=\"/example http://foo.com/bar\"\r\n"
614            (test-unparse-headers
615             `((www-authenticate #(digest
616                                   ((domain . (,(uri-reference "/example")
617                                               ,(uri-reference "http://foo.com/bar")))))))))
618      (test "stale"
619            "Www-Authenticate: Digest Realm=foo, Stale=TRUE\r\n"
620            (test-unparse-headers
621             `((www-authenticate #(digest
622                                   ((realm . "foo")
623                                    (stale . #t)))))))
624      (test "stale present but false"
625            "Www-Authenticate: Digest Realm=foo\r\n"
626            (test-unparse-headers
627             `((www-authenticate #(digest
628                                   ((realm . "foo")
629                                    (stale . #f))))))))))
630
631(define (test-read-request str)
632  (call-with-input-string str read-request))
633
634(test-group "Read-request"
635  (parameterize ((request-parsers `(,(lambda (line in)
636                                       (and (string=? line "foo") 'foo))
637                                    ,(lambda (line in)
638                                       (and (string=? line "bar") 'bar)))))
639    (test-error* (http unknown-protocol-line) (test-read-request "qux"))
640    (test-error* (http unknown-protocol-line) (test-read-request ""))
641    (test 'foo (test-read-request "foo"))
642    (test 'bar (test-read-request "bar")))
643  (test-group "HTTP/0.9"
644    (let ((req (test-read-request "GET /path/../to/stuff?arg1=val1&arg2=val2\r\n")))
645      (test 0 (request-major req))
646      (test 9 (request-minor req))
647      (test 'GET (request-method req))
648      ;; Path-normalized URI (dots removed)
649      (test (uri-reference "/to/stuff?arg1=val1&arg2=val2") (request-uri req))
650      (test (headers '()) (request-headers req)))
651    ; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
652    ; It only mentions it in the context of HTTP/1.x (section 5.1.1).
653    ; We obey the BNF syntax rule in 2.1:
654    ;     "literal" - Quotation marks surround literal text.
655    ;                 Unless stated otherwise, the text is case-insensitive.
656    ; Section 4.1 defines:
657    ;     Simple-Request  = "GET" SP Request-URI CRLF
658    (test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
659    (test-error "0.9 only knows GET" (test-read-request "PUT /path")))
660  (test-group "HTTP/1.0"
661    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
662      (test 1 (request-major req))
663      (test 0 (request-minor req))
664      (test 'GET (request-method req))
665      (test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
666      (test (headers '()) (request-headers req)))
667    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
668  (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
669   (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
670     (test 1 (request-major req))
671     (test 1 (request-minor req)))
672   (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
673   ; RFC 2616 5.1.1
674   (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
675   ; RFC 2616 3.1 + case-insensitivity BNF rule
676   (test "Protocol is case-insensitive" '1 (request-minor (test-read-request "GET /path htTP/1.1\r\n\r\n"))))) ;; TODO: Chunking
677
678(define (test-write-request req . outputs)
679  (call-with-output-string
680    (lambda (out)
681      (request-port-set! req out)
682      (let ((r (write-request req)))
683       (for-each (lambda (output)
684                   (display output (request-port r)))
685                 outputs)))))
686
687(test-group "Write request"
688  ;; This can also be called Simple-Request as per RFC 1945 4.1
689  ;; RFC 2616 19.6 also states we should recognise 0.9 requests, but if
690  ;; we understand those we should also be able to generate them because
691  ;; a 0.9 server does not understand 1.x requests.
692  (test-group "HTTP/0.9"
693    (let ((req (make-request major: 0 minor: 9
694                             method: 'GET
695                             uri: (uri-reference "/foo/bar.html"))))
696      (test "Always empty headers"
697            "GET /foo/bar.html\r\n"
698            (test-write-request (update-request req
699                                                headers:
700                                                (headers `((foo bar))))
701                                ""))
702      (test "Always GET"
703            "GET /foo/bar.html\r\n"
704            (test-write-request (update-request req method: 'POST)))))
705  (test-group "HTTP/1.0"
706    (let ((req (make-request major: 1 minor: 0
707                             method: 'GET
708                             uri: (uri-reference "/foo/bar.html"))))
709      (test "Headers"
710            "GET /foo/bar.html HTTP/1.0\r\nFoo: bar\r\n\r\ntest"
711            (test-write-request
712             (update-request req
713                             headers: (headers `((foo bar))))
714             "test"))
715      (test "Chunking ignored"
716            "GET /foo/bar.html HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\nfoobar"
717            (test-write-request
718             (update-request req
719                             headers: (headers `((transfer-encoding chunked))))
720             "foo" "bar"))))
721  (test-group "HTTP/1.1"
722    (let ((req (make-request major: 1 minor: 1
723                             method: 'GET
724                             uri: (uri-reference "/foo/bar.html"))))
725      (test "Headers"
726            "GET /foo/bar.html HTTP/1.1\r\nFoo: bar\r\n\r\ntest"
727            (test-write-request
728             (update-request req
729                             headers: (headers `((foo bar))))
730             "test"))
731      (test "Chunking"
732            "GET /foo/bar.html HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
733            (test-write-request
734             (update-request req
735                             headers: (headers `((transfer-encoding chunked))))
736             "foo" "1234567890")))))
737
738(define (test-read-response input-string)
739  (call-with-input-string input-string read-response))
740
741(test-group "Read response"
742  (test-group "HTTP/1.1"
743    (let ((res (test-read-response "HTTP/1.1 303 See other\r\nFoo: bar\r\n\r\nContents")))
744      (test "Version detection"
745            '(1 . 1)
746            (cons (response-major res) (response-minor res)))
747      (test "Status"
748            '(303 . "See other")
749            (cons (response-code res) (response-reason res)))
750      (test "Headers"
751            '("bar")
752            (header-values 'foo (response-headers res)))
753      (test "Contents"
754            "Contents"
755            (read-string #f (response-port res))))
756    (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")))
757      (test "Chunking"
758            "foo1234567890"
759            (read-string #f (response-port res)))))
760  (test-group "HTTP/1.0"
761    (let ((res (test-read-response "HTTP/1.0 303 See other\r\nFoo: bar\r\n\r\nContents")))
762      (test "Version detection"
763            '(1 . 0)
764            (cons (response-major res) (response-minor res)))
765      (test "Status"
766            '(303 . "See other")
767            (cons (response-code res) (response-reason res)))
768      (test "Headers"
769            '("bar")
770            (header-values 'foo (response-headers res)))
771      (test "Contents"
772            "Contents"
773            (read-string #f (response-port res))))
774    (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")))
775      (test "Chunking ignored"
776            "3\r\nfoo\r\na\r\n1234567890\r\n"
777            (read-string #f (response-port res)))))
778  (test-group "HTTP/0.9"
779    (let ((res (test-read-response "Doesn't matter what's here\r\nLine 2")))
780      (test "Always OK status"
781            '(200 . "OK")
782            (cons (response-code res) (response-reason res)))
783      (test "Version detection; fallback to 0.9"
784            '(0 . 9)
785            (cons (response-major res) (response-minor res)))
786      (test "No headers"
787            (headers '()) (response-headers res))
788      (test "Contents"
789            "Doesn't matter what's here\r\nLine 2"
790            (read-string #f (response-port res))))))
791
792(define (test-write-response res . outputs)
793  (call-with-output-string
794    (lambda (out)
795      (response-port-set! res out)
796      (let ((r (write-response res)))
797       (for-each (lambda (output)
798                   (display output (response-port r)))
799                 outputs)))))
800
801(test-group "Write response"
802  (test-group "HTTP/0.9"
803    (let ((res (make-response major: 0 minor: 9
804                              code: 200 reason: "OK")))
805      (test "Headers ignored"
806            "These are the contents\r\n"
807            (test-write-response
808             (update-response res headers: (headers `((foo bar))))
809             "These are the contents\r\n"))))
810  (test-group "HTTP/1.0"
811    (let ((res (make-response major: 1 minor: 0
812                              code: 200 reason: "OK")))
813      (test "Headers used"
814            "HTTP/1.0 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
815            (test-write-response
816             (update-response res headers: (headers `((foo bar))))
817             "These are the contents\r\n"))
818      (test "Status code"
819            "HTTP/1.0 303 See other\r\n\r\nThese are the contents\r\n"
820            (test-write-response
821             (update-response res code: 303 reason: "See other")
822             "These are the contents\r\n"))
823      (test "Chunking ignored"
824            "HTTP/1.0 200 OK\r\nTransfer-Encoding: chunked\r\n\r\nfoo1234567890"
825            (test-write-response
826             (update-response
827              res
828              headers: (headers `((transfer-encoding chunked))))
829             "foo" "1234567890"))))
830  (test-group "HTTP/1.1"
831   (let ((res (make-response major: 1 minor: 1
832                             code: 200 reason: "OK")))
833     (test "Headers used"
834           "HTTP/1.1 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
835            (test-write-response
836             (update-response res headers: (headers `((foo bar))))
837             "These are the contents\r\n"))
838     (test "Status code"
839           "HTTP/1.1 303 See other\r\n\r\nThese are the contents\r\n"
840           (test-write-response
841            (update-response res code: 303 reason: "See other")
842            "These are the contents\r\n"))
843     (test "Chunking"
844           "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
845           (test-write-response
846            (update-response
847             res
848             headers: (headers `((transfer-encoding chunked))))
849            "foo" "1234567890")))))
850
851;; TODO:
852;; - Fix the parsing system so it's not so broken (more comfortable combinators)
853;; - Test malformed headers
854;; - Add parsing capability for quoted-pairs inside tokens and comments
855;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level
Note: See TracBrowser for help on using the repository browser.