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

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

Add support for broken cookie expiry values

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