diff options
| -rw-r--r-- | intarweb.scm | 14 | ||||
| -rw-r--r-- | tests/run.scm | 26 |
2 files changed, 20 insertions, 20 deletions
diff --git a/intarweb.scm b/intarweb.scm index ffea2a2..d2cca10 100644 --- a/intarweb.scm +++ b/intarweb.scm @@ -100,7 +100,7 @@ basic-auth-param-subunparser digest-auth-param-subunparser ) -(import scheme (chicken base) (chicken foreign) (chicken irregex) +(import scheme (scheme base) (chicken base) (chicken foreign) (chicken irregex) (chicken format) (chicken io) (chicken string) (chicken time posix) (chicken pathname) (chicken fixnum) (chicken condition) (chicken port) (chicken syntax) @@ -153,8 +153,8 @@ ;; that deal with headers. (define-record headers v) -(define-record-printer (headers h out) - (fprintf out "#(headers: ~S)" (headers-v h))) +(set-record-printer! headers (lambda (h out) + (fprintf out "#(headers: ~S)" (headers-v h)))) (define headers->list headers-v) @@ -271,7 +271,7 @@ (fprintf port "~X\r\n~A\r\n" len s)))) (lambda () ; close (close-output-port port)) - (lambda () ; flush + force-output: (lambda () (flush-output port))))) ;; first "reserved" slot ;; Slot 7 should probably stay 'custom @@ -312,12 +312,12 @@ (or (not position) (char-ready? port))) (lambda () ; close (close-input-port port)) - (lambda () ; peek-char + peek-char: (lambda () (check-position) (if position (peek-char port) #!eof)) - (lambda (p bytes buf off) ; read-string! + read-bytevector: (lambda (p bytes buf off) (let lp ((todo bytes) (total-bytes-read 0) (off off)) @@ -325,7 +325,7 @@ (if (or (not position) (= todo 0)) total-bytes-read (let* ((n (min todo (- chunk-length position))) - (bytes-read (read-string! n buf port off))) + (bytes-read (read-bytevector! buf port off (+ off n)))) (set! position (+ position bytes-read)) (lp (- todo bytes-read) (+ total-bytes-read bytes-read) diff --git a/tests/run.scm b/tests/run.scm index 95a3990..f6f99ee 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,5 +1,5 @@ (import scheme chicken.base chicken.port - chicken.condition chicken.time.posix srfi-1 + 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 @@ -138,7 +138,7 @@ (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" @@ -235,7 +235,7 @@ (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\""))) @@ -277,7 +277,7 @@ (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" @@ -482,7 +482,7 @@ (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"))) + (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"))) @@ -558,7 +558,7 @@ (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" @@ -635,8 +635,8 @@ "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")))) + "Foo: \"bar\\\r\\\x01;qux\"\r\n" + (test-unparse-headers `((foo "bar\r\x01;qux")))) ;; 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. @@ -644,7 +644,7 @@ ;; 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-unparse-headers `((foo "bar\n\x01;qux")))) (test "Alist" "Foo: Bar=qux, Mooh=mumble\r\n" (test-unparse-headers `((foo (bar . qux) (mooh . mumble))))) @@ -668,7 +668,7 @@ (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-unparse-headers `((foo #("bar\n\x01;qux" raw)))))) (test-group "content-range unparser" (test "Full content-range" "Content-Range: bytes 500-999/1234\r\n" @@ -763,7 +763,7 @@ (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)))))))) + ((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") @@ -777,7 +777,7 @@ "Set-Cookie: foo=bar; Path=/blah\r\n" (test-unparse-headers `((set-cookie #(("foo" . "bar") ((path . ,(uri-reference "/blah")) - (secure . #f)))))))) + (secure . #f)))))))) (test-group "authorization unparser" (test "Basic auth" "Authorization: Basic QWxpIEJhYmE6b3BlbiBzZXNhbWU=\r\n" @@ -1180,7 +1180,7 @@ (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 + (test-write-response (update-response res code: 999 reason: "No Way") "test")) (test "defaults can be parameterized" |