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

Last change on this file since 15089 was 15089, checked in by sjamaan, 11 years ago

Update cookie-parser so it removes the stupid dollar signs

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