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

Last change on this file since 11732 was 11732, checked in by sjamaan, 13 years ago

Make parsers/unparsers list complete and rearrange some code

File size: 16.0 KB
Line 
1(require-extension test extras regex srfi-1)
2
3(load "../intarweb.scm")
4
5(import intarweb)
6
7(define (test-read-request str)
8  (call-with-input-string str
9    (lambda (in)
10      (read-request in))))
11
12(define-syntax test-error*
13  (syntax-rules ()
14    ((_ ?msg (?error-type ...) ?expr)
15     (let-syntax ((expression:
16                   (syntax-rules ()
17                     ((_ ?expr)
18                      (condition-case (begin ?expr "<no error thrown>")
19                                      ((?error-type ...) '(?error-type ...))
20                                      (exn () (##sys#slot exn 1)))))))
21       (test ?msg '(?error-type ...) (expression: ?expr))))
22    ((_ ?msg ?error-type ?expr)
23     (test-error* ?msg (?error-type) ?expr))
24    ((_ ?error-type ?expr)
25     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
26
27(test-group "Request line"
28  (parameterize ((request-parsers `(,(lambda (line in)
29                                       (and (string=? line "foo") 'foo))
30                                    ,(lambda (line in)
31                                       (and (string=? line "bar") 'bar)))))
32    (test-error* (http unknown-protocol) (test-read-request "qux"))
33    (test-error* (http unknown-protocol) (test-read-request ""))
34    (test 'foo (test-read-request "foo"))
35    (test 'bar (test-read-request "bar")))
36  (test-group "HTTP/0.9"
37    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2\r\n")))
38      (test 0 (request-major-version req))
39      (test 9 (request-minor-version req))
40      (test 'GET (request-method req))
41      (test "/path/to/stuff?arg1=val1&arg2=val2" (request-uri req))
42      (test '() (request-headers req)))
43    ; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
44    ; It only mentions it in the context of HTTP/1.x (section 5.1.1).
45    ; We obey the BNF syntax rule in 2.1:
46    ;     "literal" - Quotation marks surround literal text.
47    ;                 Unless stated otherwise, the text is case-insensitive.
48    ; Section 4.1 defines:
49    ;     Simple-Request  = "GET" SP Request-URI CRLF
50    (test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
51    (test-error "0.9 only knows GET" (test-read-request "PUT /path")))
52  (test-group "HTTP/1.0"
53    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
54      (test 1 (request-major-version req))
55      (test 0 (request-minor-version req))
56      (test 'GET (request-method req))
57      (test "/path/to/stuff?arg1=val1&arg2=val2" (request-uri req))
58      (test '() (request-headers req)))
59    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
60  (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
61   (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
62     (test 1 (request-major-version req))
63     (test 1 (request-minor-version req)))
64   (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
65   ; RFC 2616 5.1.1
66   (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
67   ; RFC 2616 3.1 + case-insensitivity BNF rule
68   (test "Protocol is case-insensitive" '1 (request-minor-version (test-read-request "GET /path htTP/1.1\r\n\r\n")))))
69
70(define (test-read-headers str)
71  (call-with-input-string str
72    (lambda (in)
73      (read-headers in))))
74
75(test-group "Headers"
76  (test-group "Single headers"
77   (parameterize ((single-headers '(foo qux))
78                  (header-parsers `((foo . ,(single identity))
79                                    (qux . ,(single identity)))))
80     (let ((headers (test-read-headers "foo: bar\r\nqux:\t   \tmooh\t   \r\n\r\n")))
81       (test "Basic test"
82             '("bar") (get-header-values 'foo headers))
83       ;; RFC 2616 4.2
84       (test "Extra spaces are ignored"
85             '("mooh") (get-header-values 'qux headers)))
86     (let ((headers (test-read-headers "foo: bar\r\n qux: mooh\r\nquux: mumble\r\n\r\n")))
87       ;; RFC 2616 2.2
88       (test "Continuation chars"
89             '("bar qux: mooh") (get-header-values 'foo headers)))
90     ;; Not in RFC but common behaviour - also, robustness principle
91     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\n")))
92       (test "Multiple headers for singular header types discarded"
93             '("qux") (get-header-values 'foo headers)))))
94  ;; All this RFC 2616 4.2
95  (test-group "Multi-headers"
96   (parameterize ((header-parsers `((foo . ,(multiple identity)))))
97     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\nquux: mumble\r\n\r\n")))
98       (test "Multiple headers"
99             '("bar" "qux") (get-header-values 'foo headers)))
100     (let ((headers (test-read-headers "Foo: bar\r\nFoO: qux\r\nquux: mumble\r\n\r\n")))
101       (test "Multiple headers: case insensitivity"
102             '("bar" "qux") (get-header-values 'foo headers)))
103     (let ((headers (test-read-headers "foo: bar, qux\r\nquux: mumble\r\n\r\n")))
104       (test "Comma-separated headers"
105             '("bar" "qux") (get-header-values 'foo headers)))
106     (let ((headers (test-read-headers "foo: \"ba\\\"r, qux\"\r\nfoo: mooh\r\n\r\n")))
107       (test "Quoted headers"
108             '("ba\"r, qux" "mooh") (get-header-values 'foo headers))))
109   ;; RFC 2616 4.5
110   ;; "Unrecognized header fields are treated as entity-header fields."
111   ;;
112   ;; RFC 2616 7.1
113   ;; "Unrecognized header fields SHOULD be ignored by the recipient and MUST be
114   ;;  forwarded by transparent proxies."
115   (let ((headers (test-read-headers "unknown: foo, bar\r\nunknown: blah\r\n\r\n")))
116     (test "Unknown headers are not parsed and put into lists"
117           '("foo, bar" "blah") (get-header-values 'unknown headers))))
118  (test-group "Miscellaneous"
119    (test-error "Missing header contents" (test-read-headers "foo\r\n\r\n"))))
120
121(test-group "Specialized header parsers"
122  (test-group "Quality parameter"
123   (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="))
124          (accept  (get-header-contents 'accept headers)))
125     ;; RFC 2616 3.6: "All transfer-coding values are case insensitive".
126     ;; This includes the parameter name (attribute) and value.
127     (test "Explicit quality value (case-insensitive)"
128           0.5 (get-quality (first accept)))
129     (test "Explicit quality encoding value"
130           'text/plain (get-value (first accept)))
131     ;; RFC 2616 3.9
132     (test "Implicit quality value"
133           1.0 (get-quality (second accept)))
134     (test "Implicit quality encoding value"
135           'text/html (get-value (second accept)))
136     (test "Quality values have only three digits"
137           0.123 (get-quality (third accept)))
138     (test "Quality values maximum is 1.0"
139           1.0 (get-quality (fourth accept)))
140     (test "Quality values minimum is 0.0"
141           0.0 (get-quality (fifth accept)))
142     (test "Missing quality value ok"
143           1.0 (get-quality (sixth accept)))))
144
145  (test-group "Symbol-parser-ci"
146    (let* ((headers (test-read-headers "Accept-Ranges: FoO")))
147      (test "Case-insensitive"
148            '(foo) (get-header-values 'accept-ranges headers))))
149 
150  (test-group "Symbol-parser"
151    (let* ((headers (test-read-headers "Allow: FoO, foo")))
152      (test "Case-sensitive"
153            '(FoO foo) (get-header-values 'allow headers))))
154
155  (test-group "Natnum-parser"
156    (parameterize ((single-headers '(foo bar qux mooh))
157                   (header-parsers `((foo . ,(single natnum-parser))
158                                     (bar . ,(single natnum-parser))
159                                     (qux . ,(single natnum-parser))
160                                     (mooh . ,(single natnum-parser)))))
161     (let ((headers (test-read-headers "Foo: 10\r\nBar: abc\r\nQux: -10\r\nMooh: 1.6")))
162       (test "Simple test"
163             10 (get-value (car (get-header-contents 'foo headers))))
164       (test "No number defaults to 0"
165             0 (get-value (car (get-header-contents 'bar headers))))
166       (test "No negative numbers"
167             0 (get-value (car (get-header-contents 'qux headers))))
168       ;; This is a "feature" in the interest of the robustness principle
169       (test "Rounding of real numbers"
170             2 (get-value (car (get-header-contents 'mooh headers)))))))
171
172  (test-group "Cache-control-parser"
173    (let ((headers (test-read-headers "Cache-control: max-age=10, private")))
174      (test "max-age is a number"
175            '(max-age . 10) (get-value (header-list-ref 'max-age (get-header-contents 'cache-control headers))))
176      (test "private without value"
177            '(private . #t) (get-value (header-list-ref 'private (get-header-contents 'cache-control headers)))))
178    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
179      (test "private with values"
180            '(private . (accept-encoding accept-ranges))
181            (get-value (header-list-ref 'private (get-header-contents 'cache-control headers))))
182      (test "Acts like a multi-header"
183            '(must-revalidate . #t) (get-value (header-list-ref 'must-revalidate (get-header-contents 'cache-control headers))))))
184
185  ;; RFC 2616, 14.15
186  ;; Also: RFC 1864 (Base64) and RF1321 (MD5)
187  ;; XXX TODO: See if binary strings are useful with the MD5 egg, otherwise
188  ;; we need an additional decoding step
189  (test-group "md5-parser"
190    (let ((headers (test-read-headers "Content-md5: Q2hlY2sgSW50ZWdyaXR5IQ==")))
191      (test "md5 is base64-decoded"
192            "Check Integrity!"
193            (get-value (car (get-header-contents 'content-md5 headers))))))
194
195  (test-group "Range-parser"
196    (let ((headers (test-read-headers "content-range: bytes 500-999/1234")))
197      (test "Simple range"
198            '(500 999 1234)
199            (get-value (car (get-header-contents 'content-range headers))))))
200
201  ;; XXX SRFI-19!
202  (test-group "http-time-parser"
203    (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
204      (test "RFC822/RFC1123 time"
205            0
206            (get-value (car (get-header-contents 'date headers)))))
207    (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
208      (test "RFC850 time"
209            0
210            (get-value (car (get-header-contents 'date headers)))))
211    (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
212      (test "asctime time"
213            0
214            (get-value (car (get-header-contents 'date headers))))))
215
216  (test-group "entity-tag-parser"
217    (let ((headers (test-read-headers "Etag: \"foo\"")))
218      (test "Strong tag"
219            '(strong . "foo")
220            (get-value (car (get-header-contents 'etag headers)))))
221    (let ((headers (test-read-headers "Etag: W/\"bar\"")))
222      (test "Weak tag"
223            '(weak . "bar")
224            (get-value (car (get-header-contents 'etag headers)))))
225    (let ((headers (test-read-headers "Etag: \"\"")))
226      (test "Empty tag"
227            '(strong . "")
228            (get-value (car (get-header-contents 'etag headers)))))
229    ;; XXX, is this test important to pass?
230    #;(let ((headers (test-read-headers "Etag: \"W/bar\"")))
231        (test "Strong tag, containing W/ prefix"
232              '(strong . "W/foo")
233              (get-value (car (get-header-contents 'etag headers))))))
234
235  (test-group "Set-Cookie-parser"
236    (let* ((headers (test-read-headers "Set-Cookie: foo=\"bar\"")))
237      (test "Simple name/value pair"
238            '("foo" . "bar")
239            (get-value (first (get-header-contents 'set-cookie headers)))))
240    (let ((headers (test-read-headers "Set-Cookie: foo=bar=qux; max-age=10")))
241      (test "Cookie with = signs"
242            '("foo" . "bar=qux")
243            (get-value (first (get-header-contents 'set-cookie headers)))))
244    (let* ((headers (test-read-headers "Set-Cookie: foo=bar; Comment=\"Hi, there!\", qux=mooh\r\nSet-Cookie: mumble=mutter")))
245      (test "Comment"
246            "Hi, there!"
247            (get-param 'comment
248                       (first (get-header-contents 'set-cookie headers))))
249      (test "Multiple cookies in one header"
250            '("qux" . "mooh")
251            (get-value (second (get-header-contents 'set-cookie headers))))
252      (test "Multiple cookies in multiple headers"
253            '("mumble" . "mutter")
254            (get-value (third (get-header-contents 'set-cookie headers))))
255      (test "Missing \"secure\" value"
256            #f
257            (get-param 'secure
258                       (third (get-header-contents 'set-cookie headers)))))
259    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sunday, 20-Jul-08 15:23:42 GMT; secure; path = / ")))
260      (test "Missing value"
261            '("foo" . "")
262            (get-value (first (get-header-contents 'set-cookie headers))))
263      (test "Old-style cookie expires value"
264            ;; Should use something like
265            ;; (string->date foo "~A, ~d-~b-~y ~H:~M:~S ~z") in an "en" locale
266            0
267            (get-param 'expires
268                       (first (get-header-contents 'set-cookie headers))))
269      (test "Secure value"
270            #t
271            (get-param 'secure
272                       (first (get-header-contents 'set-cookie headers))))
273      (test "Path"
274            "/"
275            (get-param 'path
276                       (first (get-header-contents 'set-cookie headers))))))
277 
278  (test-group "Cookie-parser"
279    (let* ((headers (test-read-headers "Cookie: foo=bar; $Path=/; qux=mooh; $unknown=something")))
280      (test "Multiple cookies in the same header"
281            '(("foo" . "bar") . ("qux" . "mooh"))
282            (cons
283             (get-value (first  (get-header-contents 'cookie headers)))
284             (get-value (second (get-header-contents 'cookie headers)))))
285      (test "Parameters of cookies (spaces stripped)"
286            "/"
287            (get-param '$path (first (get-header-contents 'cookie headers))))
288      (test "Parameters of cookies"
289            "something"
290            (get-param '$unknown (second (get-header-contents 'cookie headers)))))
291    (let* ((headers (test-read-headers "Cookie: $Version=\"1\"; foo=bar; $Path=/; qux=mooh; $unknown=something")))
292      (test "Version string is used for all cookies"
293            (cons 1 1)
294            (cons
295             (get-param '$version (first (get-header-contents 'cookie headers)))
296             (get-param '$version (second (get-header-contents 'cookie headers))))))))
297
298(test-group "Make-headers"
299  (test "Simple test"
300        `(bar qux)
301        (get-header-values 'foo (make-headers `((foo bar qux)))))
302  (test "Multi headers are folded"
303        `(bar qux)
304        (get-header-values 'foo (make-headers `((foo bar)
305                                                  (foo qux)))))
306  (test "Single headers are unique"
307        `(qux)
308        (get-header-values 'foo (parameterize ((single-headers '(foo)))
309                                    (make-headers `((foo bar)
310                                                    (foo qux))))))
311  (test "Extra single headers are ignored"
312        `(qux)
313        (get-header-values 'foo (parameterize ((single-headers '(foo)))
314                                    (make-headers `((foo bar qux))))))
315  (test "Parameters"
316        `((bar . qux))
317        (get-params
318         (car (get-header-contents 'foo (make-headers `((foo #(mooh ((bar . qux))))))))))
319  (test "Multi headers are folded into old headers"
320        `(bar qux)
321        (get-header-values 'foo (make-headers `((foo qux))
322                                                (make-headers `((foo bar)))))))
323
324(define (test-unparse-headers h)
325  (call-with-output-string
326   (lambda (o)
327     (unparse-headers (make-headers h) o))))
328
329(test-group "Unparsers"
330  (test-group "Default unparser"
331    (test "String"
332          "Foo: bar\r\n"
333          (test-unparse-headers `((foo "bar"))))
334    (test "Multiple strings"
335          "Foo: bar, qux\r\n"
336          (test-unparse-headers `((foo "bar" "qux"))))
337    (test "Auto-quoting"
338          "Foo: \"bar, qux\"\r\n"
339          (test-unparse-headers `((foo "bar, qux"))))
340    (test "Escaping"
341          "Foo: \"bar \\\" qux\", mooh\r\n"
342          (test-unparse-headers `((foo "bar \" qux" "mooh"))))
343    (test "Alist"
344          "Foo: bar=qux, mooh=mumble\r\n"
345          (test-unparse-headers `((foo (bar . qux) (mooh . mumble)))))
346    (test "Parameters"
347          "Foo: bar; qux=mooh; mumble=mutter; blah\r\n"
348          (test-unparse-headers `((foo #(bar ((qux . mooh)
349                                              (mumble . mutter)
350                                              (blah . #t)
351                                              (feh . #f)))))))))
352
353;(define (test-write-response ))
354
355#;(test-group "write-response"
356  (test-group "HTTP/0.9"
357    (test ""
358          ())))
359
360;; TODO:
361;; - Implement comments parsing (better: a sane parsing system!)
362;; - Test malformed headers
363;; - When headers are malformed, what to do? Return #f for value and let
364;;    single/multiple discard them? Throw an exception?
Note: See TracBrowser for help on using the repository browser.