Initial CHICKEN 5 port of intarweb 1.72.0

1 files changed, 1243 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..e2d0b70
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,1243 @@
+(import scheme chicken.base chicken.port
+        chicken.condition chicken.time.posix srfi-1 srfi-18 
+        test uri-common intarweb chicken.io chicken.format)
+
+;; Below, there are specific tests for when these do have a value
+(http-header-limit #f)
+(http-line-limit #f)
+(http-urlencoded-request-data-limit #f)
+
+(define-syntax test-error*
+  (syntax-rules ()
+    ((_ ?msg (?error-type ...) ?expr)
+     (let-syntax ((expression:
+                   (syntax-rules ()
+                     ((_ ?expr)
+                      (condition-case (begin ?expr "<no error thrown>")
+                                      ((?error-type ...) '(?error-type ...))
+                                      (exn () (##sys#slot exn 1)))))))
+       (test ?msg '(?error-type ...) (expression: ?expr))))
+    ((_ ?msg ?error-type ?expr)
+     (test-error* ?msg (?error-type) ?expr))
+    ((_ ?error-type ?expr)
+     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
+
+(header-parse-error-handler (lambda (header-name contents header exn)
+                              (raise exn)))
+
+(define (test-read-headers str)
+  (call-with-input-string str read-headers))
+
+(test-begin "intarweb")
+(test-group "headers"
+  (test-group "single headers"
+   (parameterize ((single-headers '(foo qux))
+                  (header-parsers `((foo . ,(single identity))
+                                    (qux . ,(single identity)))))
+     (let ((headers (test-read-headers "foo: bar\r\nqux:\t   \tmooh\t   \r\n\r\n")))
+       (test "Basic test"
+             '("bar") (header-values 'foo headers))
+       ;; RFC 2616 4.2
+       (test "Extra spaces are ignored"
+             '("mooh") (header-values 'qux headers)))
+     (let ((headers (test-read-headers "foo: bar\r\n qux: mooh\r\nquux: mumble\r\n\r\n")))
+       ;; RFC 2616 2.2
+       (test "Continuation chars"
+             '("bar qux: mooh") (header-values 'foo headers)))
+     ;; Not in RFC but common behaviour - also, robustness principle
+     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\n")))
+       (test "Multiple headers for singular header types discarded"
+             '("qux") (header-values 'foo headers)))))
+  ;; All this RFC 2616 4.2
+  (test-group "multi-headers"
+   (parameterize ((header-parsers `((foo . ,(multiple identity)))))
+     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\nquux: mumble\r\n\r\n")))
+       (test "Multiple headers"
+             '("bar" "qux") (header-values 'foo headers)))
+     (let ((headers (test-read-headers "Foo: bar\r\nFoO: qux\r\nquux: mumble\r\n\r\n")))
+       (test "Multiple headers: case insensitivity"
+             '("bar" "qux") (header-values 'foo headers)))
+     (let ((headers (test-read-headers "foo: bar, qux\r\nquux: mumble\r\n\r\n")))
+       (test "Comma-separated headers"
+             '("bar" "qux") (header-values 'foo headers)))
+     (let ((headers (test-read-headers "foo: \"ba\\\"r, qux\"\r\nfoo: mooh\r\n\r\n")))
+       (test "Quoted headers"
+             '("ba\"r, qux" "mooh") (header-values 'foo headers))))
+   ;; RFC 2616 4.5
+   ;; "Unrecognized header fields are treated as entity-header fields."
+   ;;
+   ;; RFC 2616 7.1
+   ;; "Unrecognized header fields SHOULD be ignored by the recipient and MUST be
+   ;;  forwarded by transparent proxies."
+   (let ((headers (test-read-headers "unknown: foo, bar\r\nunknown: blah\r\n\r\n")))
+     (test "Unknown headers are not parsed and put into lists"
+           '("foo, bar" "blah") (header-values 'unknown headers))
+     (test "Unknown headers get raw instead of a parameter list"
+           'raw (header-params 'unknown headers))))
+  (test-group "miscellaneous header stuff"
+    (parameterize ((header-parsers `((foo . ,(multiple identity))
+                                     (bar . ,(lambda x (error "bad header")))))
+                   (http-header-limit 2))
+      (test-error "Missing header contents" (test-read-headers "foo\r\n\r\n"))
+      (test-error "Bad header w/ handler" (test-read-headers "bar: x\r\n\r\n"))
+      (parameterize ((header-parse-error-handler (lambda (n c h exn) h)))
+       (test "Bad header w/o handler" #t (headers? (test-read-headers "bar: x\r\n\r\n"))))
+      ;; RFC 2616 2.2
+      ;; "The backslash character ("\") MAY be used as a single-character
+      ;; quoting mechanism only within quoted-string and comment constructs."
+      ;;     quoted-pair = "\" CHAR
+      ;; CHAR implies any char, *including* CR/LF. This is clarified by RFC 822,
+      ;; on which RFC 2616 is based.
+      ;; Apparently, even \CRLF is allowed (as opposed to \CR\LF)
+      (test "Embedded newlines"
+            '("bar\r\nqux")
+            ;; It's unclear whether we should interpret the "\r\n" as EOL
+            ;; in "\\\r\n", or whether it should be seen as an embedded \r
+            ;; followed by a \n (which is then interpreted as a literal \n?)
+            (header-values 'foo (test-read-headers "Foo: \"bar\\\r\\\nqux\"")))
+      (test-error "Too many headers is an error"
+                  (test-read-headers "foo: bar\r\nfoo: qux\r\nfoo: hoohoo\r\n")))))
+
+(test-group "specialized header parsers"
+  (test-group "host/port"
+    (test "Hostname and port"
+          '(("foo.example.com" . 8080))
+          (header-values 'host (test-read-headers "Host: foo.example.com:8080")))
+    (test "Hostname, no port"
+          '(("foo.example.com" . #f))
+          (header-values 'host (test-read-headers "Host: foo.example.com"))))
+  (test-group "quality parameter"
+   (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="))
+          (accept  (header-contents 'accept headers)))
+     ;; RFC 2616 3.6: "All transfer-coding values are case insensitive".
+     ;; This includes the parameter name (attribute) and value.
+     (test "quality value (case-insensitive)"
+           0.5 (get-param 'q (first accept) 1.0))
+     (test "quality encoding value"
+           'text/plain (get-value (first accept)))
+     (test "quality values have only three digits"
+           0.123 (get-param 'q (third accept) 1.0))
+     (test "quality values maximum is 1.0"
+           1.0 (get-param 'q (fourth accept) 1.0))
+     (test "quality values minimum is 0.0"
+           0.0 (get-param 'q (fifth accept) 1.0))
+     (test "missing quality value ok"
+           1.0 (get-param 'q (sixth accept) 1.0))))
+  (test-group "charset parameter"
+   (let* ((headers (test-read-headers "Content-Type: text/PLAIN; charset=ISO-8859-1"))
+          (content-type (header-contents 'content-type headers)))
+     (test "content-type value is lowercase symbol"
+           'text/plain (get-value (car content-type)))
+     ;; RFC 2616 3.4: "HTTP character sets are identified by
+     ;; case-insensitive tokens. The complete set of tokens is defined
+     ;; by the IANA Character Set registry."
+     (test "content-type charset is lowercase symbol"
+           'iso-8859-1 (get-param 'charset (car content-type)))))
+
+  (test-group "symbol-parser-ci"
+    (let* ((headers (test-read-headers "Accept-Ranges: FoO")))
+      (test "Case-insensitive"
+            '(foo) (header-values 'accept-ranges headers))))
+  
+  (test-group "symbol-parser"
+    (let* ((headers (test-read-headers "Allow: FoO, foo")))
+      (test "Case-sensitive"
+            '(FoO foo) (header-values 'allow headers))))
+
+  (test-group "natnum-subparser"
+    (parameterize ((single-headers '(foo bar qux mooh))
+                   (header-parsers `((foo . ,(single natnum-subparser))
+                                     (bar . ,(single natnum-subparser))
+                                     (qux . ,(single natnum-subparser))
+                                     (mooh . ,(single natnum-subparser)))))
+     (let ((headers (test-read-headers "Foo: 10\r\nBar: abc\r\nQux: -10\r\nMooh: 1.6")))
+       (test "Simple test"
+             10 (header-value 'foo headers))
+       (test "No number defaults to 0"
+             0 (header-value 'bar headers))
+       (test "No negative numbers"
+             0 (header-value 'qux headers))
+       ;; This is a "feature" in the interest of the robustness principle
+       (test "Rounding of real numbers"
+             2 (header-value 'mooh headers)))))
+
+  (test-group "cache-control-parser"
+    (let ((headers (test-read-headers "Cache-control: max-age=10, private")))
+      (test "max-age is a number"
+            '(max-age . 10) (assq 'max-age (header-values 'cache-control headers)))
+      (test "private without value"
+            '(private . #t) (assq 'private (header-values 'cache-control headers))))
+    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
+      (test "private with values"
+            '(private . (accept-encoding accept-ranges))
+            (assq 'private (header-values 'cache-control headers)))
+      (test "Acts like a multi-header"
+            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
+
+  (test-group "authorization-parser"
+    (test-group "basic auth"
+     (let ((headers (test-read-headers "Authorization: Basic QWxpIEJhYmE6b3BlbiBzZXNhbWU=\r\n")))
+       (test "basic"
+             'basic
+             (header-value 'authorization headers))
+       (test "username"
+             "Ali Baba"
+             (header-param 'username 'authorization headers))
+       (test "password"
+             "open sesame"
+             (header-param 'password 'authorization headers))))
+    (test-group "digest auth"
+      (let ((headers (test-read-headers "Authorization: Digest username=\"Mufasa\", realm=\"testrealm@host.com\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", uri=\"/dir/index.html\", qop=auth, nc=00000001, cnonce=\"0a4f113b\", response=\"6629fae49393a05397450978507c4ef1\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\", algorithm=MD5")))
+        (test "digest"
+              'digest
+              (header-value 'authorization headers))
+        (test "realm"
+              "testrealm@host.com"
+              (header-param 'realm 'authorization headers))
+        (test "nonce"
+              "dcd98b7102dd2f0e8b11d0f600bfb0c093"
+              (header-param 'nonce 'authorization headers))
+        (test "username"
+              "Mufasa"
+              (header-param 'username 'authorization headers))
+        (test "qop"
+              'auth
+              (header-param 'qop 'authorization headers))
+        (test "digest uri"
+              "/dir/index.html"
+              (uri->string (header-param 'uri 'authorization headers)))
+        (test "nonce count"
+              1
+              (header-param 'nc 'authorization headers))
+        (test "cnonce"
+              "0a4f113b"
+              (header-param 'cnonce 'authorization headers))
+        (test "response"
+              "6629fae49393a05397450978507c4ef1"
+              (header-param 'response 'authorization headers))
+        (test "opaque"
+              "5ccc069c403ebaf9f0171e9517f40e41"
+              (header-param 'opaque 'authorization headers))
+        (test "algorithm"
+              'md5
+              (header-param 'algorithm 'authorization headers))))
+    (test-group "custom authorization scheme"
+      (parameterize ((authorization-param-subparsers
+                      `((custom . ,(lambda (contents pos)
+                                     (receive (c p)
+                                       (parse-token contents pos)
+                                       (values `((contents . ,(http-name->symbol c))) p))))
+                        . ,(authorization-param-subparsers))))
+        (let ((headers (test-read-headers "Authorization: Custom Security-through-obscurity")))
+          (test "Custom"
+                'custom
+                (header-value 'authorization headers))
+          (test "Custom contents"
+                'security-through-obscurity
+                (header-param 'contents 'authorization headers))))))
+  
+  (test-group "authenticate parser"
+    (test-group "basic auth"
+      (let ((headers (test-read-headers "WWW-Authenticate: Basic realm=\"WallyWorld\"")))
+        (test "basic"
+              'basic
+              (header-value 'www-authenticate headers))
+        (test "realm"
+              "WallyWorld"
+              (header-param 'realm 'www-authenticate headers))))
+    (test-group "digest auth"
+      (let ((headers (test-read-headers "WWW-Authenticate: Digest realm=\"testrealm@host.com\", qop=\"auth, auth-int\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\"")))
+        (test "digest"
+              'digest
+              (header-value 'www-authenticate headers))
+        (test "realm"
+              "testrealm@host.com"
+              (header-param 'realm 'www-authenticate headers))
+        (test "qop"
+              '(auth auth-int)
+              (header-param 'qop 'www-authenticate headers))
+        (test "nonce"
+              "dcd98b7102dd2f0e8b11d0f600bfb0c093"
+              (header-param 'nonce 'www-authenticate headers))
+        (test "opaque"
+              "5ccc069c403ebaf9f0171e9517f40e41"
+              (header-param 'opaque 'www-authenticate headers))
+        (test "missing stale value"
+              #f
+              (header-param 'stale 'www-authenticate headers)))
+      (let ((headers (test-read-headers "WWW-Authenticate: Digest domain=\"/example http://foo.com/bar\", stale=TRUE")))
+        (test "domains"
+              '("/example" "http://foo.com/bar")
+              (map uri->string
+                   (header-param 'domain 'www-authenticate headers)))
+        (test "stale"
+              #t
+              (header-param 'stale 'www-authenticate headers)))
+      (let ((headers (test-read-headers "WWW-Authenticate: Digest stale=whatever")))
+        (test "non-true stale value"
+              #f
+              (header-param 'stale 'www-authenticate headers)))))
+  
+  (test-group "pragma-parser"
+    (let ((headers (test-read-headers "Pragma: custom-value=10, no-cache")))
+      (test "value"
+            '(custom-value . "10")
+            (assq 'custom-value (header-values 'pragma headers)))
+      (test "no value"
+            '(no-cache . #t) (assq 'no-cache (header-values 'pragma headers))))
+    (let ((headers (test-read-headers "Cache-control: private=\"accept-encoding, accept-ranges\"\r\nCache-control: must-revalidate")))
+      (test "private with values"
+            '(private . (accept-encoding accept-ranges))
+            (assq 'private (header-values 'cache-control headers)))
+      (test "Acts like a multi-header"
+            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
+
+  ;; RFC 2616, 14.15  &  RFC 1864 (Base64)
+  (test-group "base64-parser"
+    (let ((headers (test-read-headers "Content-md5: Q2hlY2sgSW50ZWdyaXR5IQ==")))
+      (test "md5 is base64-decoded"
+            "Check Integrity!"
+            (header-value 'content-md5 headers))))
+
+  (test-group "range-parser"
+    (let ((headers (test-read-headers "content-range: bytes 500-999/1234")))
+      (test "Simple range"
+            '(500 999 1234)
+            (header-value 'content-range headers))))
+
+  (test-group "content-disposition"
+    (let ((headers (test-read-headers "Content-Disposition: attachment; filename=dir/foo.jpg")))
+      (test "Attachment with filename parameter containing directory"
+            `(attachment (filename . "foo.jpg"))
+            (cons (header-value  'content-disposition headers)
+                  (header-params 'content-disposition headers))))
+    (let ((headers (test-read-headers "Content-Disposition: inline; filename=foo.jpg; creation-date=Sun, 06 Nov 1994 08:49:37 GMT")))
+      (test "Inline with filename and (not quoted) creation-date parameter"
+            `(inline
+              (filename . "foo.jpg")
+              (creation-date . ,(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))))
+            (cons (header-value  'content-disposition headers)
+                  (map (lambda (x)
+                         (if (vector? (cdr x))
+                             (cons (car x) (utc-time->seconds (cdr x)))
+                             x))
+                       (header-params 'content-disposition headers)))))
+    (let ((headers (test-read-headers "Content-Disposition: inline; read-date=\"Sun, 06 Nov 1994 08:49:37 GMT\"; size=100")))
+      (test "Inline with size and (quoted) read-date parameter"
+            `(inline
+              (read-date . ,(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0)))
+              (size . 100))
+            (cons (header-value  'content-disposition headers)
+                  (map (lambda (x)
+                         (if (vector? (cdr x))
+                             (cons (car x) (utc-time->seconds (cdr x)))
+                             x))
+                       (header-params 'content-disposition headers))))))
+
+  (test-group "normalized-uri"
+    (let ((headers (test-read-headers "Location: http://example.com/foo")))
+      (test "Uri"
+            (uri-reference "http://example.com/foo")
+            (header-value 'location headers)))
+    (let ((headers (test-read-headers "Location: http://example.com/foo/../bar")))
+     (test "Auto-normalization"
+           (uri-reference "http://example.com/bar")
+           (header-value 'location headers))))
+
+  (test-group "etag-parser"
+    (let ((headers (test-read-headers "Etag: \"foo\"")))
+      (test "Strong tag"
+            '(strong . "foo")
+            (header-value 'etag headers)))
+    (let ((headers (test-read-headers "Etag: W/\"bar\"")))
+      (test "Weak tag"
+            '(weak . "bar")
+            (header-value 'etag headers)))
+    (let ((headers (test-read-headers "Etag: \"\"")))
+      (test "Empty tag"
+            '(strong . "")
+            (header-value 'etag headers)))
+    (let ((headers (test-read-headers "Etag: \"W/bar\"")))
+        (test "Strong tag, containing W/ prefix"
+              '(strong . "W/bar")
+              (header-value 'etag headers))))
+
+  (test-group "if-match parser"
+    (let ((headers (test-read-headers "If-match: foo")))
+      (test "Strong etag"
+            '(strong . "foo")
+            (header-value 'if-match headers)))
+    (let ((headers (test-read-headers "If-match: W/foo")))
+      (test "Weak etag"
+            '(weak . "foo")
+            (header-value 'if-match headers)))
+    (let ((headers (test-read-headers "If-match: W/foo bar")))
+      (test "Multiple etags"
+            '((weak . "foo") (strong . "bar"))
+            (header-values 'if-match headers)))
+    (let ((headers (test-read-headers "If-match: *")))
+      (test "Wildcard"
+            '*
+            (header-value 'if-match headers))))
+
+  (test-group "http-date-parser"
+    (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
+      (test "RFC1123 time"
+            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
+            (utc-time->seconds (header-value 'date headers))))
+    (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
+      (test "RFC850 time"
+            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
+            (utc-time->seconds (header-value 'date headers))))
+    (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
+      (test "asctime time"
+            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
+            (utc-time->seconds (header-value 'date headers)))))
+
+  ;; This seems a little excessive.. Maybe find a way to reduce the number
+  ;; of cases and still have a good representative test?
+  (test-group "If-Range parser"
+    (let ((headers (test-read-headers "If-Range: Sun, 06 Nov 1994 08:49:37 GMT")))
+      (test "RFC1123 time"
+            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
+            (utc-time->seconds (header-value 'if-range headers))))
+    (let ((headers (test-read-headers "If-Range: Sunday, 06-Nov-94 08:49:37 GMT")))
+      (test "RFC850 time"
+            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
+            (utc-time->seconds (header-value 'if-range headers))))
+    (let ((headers (test-read-headers "If-Range: Sun Nov  6 08:49:37 1994")))
+      (test "asctime time"
+            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
+            (utc-time->seconds (header-value 'if-range headers))))
+    (let ((headers (test-read-headers "If-Range: \"foo\"")))
+      (test "Strong Etag"
+            '(strong . "foo")
+            (header-value 'if-range headers)))
+    (let ((headers (test-read-headers "If-Range: W/\"bar\"")))
+      (test "Weak Etag"
+            '(weak . "bar")
+            (header-value 'if-range headers)))
+    (let ((headers (test-read-headers "If-Range: \"\"")))
+      (test "Empty Etag"
+            '(strong . "")
+            (header-value 'if-range headers)))
+    (let ((headers (test-read-headers "If-Range: \"W/bar\"")))
+        (test "Strong Etag, containing W/ prefix"
+              '(strong . "W/bar")
+              (header-value 'if-range headers)))    )
+
+  (test-group "via parser"
+    (let ((headers (test-read-headers "Via: 1.1")))
+      (test "simple"
+            '("1.1")
+            (header-values 'via headers)))
+    (let ((headers (test-read-headers "Via: 1.1 foo:80 (comment)")))
+      (test "complex"
+            '("1.1 foo:80 (comment)")
+            (header-values 'via headers)))
+    (let ((headers (test-read-headers "Via: 1.1 foo")))
+      (test "one hop"
+            '("1.1 foo")
+            (header-values 'via headers)))
+    (let ((headers (test-read-headers "Via: 1.1 foo, 1.0 bar")))
+      (test "two hops"
+            '("1.1 foo" "1.0 bar")
+            (header-values 'via headers))))
+
+  (test-group "product parser"
+    (test "Simple product"
+          '("websocket" . #f)
+          (header-value 'upgrade (test-read-headers "Upgrade: websocket\r\n")))
+    (test "Product with version"
+          '("TLS" . "1.0")
+          (header-value 'upgrade (test-read-headers "Upgrade: TLS/1.0\r\n"))))
+
+  (test-group "software parser"
+    (test "Simple product"
+          '(("Mozilla" "5.0" #f))
+          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla/5.0\r\n")))
+    (test "Product with comment"
+          '(("Mozilla" #f "foo"))
+          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla (foo)\r\n")))    
+    (test "Realistic product (comments, semicolons)"
+          '(("Mozilla" "5.0" "X11; U; NetBSD amd64; en-US; rv:1.9.0.3") ("Gecko" "2008110501" #f) ("Minefield" "3.0.3" #f))
+          (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")))
+    ;; Reported by Peter Danenberg; Google Drive returns this header
+    (test "Realistic product (quoted comment)"
+          '(("UploadServer" #f "Built on May 4 2015 17:31:43 (1430785903)"))
+          (header-value 'server (test-read-headers "Server: UploadServer (\"Built on May 4 2015 17:31:43 (1430785903)\")\r\n"))))
+
+  (test-group "Set-Cookie parser"
+    (let* ((headers (test-read-headers "Set-Cookie: foo=\"bar\"")))
+      (test "Simple name/value pair"
+            '("foo" . "bar")
+            (get-value (first (header-contents 'set-cookie headers)))))
+    (let* ((headers (test-read-headers "Set-Cookie: foo=qux\r\nSet-Cookie: Foo=\"bar\"")))
+      ;; XXX: Should intarweb remove these, or should the user code handle this?
+      ;; What if interacting with actual broken code on the other side?
+      (test "Multiple cookies with same name (CI) are all kept"
+            '(("foo" . "qux") ("Foo" . "bar"))
+            (map get-value (header-contents 'set-cookie headers))))
+    (let* ((headers (test-read-headers "Set-Cookie: Foo=bar")))
+      (test "Cookie names preserve case"
+            '("Foo" . "bar")
+            (get-value (first (header-contents 'set-cookie headers)))))
+    (let ((headers (test-read-headers "Set-Cookie: foo=bar=qux; max-age=10")))
+      (test "Cookie with = signs"
+            '("foo" . "bar=qux")
+            (get-value (first (header-contents 'set-cookie headers)))))
+    (let* ((headers (test-read-headers "Set-Cookie: foo=bar; Comment=\"Hi, there!\", qux=mooh\r\nSet-Cookie: mumble=mutter\r\n")))
+      (test "Comment"
+            "Hi, there!"
+            (get-param 'comment
+                       (first (header-contents 'set-cookie headers))))
+      (test "Multiple cookies in one header"
+            '("qux" . "mooh")
+            (get-value (second (header-contents 'set-cookie headers))))
+      (test "Multiple cookies in multiple headers"
+            '("mumble" . "mutter")
+            (get-value (third (header-contents 'set-cookie headers))))
+      (test "Missing \"secure\" value"
+            #f
+            (get-param 'secure
+                       (third (header-contents 'set-cookie headers)))))
+    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sunday, 20-Jul-08 15:23:42 GMT; secure; path = / ; Port=80,8080")))
+      (test "Missing value"
+            '("foo" . "")
+            (get-value (first (header-contents 'set-cookie headers))))
+      (test "Old-style cookie expires value"
+            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
+            (utc-time->seconds
+             (get-param 'expires
+                        (first (header-contents 'set-cookie headers)))))
+      (test "Secure value"
+            #t
+            (get-param 'secure
+                       (first (header-contents 'set-cookie headers))))
+      (test "Path"
+            (uri-reference "/")
+            (get-param 'path
+                       (first (header-contents 'set-cookie headers))))
+      (test "Port numbers"
+            '(80 8080)
+            (get-param 'port
+                       (first (header-contents 'set-cookie headers)))))
+    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sun, 20 Jul 2008 15:23:42 GMT; secure; path = / ")))
+      (test "Noncompliant syntax cookie expiry value (rfc1123)"
+            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
+            (utc-time->seconds
+             (get-param 'expires
+                        (first (header-contents 'set-cookie headers))))))
+    (let* ((headers (test-read-headers "Set-Cookie: foo=; expires=Sun, 20-Jul-2008 15:23:42 GMT; secure; path = / ")))
+      (test "Noncompliant syntax cookie expiry value (rfc850-like, abbrev day)"
+            (utc-time->seconds '#(42 23 15 20 6 108 0 309 #f 0))
+            (utc-time->seconds
+             (get-param 'expires
+                        (first (header-contents 'set-cookie headers)))))))
+  
+  (test-group "cookie-parser"
+    (let* ((headers (test-read-headers "Cookie: Foo=bar; $Path=/; qux=mooh; $unknown=something")))
+      (test "Multiple cookies in the same header"
+            '(("Foo" . "bar") . ("qux" . "mooh"))
+            (cons
+             (get-value (first  (header-contents 'cookie headers)))
+             (get-value (second (header-contents 'cookie headers)))))
+      (test "Parameters of cookies (spaces stripped)"
+            (uri-reference "/")
+            (get-param 'path (first (header-contents 'cookie headers))))
+      (test "Parameters of cookies"
+            "something"
+            (get-param 'unknown (second (header-contents 'cookie headers)))))
+    (let* ((headers (test-read-headers "Cookie: $Version=\"1\"; Foo=bar; $Path=/; qux=mooh; $unknown=something")))
+      (test "Version string is used for all cookies"
+            (cons 1 1)
+            (cons
+             (get-param 'version (first (header-contents 'cookie headers)))
+             (get-param 'version (second (header-contents 'cookie headers)))))))
+
+  (test-group "strict-transport-security-parser"
+    (let ((headers (test-read-headers "Strict-Transport-Security: max-age=10; includeSubDomains")))
+      (test "max-age is a number"
+            '(max-age . 10)
+            (assq 'max-age (header-value 'strict-transport-security headers)))
+      (test "includeSubDomains without value"
+            '(includesubdomains . #t)
+            (assq 'includesubdomains (header-value 'strict-transport-security headers)))))
+
+  (test-group "headers"
+    (test "Simple test"
+          `(bar qux)
+          (header-values 'foo (headers `((foo bar qux)))))
+    (test "Multi headers are folded"
+          `(bar qux)
+          (header-values 'foo (headers `((foo bar)
+                                         (foo qux)))))
+    (test "Single headers are unique"
+          `(qux)
+          (header-values 'foo (parameterize ((single-headers '(foo)))
+                                (headers `((foo bar)
+                                           (foo qux))))))
+    (test "Extra single headers are ignored"
+          `(qux)
+          (header-values 'foo (parameterize ((single-headers '(foo)))
+                                (headers `((foo bar qux))))))
+    (test "Parameters"
+          `((bar . qux))
+          (get-params
+           (car (header-contents 'foo (headers `((foo #(mooh ((bar . qux))))))))))
+    (test "Multi headers are folded into old headers"
+          `(bar qux)
+          (header-values 'foo (headers `((foo qux))
+                                       (headers `((foo bar))))))))
+
+(define (test-unparse-headers h)
+  (call-with-output-string
+   (lambda (o)
+     (unparse-headers (headers h) o))))
+
+(test-group "unparsers"
+  (test-group "default unparser"
+    (test "String"
+          "Foo: bar\r\n"
+          (test-unparse-headers `((foo "bar"))))
+    (test "Multiple strings"
+          "Foo: bar, qux\r\n"
+          (test-unparse-headers `((foo "bar" "qux"))))
+    (test "Auto-quoting on commas and whitespace"
+          "Foo: \"bar, qux\", \"mooh blah\"\r\n"
+          (test-unparse-headers `((foo "bar, qux" "mooh blah"))))
+    ;; RFC 2616 2.2
+    (test "Escaping quotes"
+          "Foo: \"bar \\\" qux\", mooh\r\n"
+          (test-unparse-headers `((foo "bar \" qux" "mooh"))))
+    (test "Escaping control characters"
+          "Foo: \"bar\\\r\\\x01qux\"\r\n"
+          (test-unparse-headers `((foo "bar\r\x01qux"))))
+    ;; Unfortunately, there are no or very few HTTP implementations
+    ;; which understand that newlines can be escaped with a backslash
+    ;; in a quoted string. That's why we don't allow it.
+    ;; The user is expected to escape the newlines according to the type
+    ;; of header (URLencoding, removing the newlines from cookies, etc)
+    (test-error* "Embedded newlines throw an error"
+                 (exn http unencoded-header)
+                 (test-unparse-headers `((foo "bar\n\x01qux"))))
+    (test "Alist"
+          "Foo: Bar=qux, Mooh=mumble\r\n"
+          (test-unparse-headers `((foo (bar . qux) (mooh . mumble)))))
+    (test "Alist with escapes"
+          "Foo: Bar=qux, Mooh=\"mum, ble\"\r\n"
+          (test-unparse-headers `((foo (bar . "qux") (mooh . "mum, ble")))))
+    (test "URI"
+          "Foo: http://foo.com/bar;xyz?a=b\r\n"
+          (test-unparse-headers `((foo ,(uri-reference "http://foo.com/bar;xyz?a=b")))))
+    (test "Parameters"
+          "Foo: bar; qux=mooh; mumble=mutter; blah\r\n"
+          (test-unparse-headers `((foo #(bar ((qux . mooh)
+                                              (mumble . mutter)
+                                              (blah . #t)
+                                              (feh . #f)))))))
+    (test "Raw headers are unparsed as-is"
+          "Foo: bla bla; whatever \"ohai\"\r\n"
+          (test-unparse-headers `((foo #("bla bla; whatever \"ohai\"" raw)))))
+    (test "Raw headers are unparsed as-is for known headers, too"
+          "Etag: \"hi there\r\n" ;; unclosed quote is intentional here
+          (test-unparse-headers `((etag #("\"hi there" raw)))))
+    (test-error* "Embedded newlines in raw headers also throw an error"
+                 (exn http unencoded-header)
+                 (test-unparse-headers `((foo #("bar\n\x01qux" raw))))))
+  (test-group "etag unparser"
+    (test "Weak tag"
+          "Etag: W/\"blah\"\r\n"
+          (test-unparse-headers `((etag (weak . "blah")))))
+    (test "Strong tag"
+          "Etag: \"blah\"\r\n"
+          (test-unparse-headers `((etag (strong . "blah")))))
+    (test "Strong tag starting with W/"
+          "Etag: \"W/blah\"\r\n"
+          (test-unparse-headers `((etag (strong . "W/blah"))))))
+  (test-group "if-match unparser"
+    (test "List of etags"
+          "If-Match: \"foo\", \"bar\", W/\"qux\"\r\n"
+          (test-unparse-headers
+           `((if-match (strong . "foo") (strong . "bar") (weak . "qux")))))
+    (test "Wildcard"
+          "If-Match: *\r\n"
+          (test-unparse-headers
+           `((if-match (strong . "foo") * (weak . "qux"))))))
+  ;; http-dates are all deserialized as rfc1123
+  (test-group "date/time unparser"
+    (test "RFC1123 time"
+          "If-Modified-Since: Sun, 06 Nov 1994 08:49:37 GMT\r\n"
+          ;; Having to specify a vector here twice is sucky and counter-intuitive
+          (test-unparse-headers
+           `((if-modified-since #(#(37 49 08 06 10 94 0 310 #f 0) ()))))))
+  (test-group "host/port unparser"
+    (test "No port specified"
+          "Host: foo.example.com\r\n"
+          (test-unparse-headers `((host ("foo.example.com" . #f)))))
+    (test "Different port"
+          "Host: foo.example.com:8080\r\n"
+          (test-unparse-headers `((host ("foo.example.com" . 8080))))))
+  (test-group "product unparser"
+    (test "Products without version"
+          "Upgrade: websocket, foo\r\n"
+          (test-unparse-headers `((upgrade ("websocket" . #f) ("foo" . #f)))))
+    (test "Products with version"
+          "Upgrade: TLS/1.0, bar/2\r\n"
+          (test-unparse-headers `((upgrade ("TLS" . "1.0") ("bar" . "2"))))))
+  (test-group "software unparser"
+    (test "Product with comments"
+          "User-Agent: Mozilla (X11) Gecko/2008110501\r\n"
+          (test-unparse-headers `((user-agent (("Mozilla" #f "X11") ("Gecko" "2008110501" #f))))))
+    (test "Realistic product"
+          "User-Agent: Mozilla/5.0 (X11; U; NetBSD amd64; en-US; rv:1.9.0.3) Gecko/2008110501 Minefield/3.0.3\r\n"
+          (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)))))))
+  (test-group "cookie unparser"
+    (test "Basic cookie"
+          "Cookie: foo=bar; $Path=/; Qux=mooh; $Unknown=something\r\n"
+          (test-unparse-headers `((cookie #(("foo" . "bar")
+                                            ((path . ,(uri-reference "/"))))
+                                          #(("Qux" . "mooh")
+                                            ((unknown . "something")))))))
+    (test "Port list"
+          "Cookie: Foo=bar; $Port=80,8080\r\n"
+          (test-unparse-headers `((cookie #(("Foo" . "bar")
+                                            ((port . (80 8080))))))))
+    (test "#t or #f values"
+          "Cookie: Foo=bar; $Port\r\n"
+          (test-unparse-headers `((cookie #(("Foo" . "bar")
+                                            ((port . #t) (domain . #f))))))))
+  (test-group "Set-Cookie unparser"
+    (test "Simple name/value pair"
+          "Set-Cookie: foo=\"bar with space\"\r\n"
+          (test-unparse-headers `((set-cookie ("foo" . "bar with space")))))
+    ;; XXX: Should intarweb remove these, or should the user code handle this?
+    ;; What if interacting with actual broken code on the other side?
+    (test "Multiple cookies with same name (CI) are all written"
+          "Set-Cookie: foo=qux\r\nSet-Cookie: Foo=bar\r\n"
+          (test-unparse-headers `((set-cookie ("foo" . "qux") ("Foo" . "bar")))))
+    (test "Cookie names preserve case"
+          "Set-Cookie: Foo=bar\r\n"
+          (test-unparse-headers `((set-cookie ("Foo" . "bar")))))
+    (test "Cookie with = signs"
+          "Set-Cookie: foo=\"bar=qux\"; Max-Age=10\r\n"
+          (test-unparse-headers `((set-cookie #(("foo" . "bar=qux") ((max-age . 10)))))))
+    (test "Comment"
+          "Set-Cookie: foo=bar; Comment=\"Hi, there!\"\r\n"
+          (test-unparse-headers `((set-cookie #(("foo" . "bar")
+                                                ((comment . "Hi, there!")))))))
+    (test "Old-style cookie expires value"
+          "Set-Cookie: foo=; Expires=Sunday, 20-Jul-08 15:23:42 GMT\r\n"
+          (test-unparse-headers `((set-cookie #(("foo" . "")
+                                                ((expires . #(42 23 15 20 6 108 0 309 #f 0))))))))    
+    (test "Secure (true)"
+          "Set-Cookie: foo=bar; Secure\r\n"
+          (test-unparse-headers `((set-cookie #(("foo" . "bar")
+                                                ((secure . #t)))))))
+    (test "Secure (false)"
+          "Set-Cookie: foo=bar\r\n"
+          (test-unparse-headers `((set-cookie #(("foo" . "bar")
+                                                ((secure . #f)))))))
+
+    (test "Path"
+          "Set-Cookie: foo=bar; Path=/blah\r\n"
+          (test-unparse-headers `((set-cookie #(("foo" . "bar")
+                                                ((path . ,(uri-reference "/blah"))
+                                                 (secure . #f))))))))  
+  (test-group "authorization unparser"
+    (test "Basic auth"
+          "Authorization: Basic QWxpIEJhYmE6b3BlbiBzZXNhbWU=\r\n"
+          (test-unparse-headers
+           `((authorization #(basic
+                              ((username . "Ali Baba")
+                               (password . "open sesame")))))))
+    (test-error* "Basic auth with colon in username"
+                 (exn http username-with-colon)
+                 (test-unparse-headers
+                  `((authorization #(basic
+                                     ((username . "foo:bar")
+                                      (password . "qux")))))))
+    (test "Digest auth"
+          "Authorization: Digest username=\"Mufasa\", realm=\"testrealm@host.com\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", uri=\"/dir/index.html\", qop=\"auth\", cnonce=\"0a4f113b\", response=\"6629fae49393a05397450978507c4ef1\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\", nc=00000001, algorithm=\"md5\"\r\n"
+          (test-unparse-headers
+           `((authorization #(digest
+                              ((username . "Mufasa")
+                               (realm . "testrealm@host.com")
+                               (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
+                               (uri . ,(uri-reference "/dir/index.html"))
+                               (qop . auth)
+                               (cnonce . "0a4f113b")
+                               (response . "6629fae49393a05397450978507c4ef1")
+                               (opaque . "5ccc069c403ebaf9f0171e9517f40e41")
+                               (nc . 1)
+                               (algorithm . md5)))))))
+    (test "Custom auth"
+          "Authorization: Custom some-random-contents\r\n"
+          (parameterize ((authorization-param-subunparsers
+                          `((custom . ,(lambda (params)
+                                         (alist-ref 'contents params)))
+                            . ,(authorization-param-subparsers))))
+            (test-unparse-headers
+             `((authorization #(custom ((contents . some-random-contents)))))))))
+
+  (test-group "authenticate unparser"
+    (test-group "basic auth"
+      (test "basic"
+            "Www-Authenticate: Basic realm=\"WallyWorld\"\r\n"
+            (test-unparse-headers
+             `((www-authenticate #(basic
+                                   ((realm . "WallyWorld"))))))))
+    (test-group "digest auth"
+      (test "digest"
+            "Www-Authenticate: Digest realm=\"testrealm@host.com\", qop=\"auth,auth-int\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\"\r\n"
+            (test-unparse-headers
+             `((www-authenticate #(digest
+                                   ((realm . "testrealm@host.com")
+                                    (qop . (auth auth-int))
+                                    (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
+                                    (opaque . "5ccc069c403ebaf9f0171e9517f40e41")))))))
+      (test "domains"
+            "Www-Authenticate: Digest domain=\"/example http://foo.com/bar\"\r\n"
+            (test-unparse-headers
+             `((www-authenticate #(digest
+                                   ((domain . (,(uri-reference "/example")
+                                               ,(uri-reference "http://foo.com/bar")))))))))
+      (test "stale"
+            "Www-Authenticate: Digest realm=\"foo\", stale=TRUE\r\n"
+            (test-unparse-headers
+             `((www-authenticate #(digest
+                                   ((realm . "foo")
+                                    (stale . #t)))))))
+      (test "stale present but false"
+            "Www-Authenticate: Digest realm=\"foo\"\r\n"
+            (test-unparse-headers
+             `((www-authenticate #(digest
+                                   ((realm . "foo")
+                                    (stale . #f)))))))))
+  (test-group "content-disposition unparser"
+    (test "Attributes are always fully quoted and filenames stripped"
+          "Content-Disposition: form-data; name=\"foo\"; filename=\"a b c\"\r\n"
+          (test-unparse-headers `((content-disposition
+                                   #(form-data ((name . foo)
+                                                (filename . "blabla/a b c")))))))
+    (test "Size and dates are recognised correctly"
+          "Content-Disposition: inline; size=20; creation-date=\"Sun, 06 Nov 1994 08:49:37 GMT\"\r\n"
+          (test-unparse-headers `((content-disposition
+                                   #(inline ((size . 20)
+                                             (creation-date . #(37 49 08 06 10 94 0 310 #f 0)))))))))
+
+  (test-group "strict-transport-security unparser"
+    (test "Silly capitalization is honored, even if unneccessary"
+          "Strict-Transport-Security: max-age=10; includeSubDomains\r\n"
+          (test-unparse-headers `((strict-transport-security
+                                   ((max-age . 10)
+                                    (includesubdomains . #t))))))))
+
+(define (test-read-request str)
+  (call-with-input-string str read-request))
+
+(test-group "reading of requests"
+  (parameterize ((request-parsers `(,(lambda (line in)
+                                       (and (string=? line "foo") 'foo))
+                                    ,(lambda (line in)
+                                       (and (string=? line "bar") 'bar)))))
+    (test-error* (exn http unknown-protocol-line) (test-read-request "qux"))
+    (test #f (test-read-request ""))
+    (test 'foo (test-read-request "foo"))
+    (test 'bar (test-read-request "bar")))
+  ;; Even though we officially "should" support HTTP/0.9, we disable it
+  ;; by default because there are security implications of just outputting
+  ;; responses for random resources that might be under attacker control.
+  (test-group "HTTP/0.9"
+    (test-error* "By default, HTTP/0.9 is disabled"
+                 (exn http unknown-protocol-line)
+                 (test-read-request "GET /path/../to/stuff?arg1=val1&arg2=val2\r\n"))
+    (parameterize ((request-parsers (list http-1.x-request-parser http-0.9-request-parser)))
+     (let ((req (test-read-request "GET /path/../to/stuff?arg1=val1&arg2=val2\r\n")))
+       (test 0 (request-major req))
+       (test 9 (request-minor req))
+       (test 'GET (request-method req))
+       ;; Path-normalized URI (dots removed)
+       (test (uri-reference "/to/stuff?arg1=val1&arg2=val2") (request-uri req))
+       (test (headers '()) (request-headers req)))
+     ;; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
+     ;; It only mentions it in the context of HTTP/1.x (section 5.1.1).
+     ;; We obey the BNF syntax rule in 2.1:
+     ;;     "literal" - Quotation marks surround literal text.
+     ;;                 Unless stated otherwise, the text is case-insensitive.
+     ;; Section 4.1 defines:
+     ;;     Simple-Request  = "GET" SP Request-URI CRLF
+     (test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
+     (test-error "0.9 only knows GET" (test-read-request "PUT /path"))))
+  (test-group "HTTP/1.0"
+    (test-error "Asterisk is not allowed for HTTP/1.0"
+                (request-uri (test-read-request "OPTIONS * HTTP/1.0\r\n")))
+    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
+      (test 1 (request-major req))
+      (test 0 (request-minor req))
+      (test 'GET (request-method req))
+      (test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
+      (test (headers '()) (request-headers req)))
+    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n")))
+    (let ((req (test-read-request "POST / HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n")))
+      (test "Chunking ignored"
+            "3\r\nfoo\r\na\r\n1234567890\r\n"
+            (read-string #f (request-port req)))))
+  (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
+    (test "Asterisk is treated specially and returns #f uri"
+          #f (request-uri (test-read-request "OPTIONS * HTTP/1.1\r\n")))
+   (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
+     (test 1 (request-major req))
+     (test 1 (request-minor req)))
+   (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
+   ; RFC 2616 5.1.1
+   (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
+   ; RFC 2616 3.1 + case-insensitivity BNF rule
+   (test "Protocol is case-insensitive" '1 (request-minor (test-read-request "GET /path htTP/1.1\r\n\r\n")))
+   ;; TODO: Test chunking
+   (test-error "Request line limit exceeded gives error"
+               (parameterize ((http-line-limit 5))
+                 (test-read-request "GET /path HTTP/1.1\r\n\r\n")))
+   (test "Reading request body"
+         '((abc . "def") (ghi . "jkl"))
+         (let ((req (test-read-request
+                     "GET / HTTP/1.1\r\nContent-Length: 15\r\n\r\nabc=def;ghi=jkl")))
+           (read-urlencoded-request-data req)))
+   (test "Reading request body with bigger limit"
+         '((abc . "def"))
+         (let ((req (test-read-request
+                     "GET / HTTP/1.1\r\nContent-Length: 7\r\n\r\nabc=def")))
+           ;; Test for 8, since 7 would error
+           (parameterize ((http-urlencoded-request-data-limit 8))
+             (read-urlencoded-request-data req))))
+   (test-error "Request body limit exceeded gives error"
+               (let ((req (test-read-request
+                           "GET / HTTP/1.1\r\nContent-Length: 7\r\n\r\nabc=def")))
+                 ;; This errors when the limit is hit, not when it is exceeded
+                 (parameterize ((http-urlencoded-request-data-limit 7))
+                   (read-urlencoded-request-data req))))
+   (let ((req (test-read-request "POST / HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n0\r\n\r\n")))
+      (test "Chunking"
+            "foo1234567890"
+            (read-string #f (request-port req)))))
+  (test-group "Invalid protocols"
+    (test-error "Total cruft is unrecognised"
+                (test-read-request "whatever\r\n"))
+    (test-error "Invalid URI also causes protocol not to be recognised"
+                (test-read-request "GET //path HTTP/1.0\r\n"))))
+
+(define (test-write-request req . outputs)
+  (call-with-output-string
+    (lambda (out)
+      (request-port-set! req out)
+      (let ((r (write-request req)))
+       (for-each (lambda (output)
+		   (display output (request-port r)))
+		 outputs)
+       (finish-request-body r)))))
+
+(test-group "writing of requests"
+  ;; This can also be called Simple-Request as per RFC 1945 4.1
+  ;; RFC 2616 19.6 also states we should recognise 0.9 requests, but if
+  ;; we understand those we should also be able to generate them because
+  ;; a 0.9 server does not understand 1.x requests.
+  (test-group "HTTP/0.9"
+    (let ((req (make-request major: 0 minor: 9 method: 'GET
+                             uri: (uri-reference "/foo/bar.html"))))
+      (test-error* "By default, HTTP/0.9 is disabled"
+                   (exn http unknown-protocol)
+                   (test-write-request req))
+      (parameterize ((request-unparsers (list http-1.x-request-unparser
+                                              http-1.0-request-unparser
+                                              http-0.9-request-unparser)))
+        (test "Always empty headers"
+              "GET /foo/bar.html\r\n"
+              (test-write-request (update-request req
+                                                  headers:
+                                                  (headers `((foo bar))))))
+        (test "Always GET"
+              "GET /foo/bar.html\r\n"
+              (test-write-request (update-request req method: 'POST))))))
+  (test-group "HTTP/1.0"
+    (let ((req (make-request major: 1 minor: 0
+                             method: 'GET
+                             uri: (uri-reference "/foo/bar.html"))))
+      (test "Headers"
+            "GET /foo/bar.html HTTP/1.0\r\nFoo: bar\r\n\r\ntest"
+            (test-write-request
+             (update-request req
+                             headers: (headers `((foo bar))))
+             "test"))
+      (test "Chunking ignored"
+            "GET /foo/bar.html HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\nfoobar"
+            (test-write-request
+             (update-request req
+                             headers: (headers `((transfer-encoding chunked))))
+             "foo" "" "bar"))))
+  (test-group "HTTP/1.1"
+    (let ((req (make-request major: 1 minor: 1
+                             method: 'GET
+                             uri: (uri-reference "/foo/bar.html"))))
+      (test "Headers"
+            "GET /foo/bar.html HTTP/1.1\r\nFoo: bar\r\n\r\ntest"
+            (test-write-request
+             (update-request req
+                             headers: (headers `((foo bar))))
+             "test"))
+      (test "Chunking"
+            "GET /foo/bar.html HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n0\r\n\r\n"
+            (test-write-request
+             (update-request req
+                             headers: (headers `((transfer-encoding chunked))))
+             "foo" "" "1234567890"))
+      (test "OPTIONS-type asterisk if no URI"
+            "OPTIONS * HTTP/1.1\r\n\r\n"
+            (test-write-request
+             (update-request req method: 'OPTIONS uri: #f))))))
+
+(define (test-read-response input-string)
+  (call-with-input-string input-string read-response))
+
+(test-group "reading of responses"
+  (test-group "HTTP/1.1"
+    (let ((res (test-read-response "HTTP/1.1 303 See other\r\nFoo: bar\r\n\r\nContents")))
+      (test "Version detection"
+            '(1 . 1)
+            (cons (response-major res) (response-minor res)))
+      (test "Status"
+            '(see-other 303 "See other")
+            (list (response-status res) (response-code res) (response-reason res)))
+      (test "Headers"
+            '("bar")
+            (header-values 'foo (response-headers res)))
+      (test "Contents"
+            "Contents"
+            (read-string #f (response-port res))))
+    (test-error* (exn http unknown-protocol-line) (test-read-response "qux"))
+    (test #f (test-read-request ""))
+    (test-error "Response line limit exceeded gives error"
+                (parameterize ((http-line-limit 5))
+                  (test-read-response "HTTP/1.1 200 OK\r\n\r\n")))
+    (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\n0\r\n\r\n")))
+      (test "Chunking"
+            "foo1234567890"
+            (read-string #f (response-port res))))
+    ;; Reported by "sz0ka" via IRC
+    (let ((res (test-read-response "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n5\r\nfoo\r\n\r\n0\r\n\r\n")))
+      (test "First read of chunked port returns first line"
+            "foo"
+            (read-line (response-port res)))
+      (test "Peek-char returns EOF"
+            #!eof
+            (peek-char (response-port res)))
+      (test "Read-char also returns EOF"
+            #!eof
+            (read-char (response-port res)))))
+  (test-group "HTTP/1.0"
+    (let ((res (test-read-response "HTTP/1.0 303 See other\r\nFoo: bar\r\n\r\nContents")))
+      (test "Version detection"
+            '(1 . 0)
+            (cons (response-major res) (response-minor res)))
+      (test "Status"
+            '(303 . "See other")
+            (cons (response-code res) (response-reason res)))
+      (test "Headers"
+            '("bar")
+            (header-values 'foo (response-headers res)))
+      (test "Contents"
+            "Contents"
+            (read-string #f (response-port res))))
+    (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")))
+      (test "Chunking ignored"
+            "3\r\nfoo\r\na\r\n1234567890\r\n"
+            (read-string #f (response-port res)))))
+  (test-group "HTTP/0.9"
+    (test-error* "By default, HTTP/0.9 is disabled"
+                 (exn http unknown-protocol-line)
+                 (test-read-response "Doesn't matter what's here\r\nLine 2"))
+    (parameterize ((response-parsers (list http-1.x-response-parser
+                                           http-1.0-response-parser
+                                           http-0.9-response-parser)))
+      (let ((res (test-read-response "Doesn't matter what's here\r\nLine 2")))
+        (test "Always OK status"
+              '(200 . "OK")
+              (cons (response-code res) (response-reason res)))
+        (test "Version detection; fallback to 0.9"
+              '(0 . 9)
+              (cons (response-major res) (response-minor res)))
+        (test "No headers"
+              (headers '()) (response-headers res))
+        (test "Contents"
+              "Doesn't matter what's here\r\nLine 2"
+              (read-string #f (response-port res)))))))
+
+(define (test-write-response res . outputs)
+  (call-with-output-string
+    (lambda (out)
+      (response-port-set! res out)
+      (let ((r (write-response res)))
+       (for-each (lambda (output)
+		   (display output (response-port r)))
+		 outputs)
+       (finish-response-body r)))))
+
+(test-group "writing of responses"
+  (test-group "HTTP/0.9"
+    (let ((res (make-response major: 0 minor: 9
+                              code: 200 reason: "OK")))
+      (test-error* "By default, HTTP/0.9 is disabled"
+                   (exn http unknown-protocol)
+                   (test-write-response res "These are the contents\r\n"))
+      (parameterize ((response-unparsers (list http-1.x-response-unparser
+                                               http-1.0-response-unparser
+                                               http-0.9-response-unparser)))
+        (test "Headers ignored"
+              "These are the contents\r\n"
+              (test-write-response
+               (update-response res headers: (headers `((foo bar))))
+               "These are the contents\r\n")))))
+  (test-group "HTTP/1.0"
+    (let ((res (make-response major: 1 minor: 0
+                              code: 200 reason: "OK")))
+      (test "Headers used"
+            "HTTP/1.0 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
+            (test-write-response
+             (update-response res headers: (headers `((foo bar))))
+             "These are the contents\r\n"))
+      (test "Status code"
+            "HTTP/1.0 303 See other\r\n\r\nThese are the contents\r\n"
+            (test-write-response
+             (update-response res code: 303 reason: "See other")
+             "These are the contents\r\n"))
+      (test "Chunking ignored"
+            "HTTP/1.0 200 OK\r\nTransfer-Encoding: chunked\r\n\r\nfoo1234567890"
+            (test-write-response
+             (update-response
+              res
+              headers: (headers `((transfer-encoding chunked))))
+             "foo" "1234567890"))))
+  (test-group "HTTP/1.1"
+   (let ((res (make-response major: 1 minor: 1
+                             code: 200 reason: "OK")))
+     (test "Headers used"
+           "HTTP/1.1 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
+            (test-write-response
+             (update-response res headers: (headers `((foo bar))))
+             "These are the contents\r\n"))
+     (test "Status code"
+           "HTTP/1.1 303 See other\r\n\r\nThese are the contents\r\n"
+           (test-write-response
+            (update-response res code: 303 reason: "See other")
+            "These are the contents\r\n"))
+     (test "Chunking"
+           "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n0\r\n\r\n"
+           (test-write-response
+            (update-response
+             res
+             headers: (headers `((transfer-encoding chunked))))
+            "foo" "1234567890"))))
+  (test-group "status"
+    (let ((res (make-response major: 1 minor: 1)))
+      (test "reason and code are looked up by symbol properly"
+            "HTTP/1.1 409 Conflict\r\n\r\ntest"
+            (test-write-response (update-response res status: 'conflict)
+                                 "test"))
+      (test-error "an error is raised for unknown status codes"
+                  (update-response res status: 'unknown))
+      (test "any status can be used when code and reason are given directly"
+            "HTTP/1.1 999 No Way\r\n\r\ntest"
+            (test-write-response 
+             (update-response res code: 999 reason: "No Way")
+             "test"))
+      (test "defaults can be parameterized"
+            "HTTP/1.1 999 Say What\r\n\r\ntest"
+            (parameterize ((http-status-codes
+                            (alist-cons 'say-what (cons 999 "Say What")
+                                        (http-status-codes))))
+              (test-write-response (update-response res status: 'say-what)
+                                   "test"))))))
+
+(test-group "etag comparison procedures"
+  (test-group "weak comparison"
+    (test-assert "Strong etag does not match list not containing it"
+                 (not (etag-matches-weakly?
+                       '(strong . "xyz") `((strong . "blabla")))))
+    (test-assert "Weak etag does not match list not containing it"
+                 (not (etag-matches-weakly?
+                       '(weak . "xyz") `((weak . "blabla")))))
+    (test-assert "Weak etag matches list containing it"
+                 (etag-matches-weakly?
+                  '(weak . "xyz") `((strong . "blabla") (weak . "xyz"))))
+    (test-assert "Strong etag matches list containing it"
+                 (etag-matches-weakly?
+                  '(strong . "xyz") `((strong . "blabla") (strong . "xyz"))))
+    (test-assert "Weak etag does not match list containing same tag but strong"
+                 (not (etag-matches-weakly?
+                       '(weak . "xyz") `((strong . "blabla") (strong . "xyz")))))
+    (test-assert "Strong etag does not match list containing same tag but weak"
+                 (not (etag-matches-weakly?
+                       '(strong . "xyz") `((strong . "blabla") (weak . "xyz")))))
+    (test-assert "Weak etag matches list containing wildcard"
+                 (etag-matches-weakly?
+                  '(weak . "xyz") `((strong . "blabla") *)))
+    (test-assert "Strong etag matches list containing wildcard"
+                 (etag-matches-weakly?
+                  '(strong . "xyz") `((strong . "blabla") *))))
+  (test-group "strong comparison"
+    (test-assert "Strong etag does not match list not containing it"
+                 (not (etag-matches?
+                       '(strong . "xyz") `((strong . "blabla")))))
+    (test-assert "Weak etag does not match list not containing it"
+                 (not (etag-matches?
+                       '(weak . "xyz") `((weak . "blabla")))))
+    (test-assert "Weak etag does *not* match list containing it"
+                 (not (etag-matches?
+                       '(weak . "xyz") `((strong . "blabla") (weak . "xyz")))))
+    (test-assert "Strong etag matches list containing it"
+                 (etag-matches?
+                  '(strong . "xyz") `((strong . "blabla") (strong . "xyz"))))
+    (test-assert "Weak etag does not match list containing same tag but strong"
+                 (not (etag-matches?
+                       '(weak . "xyz") `((strong . "blabla") (strong . "xyz")))))
+    (test-assert "Strong etag does not match list containing same tag but weak"
+                 (not (etag-matches?
+                       '(strong . "xyz") `((strong . "blabla") (weak . "xyz")))))
+    (test-assert "Weak etag matches list containing wildcard"
+                 (etag-matches?
+                  '(weak . "xyz") `((strong . "blabla") *)))
+    (test-assert "Strong etag matches list containing wildcard"
+                 (etag-matches?
+                  '(strong . "xyz") `((strong . "blabla") *)))))
+
+
+;; We don't expose chunked-output-port/chunked-input-port.  Maybe we should?
+;; To work around this, prepend some stuff and parse some headers
+(define (chunked-inport string)
+  (let ((res (test-read-response
+              (string-append
+               "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n"
+               string))))
+    (response-port res)))
+
+(test-group "Chunked ports"
+  (let ((s "5\r\nab\ncd\r\n2\r\n\nx\r\n0\r\nDO NOT WANT"))
+    (test "read-lines" '("ab" "cd" "x") (read-lines (chunked-inport s)))
+    (let ((p (chunked-inport s)))
+      (test "read-char" #\a (read-char p))
+      (test "peek-char" #\b (peek-char p))
+      (test "partial read" "b\n" (read-string 2 p))
+      (test "short read" "c" (read-string 1 p))
+      (test "read across chunk boundaries" "d\nx" (read-string 3 p))
+      (test "read at eof" #!eof (read-string 1 p)))
+    (test "read beyond chunked port size"
+          "ab\ncd\nx" (read-string 10 (chunked-inport s)))))
+
+(test-end)
+
+(unless (zero? (test-failure-count)) (exit 1))
+
+;; TODO:
+;; - Fix the parsing system so it's not so broken (more comfortable combinators)
+;; - Test malformed headers
+;; - Add parsing capability for quoted-pairs inside tokens and comments
+;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level