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

Last change on this file since 11592 was 11592, checked in by sjamaan, 12 years ago

Rename set-header-contents! to update-header-contents! and create a nondestructive variant of it too
Fix definitions for a few header parsers

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