(import scheme chicken.base chicken.port chicken.condition chicken.time.posix srfi-1 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 "") ((?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