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

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

Add host parser/unparser

File size: 26.3 KB
Line 
1(require-extension test extras regex uri-generic 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            ;; XXX Should we interpret "\\\r\n" as "\r\n", too?
79            (header-values 'foo (test-read-headers "Foo: \"bar\\\r\\\nqux\""))))))
80
81(test-group "Specialized header parsers"
82  (test-group "Host"
83    (test "Hostname and port"
84          '(("foo.example.com" . 8080))
85          (header-values 'host (test-read-headers "Host: foo.example.com:8080")))
86    (test "Hostname, no port"
87          '(("foo.example.com" . 80))
88          (header-values 'host (test-read-headers "Host: foo.example.com"))))
89  (test-group "Quality parameter"
90   (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="))
91          (accept  (header-contents 'accept headers)))
92     ;; RFC 2616 3.6: "All transfer-coding values are case insensitive".
93     ;; This includes the parameter name (attribute) and value.
94     (test "Explicit quality value (case-insensitive)"
95           0.5 (get-quality (first accept)))
96     (test "Explicit quality encoding value"
97           'text/plain (get-value (first accept)))
98     ;; RFC 2616 3.9
99     (test "Implicit quality value"
100           1.0 (get-quality (second accept)))
101     (test "Implicit quality encoding value"
102           'text/html (get-value (second accept)))
103     (test "Quality values have only three digits"
104           0.123 (get-quality (third accept)))
105     (test "Quality values maximum is 1.0"
106           1.0 (get-quality (fourth accept)))
107     (test "Quality values minimum is 0.0"
108           0.0 (get-quality (fifth accept)))
109     (test "Missing quality value ok"
110           1.0 (get-quality (sixth accept)))))
111
112  (test-group "Symbol-parser-ci"
113    (let* ((headers (test-read-headers "Accept-Ranges: FoO")))
114      (test "Case-insensitive"
115            '(foo) (header-values 'accept-ranges headers))))
116 
117  (test-group "Symbol-parser"
118    (let* ((headers (test-read-headers "Allow: FoO, foo")))
119      (test "Case-sensitive"
120            '(FoO foo) (header-values 'allow headers))))
121
122  (test-group "Natnum-parser"
123    (parameterize ((single-headers '(foo bar qux mooh))
124                   (header-parsers `((foo . ,(single natnum-parser))
125                                     (bar . ,(single natnum-parser))
126                                     (qux . ,(single natnum-parser))
127                                     (mooh . ,(single natnum-parser)))))
128     (let ((headers (test-read-headers "Foo: 10\r\nBar: abc\r\nQux: -10\r\nMooh: 1.6")))
129       (test "Simple test"
130             10 (get-value (car (header-contents 'foo headers))))
131       (test "No number defaults to 0"
132             0 (get-value (car (header-contents 'bar headers))))
133       (test "No negative numbers"
134             0 (get-value (car (header-contents 'qux headers))))
135       ;; This is a "feature" in the interest of the robustness principle
136       (test "Rounding of real numbers"
137             2 (get-value (car (header-contents 'mooh headers)))))))
138
139  (test-group "Cache-control-parser"
140    (let ((headers (test-read-headers "Cache-control: max-age=10, private")))
141      (test "max-age is a number"
142            '(max-age . 10) (get-value (header-list-ref 'max-age (header-contents 'cache-control headers))))
143      (test "private without value"
144            '(private . #t) (get-value (header-list-ref 'private (header-contents 'cache-control headers)))))
145    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
146      (test "private with values"
147            '(private . (accept-encoding accept-ranges))
148            (get-value (header-list-ref 'private (header-contents 'cache-control headers))))
149      (test "Acts like a multi-header"
150            '(must-revalidate . #t) (get-value (header-list-ref 'must-revalidate (header-contents 'cache-control headers))))))
151
152  ;; RFC 2616, 14.15
153  ;; Also: RFC 1864 (Base64) and RF1321 (MD5)
154  ;; XXX TODO: See if binary strings are useful with the MD5 egg, otherwise
155  ;; we need an additional decoding step
156  (test-group "md5-parser"
157    (let ((headers (test-read-headers "Content-md5: Q2hlY2sgSW50ZWdyaXR5IQ==")))
158      (test "md5 is base64-decoded"
159            "Check Integrity!"
160            (get-value (car (header-contents 'content-md5 headers))))))
161
162  (test-group "Range-parser"
163    (let ((headers (test-read-headers "content-range: bytes 500-999/1234")))
164      (test "Simple range"
165            '(500 999 1234)
166            (get-value (car (header-contents 'content-range headers))))))
167
168  ;; XXX SRFI-19!
169  (test-group "http-time-parser"
170    (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
171      (test "RFC822/RFC1123 time"
172            0
173            (get-value (car (header-contents 'date headers)))))
174    (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
175      (test "RFC850 time"
176            0
177            (get-value (car (header-contents 'date headers)))))
178    (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
179      (test "asctime time"
180            0
181            (get-value (car (header-contents 'date headers))))))
182
183  (test-group "entity-tag-parser"
184    (let ((headers (test-read-headers "Etag: \"foo\"")))
185      (test "Strong tag"
186            '(strong . "foo")
187            (get-value (car (header-contents 'etag headers)))))
188    (let ((headers (test-read-headers "Etag: W/\"bar\"")))
189      (test "Weak tag"
190            '(weak . "bar")
191            (get-value (car (header-contents 'etag headers)))))
192    (let ((headers (test-read-headers "Etag: \"\"")))
193      (test "Empty tag"
194            '(strong . "")
195            (get-value (car (header-contents 'etag headers)))))
196    (let ((headers (test-read-headers "Etag: \"W/bar\"")))
197        (test "Strong tag, containing W/ prefix"
198              '(strong . "W/bar")
199              (get-value (car (header-contents 'etag headers))))))
200
201  (test-group "Set-Cookie-parser"
202    (let* ((headers (test-read-headers "Set-Cookie: foo=\"bar\"")))
203      (test "Simple name/value pair"
204            '("foo" . "bar")
205            (get-value (first (header-contents 'set-cookie headers)))))
206    (let ((headers (test-read-headers "Set-Cookie: foo=bar=qux; max-age=10")))
207      (test "Cookie with = signs"
208            '("foo" . "bar=qux")
209            (get-value (first (header-contents 'set-cookie headers)))))
210    (let* ((headers (test-read-headers "Set-Cookie: foo=bar; Comment=\"Hi, there!\", qux=mooh\r\nSet-Cookie: mumble=mutter")))
211      (test "Comment"
212            "Hi, there!"
213            (get-param 'comment
214                       (first (header-contents 'set-cookie headers))))
215      (test "Multiple cookies in one header"
216            '("qux" . "mooh")
217            (get-value (second (header-contents 'set-cookie headers))))
218      (test "Multiple cookies in multiple headers"
219            '("mumble" . "mutter")
220            (get-value (third (header-contents 'set-cookie headers))))
221      (test "Missing \"secure\" value"
222            #f
223            (get-param 'secure
224                       (third (header-contents 'set-cookie headers)))))
225    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sunday, 20-Jul-08 15:23:42 GMT; secure; path = / ")))
226      (test "Missing value"
227            '("foo" . "")
228            (get-value (first (header-contents 'set-cookie headers))))
229      (test "Old-style cookie expires value"
230            ;; Should use something like
231            ;; (string->date foo "~A, ~d-~b-~y ~H:~M:~S ~z") in an "en" locale
232            0
233            (get-param 'expires
234                       (first (header-contents 'set-cookie headers))))
235      (test "Secure value"
236            #t
237            (get-param 'secure
238                       (first (header-contents 'set-cookie headers))))
239      (test "Path"
240            "/"
241            (get-param 'path
242                       (first (header-contents 'set-cookie headers))))))
243 
244  (test-group "Cookie-parser"
245    (let* ((headers (test-read-headers "Cookie: foo=bar; $Path=/; qux=mooh; $unknown=something")))
246      (test "Multiple cookies in the same header"
247            '(("foo" . "bar") . ("qux" . "mooh"))
248            (cons
249             (get-value (first  (header-contents 'cookie headers)))
250             (get-value (second (header-contents 'cookie headers)))))
251      (test "Parameters of cookies (spaces stripped)"
252            "/"
253            (get-param '$path (first (header-contents 'cookie headers))))
254      (test "Parameters of cookies"
255            "something"
256            (get-param '$unknown (second (header-contents 'cookie headers)))))
257    (let* ((headers (test-read-headers "Cookie: $Version=\"1\"; foo=bar; $Path=/; qux=mooh; $unknown=something")))
258      (test "Version string is used for all cookies"
259            (cons 1 1)
260            (cons
261             (get-param '$version (first (header-contents 'cookie headers)))
262             (get-param '$version (second (header-contents 'cookie headers))))))))
263
264(test-group "Headers"
265  (test "Simple test"
266        `(bar qux)
267        (header-values 'foo (headers `((foo bar qux)))))
268  (test "Multi headers are folded"
269        `(bar qux)
270        (header-values 'foo (headers `((foo bar)
271                                       (foo qux)))))
272  (test "Single headers are unique"
273        `(qux)
274        (header-values 'foo (parameterize ((single-headers '(foo)))
275                                    (headers `((foo bar)
276                                               (foo qux))))))
277  (test "Extra single headers are ignored"
278        `(qux)
279        (header-values 'foo (parameterize ((single-headers '(foo)))
280                                    (headers `((foo bar qux))))))
281  (test "Parameters"
282        `((bar . qux))
283        (get-params
284         (car (header-contents 'foo (headers `((foo #(mooh ((bar . qux))))))))))
285  (test "Multi headers are folded into old headers"
286        `(bar qux)
287        (header-values 'foo (headers `((foo qux))
288                                     (headers `((foo bar)))))))
289
290(define (test-unparse-headers h)
291  (call-with-output-string
292   (lambda (o)
293     (unparse-headers (headers h) o))))
294
295(test-group "Unparsers"
296  (test-group "Default unparser"
297    (test "String"
298          "Foo: bar\r\n"
299          (test-unparse-headers `((foo "bar"))))
300    (test "Multiple strings"
301          "Foo: bar, qux\r\n"
302          (test-unparse-headers `((foo "bar" "qux"))))
303    (test "Auto-quoting on commas and whitespace"
304          "Foo: \"bar, qux\", \"mooh blah\"\r\n"
305          (test-unparse-headers `((foo "bar, qux" "mooh blah"))))
306    ;; RFC 2616 2.2
307    (test "Escaping quotes"
308          "Foo: \"bar \\\" qux\", mooh\r\n"
309          (test-unparse-headers `((foo "bar \" qux" "mooh"))))
310    (test "Escaping control characters"
311          "Foo: \"bar\\\r\\\x01qux\"\r\n"
312          (test-unparse-headers `((foo "bar\r\x01qux"))))
313    ;; Unfortunately, there are no or very few HTTP implementations
314    ;; which understand that newlines can be escaped with a backslash
315    ;; in a quoted string. That's why we don't allow it.
316    ;; The user is expected to escape the newlines according to the type
317    ;; of header (URLencoding, removing the newlines from cookies, etc)
318    (test-error* "Embedded newlines throw an error"
319                 (http unencoded-header)
320                 (test-unparse-headers `((foo "bar\n\x01qux"))))
321    (test "Alist"
322          "Foo: bar=qux, mooh=mumble\r\n"
323          (test-unparse-headers `((foo (bar . qux) (mooh . mumble)))))
324    (test "Alist with escapes"
325          "Foo: bar=qux, mooh=\"mum, ble\"\r\n"
326          (test-unparse-headers `((foo (bar . "qux") (mooh . "mum, ble")))))
327    (test "URI"
328          "Foo: http://foo.com/bar\r\n"
329          (test-unparse-headers `((foo ,(uri-reference "http://foo.com/bar")))))
330    (test "Parameters"
331          "Foo: bar; qux=mooh; mumble=mutter; blah\r\n"
332          (test-unparse-headers `((foo #(bar ((qux . mooh)
333                                              (mumble . mutter)
334                                              (blah . #t)
335                                              (feh . #f))))))))
336  (test-group "Entity-tag unparser"
337    (test "Weak tag"
338          "Etag: W/blah\r\n"
339          (test-unparse-headers `((etag (weak . "blah")))))
340    (test "Strong tag"
341          "Etag: blah\r\n"
342          (test-unparse-headers `((etag (strong . "blah")))))
343    (test "Strong tag starting with W/"
344          "Etag: \"W/blah\"\r\n"
345          (test-unparse-headers `((etag (strong . "W/blah"))))))
346  (test-group "Host unparser"
347    (test "Default port is 80, left out"
348          "Host: foo.example.com\r\n"
349          (test-unparse-headers `((host ("foo.example.com" . 80)))))
350    (test "Different port"
351          "Host: foo.example.com:8080\r\n"
352          (test-unparse-headers `((host ("foo.example.com" . 8080)))))))
353
354(define (test-read-request str)
355  (call-with-input-string str
356    (lambda (in)
357      (read-request in))))
358
359(test-group "Read-request"
360  (parameterize ((request-parsers `(,(lambda (line in)
361                                       (and (string=? line "foo") 'foo))
362                                    ,(lambda (line in)
363                                       (and (string=? line "bar") 'bar)))))
364    (test-error* (http unknown-protocol-line) (test-read-request "qux"))
365    (test-error* (http unknown-protocol-line) (test-read-request ""))
366    (test 'foo (test-read-request "foo"))
367    (test 'bar (test-read-request "bar")))
368  (test-group "HTTP/0.9"
369    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2\r\n")))
370      (test 0 (request-major req))
371      (test 9 (request-minor req))
372      (test 'GET (request-method req))
373      (test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
374      (test (headers '()) (request-headers req)))
375    ; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
376    ; It only mentions it in the context of HTTP/1.x (section 5.1.1).
377    ; We obey the BNF syntax rule in 2.1:
378    ;     "literal" - Quotation marks surround literal text.
379    ;                 Unless stated otherwise, the text is case-insensitive.
380    ; Section 4.1 defines:
381    ;     Simple-Request  = "GET" SP Request-URI CRLF
382    (test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
383    (test-error "0.9 only knows GET" (test-read-request "PUT /path")))
384  (test-group "HTTP/1.0"
385    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
386      (test 1 (request-major req))
387      (test 0 (request-minor req))
388      (test 'GET (request-method req))
389      (test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
390      (test (headers '()) (request-headers req)))
391    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
392  (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
393   (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
394     (test 1 (request-major req))
395     (test 1 (request-minor req)))
396   (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
397   ; RFC 2616 5.1.1
398   (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
399   ; RFC 2616 3.1 + case-insensitivity BNF rule
400   (test "Protocol is case-insensitive" '1 (request-minor (test-read-request "GET /path htTP/1.1\r\n\r\n"))))) ;; TODO: Chunking
401
402(define (test-write-request req . outputs)
403  (call-with-output-string
404    (lambda (out)
405      (request-port-set! req out)
406      (let ((r (write-request req)))
407       (for-each (lambda (output)
408                   (display output (request-port r)))
409                 outputs)))))
410
411(test-group "Write request"
412  ;; This can also be called Simple-Request as per RFC 1945 4.1
413  ;; RFC 2616 19.6 also states we should recognise 0.9 requests, but if
414  ;; we understand those we should also be able to generate them because
415  ;; a 0.9 server does not understand 1.x requests.
416  (test-group "HTTP/0.9"
417    (let ((req (make-request major: 0 minor: 9
418                             method: 'GET
419                             uri: (uri-reference "/foo/bar.html"))))
420      (test "Always empty headers"
421            "GET /foo/bar.html\r\n"
422            (test-write-request (update-request req
423                                                headers:
424                                                (headers `((foo bar))))
425                                ""))
426      (test "Always GET"
427            "GET /foo/bar.html\r\n"
428            (test-write-request (update-request req method: 'POST)))))
429  (test-group "HTTP/1.0"
430    (let ((req (make-request major: 1 minor: 0
431                             method: 'GET
432                             uri: (uri-reference "/foo/bar.html"))))
433      (test "Headers"
434            "GET /foo/bar.html HTTP/1.0\r\nFoo: bar\r\n\r\ntest"
435            (test-write-request
436             (update-request req
437                             headers: (headers `((foo bar))))
438             "test"))
439      (test "Chunking ignored"
440            "GET /foo/bar.html HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\nfoobar"
441            (test-write-request
442             (update-request req
443                             headers: (headers `((transfer-encoding chunked))))
444             "foo" "bar"))))
445  (test-group "HTTP/1.1"
446    (let ((req (make-request major: 1 minor: 1
447                             method: 'GET
448                             uri: (uri-reference "/foo/bar.html"))))
449      (test "Headers"
450            "GET /foo/bar.html HTTP/1.1\r\nFoo: bar\r\n\r\ntest"
451            (test-write-request
452             (update-request req
453                             headers: (headers `((foo bar))))
454             "test"))
455      (test "Chunking"
456            "GET /foo/bar.html HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
457            (test-write-request
458             (update-request req
459                             headers: (headers `((transfer-encoding chunked))))
460             "foo" "1234567890")))))
461
462(define (test-read-response input-string)
463  (call-with-input-string input-string
464    (lambda (in)
465      (read-response in))))
466
467(test-group "Read response"
468  (test-group "HTTP/1.1"
469    (let ((res (test-read-response "HTTP/1.1 303 See other\r\nFoo: bar\r\n\r\nContents")))
470      (test "Version detection"
471            '(1 . 1)
472            (cons (response-major res) (response-minor res)))
473      (test "Status"
474            '(303 . "See other")
475            (cons (response-code res) (response-reason res)))
476      (test "Headers"
477            '("bar")
478            (header-values 'foo (response-headers res)))
479      (test "Contents"
480            "Contents"
481            (read-string #f (response-port res))))
482    (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")))
483      (test "Chunking"
484            "foo1234567890"
485            (read-string #f (response-port res)))))
486  (test-group "HTTP/1.0"
487    (let ((res (test-read-response "HTTP/1.0 303 See other\r\nFoo: bar\r\n\r\nContents")))
488      (test "Version detection"
489            '(1 . 0)
490            (cons (response-major res) (response-minor res)))
491      (test "Status"
492            '(303 . "See other")
493            (cons (response-code res) (response-reason res)))
494      (test "Headers"
495            '("bar")
496            (header-values 'foo (response-headers res)))
497      (test "Contents"
498            "Contents"
499            (read-string #f (response-port res))))
500    (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")))
501      (test "Chunking ignored"
502            "3\r\nfoo\r\na\r\n1234567890\r\n"
503            (read-string #f (response-port res)))))
504  (test-group "HTTP/0.9"
505    (let ((res (test-read-response "Doesn't matter what's here\r\nLine 2")))
506      (test "Always OK status"
507            '(200 . "OK")
508            (cons (response-code res) (response-reason res)))
509      (test "Version detection; fallback to 0.9"
510            '(0 . 9)
511            (cons (response-major res) (response-minor res)))
512      (test "No headers"
513            (headers '()) (response-headers res))
514      (test "Contents"
515            "Doesn't matter what's here\r\nLine 2"
516            (read-string #f (response-port res))))))
517
518(define (test-write-response res . outputs)
519  (call-with-output-string
520    (lambda (out)
521      (response-port-set! res out)
522      (let ((r (write-response res)))
523       (for-each (lambda (output)
524                   (display output (response-port r)))
525                 outputs)))))
526
527(test-group "Write response"
528  (test-group "HTTP/0.9"
529    (let ((res (make-response major: 0 minor: 9
530                              code: 200 reason: "OK")))
531      (test "Headers ignored"
532            "These are the contents\r\n"
533            (test-write-response
534             (update-response res headers: (headers `((foo bar))))
535             "These are the contents\r\n"))))
536  (test-group "HTTP/1.0"
537    (let ((res (make-response major: 1 minor: 0
538                              code: 200 reason: "OK")))
539      (test "Headers used"
540            "HTTP/1.0 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
541            (test-write-response
542             (update-response res headers: (headers `((foo bar))))
543             "These are the contents\r\n"))
544      (test "Status code"
545            "HTTP/1.0 303 See other\r\n\r\nThese are the contents\r\n"
546            (test-write-response
547             (update-response res code: 303 reason: "See other")
548             "These are the contents\r\n"))
549      (test "Chunking ignored"
550            "HTTP/1.0 200 OK\r\nTransfer-Encoding: chunked\r\n\r\nfoo1234567890"
551            (test-write-response
552             (update-response
553              res
554              headers: (headers `((transfer-encoding chunked))))
555             "foo" "1234567890"))))
556  (test-group "HTTP/1.1"
557   (let ((res (make-response major: 1 minor: 1
558                             code: 200 reason: "OK")))
559     (test "Headers used"
560           "HTTP/1.1 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
561            (test-write-response
562             (update-response res headers: (headers `((foo bar))))
563             "These are the contents\r\n"))
564     (test "Status code"
565           "HTTP/1.1 303 See other\r\n\r\nThese are the contents\r\n"
566           (test-write-response
567            (update-response res code: 303 reason: "See other")
568            "These are the contents\r\n"))
569     (test "Chunking"
570           "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
571           (test-write-response
572            (update-response
573             res
574             headers: (headers `((transfer-encoding chunked))))
575            "foo" "1234567890")))))
576
577;; TODO:
578;; - Implement comments parsing (better: a sane parsing system!)
579;; - Test malformed headers
580;; - When headers are malformed, what to do? Return #f for value and let
581;;    single/multiple discard them? Throw an exception?
582;; - Use SRFI-19
583;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level
584;; - Think about a good naming convention to distinguish parsers that accept
585;;    one argument (an already-tokenized string) or multiple (raw header data)
Note: See TracBrowser for help on using the repository browser.