Context Navigation

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

Last change on this file since 14574 was 14574, checked in by sjamaan, 11 years ago
Rearrange code so it has a more logical source order. Rename all subparsers so they end in -subparser (finding bugs in the process). Fix export list
File size: 30.3 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 "http-date-parser"
210	(let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
211	(test "RFC1123 time"
212	(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
213	(utc-time->seconds (header-value 'date headers))))
214	(let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
215	(test "RFC850 time"
216	(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
217	(utc-time->seconds (header-value 'date headers))))
218	(let ((headers (test-read-headers "Date: Sun Nov 6 08:49:37 1994")))
219	(test "asctime time"
220	(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
221	(utc-time->seconds (header-value 'date headers)))))
222
223	;; This seems a little excessive.. Maybe find a way to reduce the number
224	;; of cases and still have a good representative test?
225	(test-group "If-Range parser"
226	(let ((headers (test-read-headers "If-Range: Sun, 06 Nov 1994 08:49:37 GMT")))
227	(test "RFC1123 time"
228	(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
229	(utc-time->seconds (header-value 'if-range headers))))
230	(let ((headers (test-read-headers "If-Range: Sunday, 06-Nov-94 08:49:37 GMT")))
231	(test "RFC850 time"
232	(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
233	(utc-time->seconds (header-value 'if-range headers))))
234	(let ((headers (test-read-headers "If-Range: Sun Nov 6 08:49:37 1994")))
235	(test "asctime time"
236	(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
237	(utc-time->seconds (header-value 'if-range headers))))
238	(let ((headers (test-read-headers "If-Range: \"foo\"")))
239	(test "Strong Etag"
240	'(strong . "foo")
241	(header-value 'if-range headers)))
242	(let ((headers (test-read-headers "If-Range: W/\"bar\"")))
243	(test "Weak Etag"
244	'(weak . "bar")
245	(header-value 'if-range headers)))
246	(let ((headers (test-read-headers "If-Range: \"\"")))
247	(test "Empty Etag"
248	'(strong . "")
249	(header-value 'if-range headers)))
250	(let ((headers (test-read-headers "If-Range: \"W/bar\"")))
251	(test "Strong Etag, containing W/ prefix"
252	'(strong . "W/bar")
253	(header-value 'if-range headers))) )
254
255	(test-group "Product parser"
256	(test "Simple product"
257	'(("Mozilla" "5.0" #f))
258	(header-value 'user-agent (test-read-headers "User-Agent: Mozilla/5.0\r\n")))
259	(test "Product with comment"
260	'(("Mozilla" #f "foo"))
261	(header-value 'user-agent (test-read-headers "User-Agent: Mozilla (foo)\r\n")))
262	(test "Realistic product (comments, semicolons)"
263	'(("Mozilla" "5.0" "X11; U; NetBSD amd64; en-US; rv:1.9.0.3") ("Gecko" "2008110501" #f) ("Minefield" "3.0.3" #f))
264	(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"))))
265
266	(test-group "Set-Cookie-parser"
267	(let* ((headers (test-read-headers "Set-Cookie: foo=\"bar\"")))
268	(test "Simple name/value pair"
269	'("foo" . "bar")
270	(get-value (first (header-contents 'set-cookie headers)))))
271	(let ((headers (test-read-headers "Set-Cookie: foo=bar=qux; max-age=10")))
272	(test "Cookie with = signs"
273	'("foo" . "bar=qux")
274	(get-value (first (header-contents 'set-cookie headers)))))
275	(let* ((headers (test-read-headers "Set-Cookie: foo=bar; Comment=\"Hi, there!\", qux=mooh\r\nSet-Cookie: mumble=mutter")))
276	(test "Comment"
277	"Hi, there!"
278	(get-param 'comment
279	(first (header-contents 'set-cookie headers))))
280	(test "Multiple cookies in one header"
281	'("qux" . "mooh")
282	(get-value (second (header-contents 'set-cookie headers))))
283	(test "Multiple cookies in multiple headers"
284	'("mumble" . "mutter")
285	(get-value (third (header-contents 'set-cookie headers))))
286	(test "Missing \"secure\" value"
287	#f
288	(get-param 'secure
289	(third (header-contents 'set-cookie headers)))))
290	(let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sunday, 20-Jul-08 15:23:42 GMT; secure; path = / ")))
291	(test "Missing value"
292	'("foo" . "")
293	(get-value (first (header-contents 'set-cookie headers))))
294	(test "Old-style cookie expires value"
295	(utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
296	(utc-time->seconds
297	(get-param 'expires
298	(first (header-contents 'set-cookie headers)))))
299	(test "Secure value"
300	#t
301	(get-param 'secure
302	(first (header-contents 'set-cookie headers))))
303	(test "Path"
304	"/"
305	(get-param 'path
306	(first (header-contents 'set-cookie headers))))))
307
308	(test-group "Cookie-parser"
309	(let* ((headers (test-read-headers "Cookie: foo=bar; $Path=/; qux=mooh; $unknown=something")))
310	(test "Multiple cookies in the same header"
311	'(("foo" . "bar") . ("qux" . "mooh"))
312	(cons
313	(get-value (first (header-contents 'cookie headers)))
314	(get-value (second (header-contents 'cookie headers)))))
315	(test "Parameters of cookies (spaces stripped)"
316	"/"
317	(get-param '$path (first (header-contents 'cookie headers))))
318	(test "Parameters of cookies"
319	"something"
320	(get-param '$unknown (second (header-contents 'cookie headers)))))
321	(let* ((headers (test-read-headers "Cookie: $Version=\"1\"; foo=bar; $Path=/; qux=mooh; $unknown=something")))
322	(test "Version string is used for all cookies"
323	(cons 1 1)
324	(cons
325	(get-param '$version (first (header-contents 'cookie headers)))
326	(get-param '$version (second (header-contents 'cookie headers))))))))
327
328	(test-group "Headers"
329	(test "Simple test"
330	`(bar qux)
331	(header-values 'foo (headers `((foo bar qux)))))
332	(test "Multi headers are folded"
333	`(bar qux)
334	(header-values 'foo (headers `((foo bar)
335	(foo qux)))))
336	(test "Single headers are unique"
337	`(qux)
338	(header-values 'foo (parameterize ((single-headers '(foo)))
339	(headers `((foo bar)
340	(foo qux))))))
341	(test "Extra single headers are ignored"
342	`(qux)
343	(header-values 'foo (parameterize ((single-headers '(foo)))
344	(headers `((foo bar qux))))))
345	(test "Parameters"
346	`((bar . qux))
347	(get-params
348	(car (header-contents 'foo (headers `((foo #(mooh ((bar . qux))))))))))
349	(test "Multi headers are folded into old headers"
350	`(bar qux)
351	(header-values 'foo (headers `((foo qux))
352	(headers `((foo bar)))))))
353
354	(define (test-unparse-headers h)
355	(call-with-output-string
356	(lambda (o)
357	(unparse-headers (headers h) o))))
358
359	(test-group "Unparsers"
360	(test-group "Default unparser"
361	(test "String"
362	"Foo: bar\r\n"
363	(test-unparse-headers `((foo "bar"))))
364	(test "Multiple strings"
365	"Foo: bar, qux\r\n"
366	(test-unparse-headers `((foo "bar" "qux"))))
367	(test "Auto-quoting on commas and whitespace"
368	"Foo: \"bar, qux\", \"mooh blah\"\r\n"
369	(test-unparse-headers `((foo "bar, qux" "mooh blah"))))
370	;; RFC 2616 2.2
371	(test "Escaping quotes"
372	"Foo: \"bar \\\" qux\", mooh\r\n"
373	(test-unparse-headers `((foo "bar \" qux" "mooh"))))
374	(test "Escaping control characters"
375	"Foo: \"bar\\\r\\\x01qux\"\r\n"
376	(test-unparse-headers `((foo "bar\r\x01qux"))))
377	;; Unfortunately, there are no or very few HTTP implementations
378	;; which understand that newlines can be escaped with a backslash
379	;; in a quoted string. That's why we don't allow it.
380	;; The user is expected to escape the newlines according to the type
381	;; of header (URLencoding, removing the newlines from cookies, etc)
382	(test-error* "Embedded newlines throw an error"
383	(http unencoded-header)
384	(test-unparse-headers `((foo "bar\n\x01qux"))))
385	(test "Alist"
386	"Foo: Bar=qux, Mooh=mumble\r\n"
387	(test-unparse-headers `((foo (bar . qux) (mooh . mumble)))))
388	(test "Alist with escapes"
389	"Foo: Bar=qux, Mooh=\"mum, ble\"\r\n"
390	(test-unparse-headers `((foo (bar . "qux") (mooh . "mum, ble")))))
391	(test "URI"
392	"Foo: http://foo.com/bar\r\n"
393	(test-unparse-headers `((foo ,(uri-reference "http://foo.com/bar")))))
394	(test "Parameters"
395	"Foo: bar; Qux=mooh; Mumble=mutter; Blah\r\n"
396	(test-unparse-headers `((foo #(bar ((qux . mooh)
397	(mumble . mutter)
398	(blah . #t)
399	(feh . #f))))))))
400	(test-group "Entity-tag unparser"
401	(test "Weak tag"
402	"Etag: W/blah\r\n"
403	(test-unparse-headers `((etag (weak . "blah")))))
404	(test "Strong tag"
405	"Etag: blah\r\n"
406	(test-unparse-headers `((etag (strong . "blah")))))
407	(test "Strong tag starting with W/"
408	"Etag: \"W/blah\"\r\n"
409	(test-unparse-headers `((etag (strong . "W/blah"))))))
410	;; http-dates are all deserialized as rfc1123
411	(test-group "Date/time unparser"
412	(test "RFC1123 time"
413	"If-Modified-Since: Sun, 06 Nov 1994 08:49:37 GMT\r\n"
414	;; Having to specify a vector here twice is sucky and counter-intuitive
415	(test-unparse-headers
416	`((if-modified-since #(#(37 49 08 06 10 94 0 310 #f 0) ()))))))
417	(test-group "Host/port unparser"
418	(test "Default port is 80, left out"
419	"Host: foo.example.com\r\n"
420	(test-unparse-headers `((host ("foo.example.com" . 80)))))
421	(test "Different port"
422	"Host: foo.example.com:8080\r\n"
423	(test-unparse-headers `((host ("foo.example.com" . 8080))))))
424	(test-group "Product unparser"
425	(test "Product with comments"
426	"User-Agent: Mozilla (X11) Gecko/2008110501\r\n"
427	(test-unparse-headers `((user-agent (("Mozilla" #f "X11") ("Gecko" "2008110501" #f))))))
428	(test "Realistic product"
429	"User-Agent: Mozilla/5.0 (X11; U; NetBSD amd64; en-US; rv:1.9.0.3) Gecko/2008110501 Minefield/3.0.3\r\n"
430	(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))))))))
431
432	(define (test-read-request str)
433	(call-with-input-string str
434	(lambda (in)
435	(read-request in))))
436
437	(test-group "Read-request"
438	(parameterize ((request-parsers `(,(lambda (line in)
439	(and (string=? line "foo") 'foo))
440	,(lambda (line in)
441	(and (string=? line "bar") 'bar)))))
442	(test-error* (http unknown-protocol-line) (test-read-request "qux"))
443	(test-error* (http unknown-protocol-line) (test-read-request ""))
444	(test 'foo (test-read-request "foo"))
445	(test 'bar (test-read-request "bar")))
446	(test-group "HTTP/0.9"
447	(let ((req (test-read-request "GET /path/../to/stuff?arg1=val1&arg2=val2\r\n")))
448	(test 0 (request-major req))
449	(test 9 (request-minor req))
450	(test 'GET (request-method req))
451	;; Path-normalized URI (dots removed)
452	(test (uri-reference "/to/stuff?arg1=val1&arg2=val2") (request-uri req))
453	(test (headers '()) (request-headers req)))
454	; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
455	; It only mentions it in the context of HTTP/1.x (section 5.1.1).
456	; We obey the BNF syntax rule in 2.1:
457	; "literal" - Quotation marks surround literal text.
458	; Unless stated otherwise, the text is case-insensitive.
459	; Section 4.1 defines:
460	; Simple-Request = "GET" SP Request-URI CRLF
461	(test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
462	(test-error "0.9 only knows GET" (test-read-request "PUT /path")))
463	(test-group "HTTP/1.0"
464	(let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
465	(test 1 (request-major req))
466	(test 0 (request-minor req))
467	(test 'GET (request-method req))
468	(test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
469	(test (headers '()) (request-headers req)))
470	(test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
471	(test-group "HTTP/1.1" ; No need to test all things we test for 1.0
472	(let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
473	(test 1 (request-major req))
474	(test 1 (request-minor req)))
475	(test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
476	; RFC 2616 5.1.1
477	(test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
478	; RFC 2616 3.1 + case-insensitivity BNF rule
479	(test "Protocol is case-insensitive" '1 (request-minor (test-read-request "GET /path htTP/1.1\r\n\r\n"))))) ;; TODO: Chunking
480
481	(define (test-write-request req . outputs)
482	(call-with-output-string
483	(lambda (out)
484	(request-port-set! req out)
485	(let ((r (write-request req)))
486	(for-each (lambda (output)
487	(display output (request-port r)))
488	outputs)))))
489
490	(test-group "Write request"
491	;; This can also be called Simple-Request as per RFC 1945 4.1
492	;; RFC 2616 19.6 also states we should recognise 0.9 requests, but if
493	;; we understand those we should also be able to generate them because
494	;; a 0.9 server does not understand 1.x requests.
495	(test-group "HTTP/0.9"
496	(let ((req (make-request major: 0 minor: 9
497	method: 'GET
498	uri: (uri-reference "/foo/bar.html"))))
499	(test "Always empty headers"
500	"GET /foo/bar.html\r\n"
501	(test-write-request (update-request req
502	headers:
503	(headers `((foo bar))))
504	""))
505	(test "Always GET"
506	"GET /foo/bar.html\r\n"
507	(test-write-request (update-request req method: 'POST)))))
508	(test-group "HTTP/1.0"
509	(let ((req (make-request major: 1 minor: 0
510	method: 'GET
511	uri: (uri-reference "/foo/bar.html"))))
512	(test "Headers"
513	"GET /foo/bar.html HTTP/1.0\r\nFoo: bar\r\n\r\ntest"
514	(test-write-request
515	(update-request req
516	headers: (headers `((foo bar))))
517	"test"))
518	(test "Chunking ignored"
519	"GET /foo/bar.html HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\nfoobar"
520	(test-write-request
521	(update-request req
522	headers: (headers `((transfer-encoding chunked))))
523	"foo" "bar"))))
524	(test-group "HTTP/1.1"
525	(let ((req (make-request major: 1 minor: 1
526	method: 'GET
527	uri: (uri-reference "/foo/bar.html"))))
528	(test "Headers"
529	"GET /foo/bar.html HTTP/1.1\r\nFoo: bar\r\n\r\ntest"
530	(test-write-request
531	(update-request req
532	headers: (headers `((foo bar))))
533	"test"))
534	(test "Chunking"
535	"GET /foo/bar.html HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
536	(test-write-request
537	(update-request req
538	headers: (headers `((transfer-encoding chunked))))
539	"foo" "1234567890")))))
540
541	(define (test-read-response input-string)
542	(call-with-input-string input-string
543	(lambda (in)
544	(read-response in))))
545
546	(test-group "Read response"
547	(test-group "HTTP/1.1"
548	(let ((res (test-read-response "HTTP/1.1 303 See other\r\nFoo: bar\r\n\r\nContents")))
549	(test "Version detection"
550	'(1 . 1)
551	(cons (response-major res) (response-minor res)))
552	(test "Status"
553	'(303 . "See other")
554	(cons (response-code res) (response-reason res)))
555	(test "Headers"
556	'("bar")
557	(header-values 'foo (response-headers res)))
558	(test "Contents"
559	"Contents"
560	(read-string #f (response-port res))))
561	(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")))
562	(test "Chunking"
563	"foo1234567890"
564	(read-string #f (response-port res)))))
565	(test-group "HTTP/1.0"
566	(let ((res (test-read-response "HTTP/1.0 303 See other\r\nFoo: bar\r\n\r\nContents")))
567	(test "Version detection"
568	'(1 . 0)
569	(cons (response-major res) (response-minor res)))
570	(test "Status"
571	'(303 . "See other")
572	(cons (response-code res) (response-reason res)))
573	(test "Headers"
574	'("bar")
575	(header-values 'foo (response-headers res)))
576	(test "Contents"
577	"Contents"
578	(read-string #f (response-port res))))
579	(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")))
580	(test "Chunking ignored"
581	"3\r\nfoo\r\na\r\n1234567890\r\n"
582	(read-string #f (response-port res)))))
583	(test-group "HTTP/0.9"
584	(let ((res (test-read-response "Doesn't matter what's here\r\nLine 2")))
585	(test "Always OK status"
586	'(200 . "OK")
587	(cons (response-code res) (response-reason res)))
588	(test "Version detection; fallback to 0.9"
589	'(0 . 9)
590	(cons (response-major res) (response-minor res)))
591	(test "No headers"
592	(headers '()) (response-headers res))
593	(test "Contents"
594	"Doesn't matter what's here\r\nLine 2"
595	(read-string #f (response-port res))))))
596
597	(define (test-write-response res . outputs)
598	(call-with-output-string
599	(lambda (out)
600	(response-port-set! res out)
601	(let ((r (write-response res)))
602	(for-each (lambda (output)
603	(display output (response-port r)))
604	outputs)))))
605
606	(test-group "Write response"
607	(test-group "HTTP/0.9"
608	(let ((res (make-response major: 0 minor: 9
609	code: 200 reason: "OK")))
610	(test "Headers ignored"
611	"These are the contents\r\n"
612	(test-write-response
613	(update-response res headers: (headers `((foo bar))))
614	"These are the contents\r\n"))))
615	(test-group "HTTP/1.0"
616	(let ((res (make-response major: 1 minor: 0
617	code: 200 reason: "OK")))
618	(test "Headers used"
619	"HTTP/1.0 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
620	(test-write-response
621	(update-response res headers: (headers `((foo bar))))
622	"These are the contents\r\n"))
623	(test "Status code"
624	"HTTP/1.0 303 See other\r\n\r\nThese are the contents\r\n"
625	(test-write-response
626	(update-response res code: 303 reason: "See other")
627	"These are the contents\r\n"))
628	(test "Chunking ignored"
629	"HTTP/1.0 200 OK\r\nTransfer-Encoding: chunked\r\n\r\nfoo1234567890"
630	(test-write-response
631	(update-response
632	res
633	headers: (headers `((transfer-encoding chunked))))
634	"foo" "1234567890"))))
635	(test-group "HTTP/1.1"
636	(let ((res (make-response major: 1 minor: 1
637	code: 200 reason: "OK")))
638	(test "Headers used"
639	"HTTP/1.1 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
640	(test-write-response
641	(update-response res headers: (headers `((foo bar))))
642	"These are the contents\r\n"))
643	(test "Status code"
644	"HTTP/1.1 303 See other\r\n\r\nThese are the contents\r\n"
645	(test-write-response
646	(update-response res code: 303 reason: "See other")
647	"These are the contents\r\n"))
648	(test "Chunking"
649	"HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
650	(test-write-response
651	(update-response
652	res
653	headers: (headers `((transfer-encoding chunked))))
654	"foo" "1234567890")))))
655
656	;; TODO:
657	;; - Fix the parsing system so it's not so broken (more comfortable combinators)
658	;; - Test malformed headers
659	;; - When headers are malformed, what to do? Return #f for value and let
660	;; single/multiple discard them? Throw an exception?
661	;; - Add parsing capability for quoted-pairs inside tokens and comments
662	;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level

Note: See TracBrowser for help on using the repository browser.

Download in other formats: