diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/run.scm | 1243 |
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 |