diff --git a/module/web/request.scm b/module/web/request.scm index 84bc36e9b..aa807d92a 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -38,11 +38,8 @@ build-request write-request - read-request-body/latin-1 - write-request-body/latin-1 - - read-request-body/bytevector - write-request-body/bytevector + read-request-body + write-request-body ;; General headers ;; @@ -198,44 +195,7 @@ on @var{port}, perhaps using some transfer encoding." (make-request (request-method r) (request-uri r) (request-version r) (request-headers r) (request-meta r) port))) -;; Probably not what you want to use "in production". Relies on one byte -;; per char because we are in latin-1 encoding. -;; -(define (read-request-body/latin-1 r) - "Reads the request body from @var{r}, as a string. - -Assumes that the request port has ISO-8859-1 encoding, so that the -number of characters to read is the same as the -@code{request-content-length}. Returns @code{#f} if there was no request -body." - (cond - ((request-content-length r) => - (lambda (nbytes) - (let ((buf (make-string nbytes)) - (port (request-port r))) - (let lp ((i 0)) - (cond - ((< i nbytes) - (let ((c (read-char port))) - (cond - ((eof-object? c) - (bad-request "EOF while reading request body: ~a bytes of ~a" - i nbytes)) - (else - (string-set! buf i c) - (lp (1+ i)))))) - (else buf)))))) - (else #f))) - -;; Likewise, assumes that body can be written in the latin-1 encoding, -;; and that the latin-1 encoding is what is expected by the server. -;; -(define (write-request-body/latin-1 r body) - "Write @var{body}, a string encodable in ISO-8859-1, to the port -corresponding to the HTTP request @var{r}." - (display body (request-port r))) - -(define (read-request-body/bytevector r) +(define (read-request-body r) "Reads the request body from @var{r}, as a bytevector. Returns @code{#f} if there was no request body." (let ((nbytes (request-content-length r))) @@ -246,7 +206,7 @@ corresponding to the HTTP request @var{r}." (bad-request "EOF while reading request body: ~a bytes of ~a" (bytevector-length bv) nbytes)))))) -(define (write-request-body/bytevector r bv) +(define (write-request-body r bv) "Write @var{body}, a bytevector, to the port corresponding to the HTTP request @var{r}." (put-bytevector (request-port r) bv)) diff --git a/module/web/response.scm b/module/web/response.scm index f8a87a256..c87f881a0 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -37,11 +37,8 @@ adapt-response-version write-response - read-response-body/latin-1 - write-response-body/latin-1 - - read-response-body/bytevector - write-response-body/bytevector + read-response-body + write-response-body ;; General headers ;; @@ -233,44 +230,7 @@ on @var{port}, perhaps using some transfer encoding." (make-response (response-version r) (response-code r) (response-reason-phrase r) (response-headers r) port))) -;; Probably not what you want to use "in production". Relies on one byte -;; per char because we are in latin-1 encoding. -;; -(define (read-response-body/latin-1 r) - "Reads the response body from @var{r}, as a string. - -Assumes that the response port has ISO-8859-1 encoding, so that the -number of characters to read is the same as the -@code{response-content-length}. Returns @code{#f} if there was no -response body." - (cond - ((response-content-length r) => - (lambda (nbytes) - (let ((buf (make-string nbytes)) - (port (response-port r))) - (let lp ((i 0)) - (cond - ((< i nbytes) - (let ((c (read-char port))) - (cond - ((eof-object? c) - (bad-response "EOF while reading response body: ~a bytes of ~a" - i nbytes)) - (else - (string-set! buf i c) - (lp (1+ i)))))) - (else buf)))))) - (else #f))) - -;; Likewise, assumes that body can be written in the latin-1 encoding, -;; and that the latin-1 encoding is what is expected by the client. -;; -(define (write-response-body/latin-1 r body) - "Write @var{body}, a string encodable in ISO-8859-1, to the port -corresponding to the HTTP response @var{r}." - (display body (response-port r))) - -(define (read-response-body/bytevector r) +(define (read-response-body r) "Reads the response body from @var{r}, as a bytevector. Returns @code{#f} if there was no response body." (let ((nbytes (response-content-length r))) @@ -281,7 +241,7 @@ corresponding to the HTTP response @var{r}." (bad-response "EOF while reading response body: ~a bytes of ~a" (bytevector-length bv) nbytes)))))) -(define (write-response-body/bytevector r bv) +(define (write-response-body r bv) "Write @var{body}, a bytevector, to the port corresponding to the HTTP response @var{r}." (put-bytevector (response-port r) bv)) diff --git a/module/web/server/http.scm b/module/web/server/http.scm index e9d612b1b..a9a90499e 100644 --- a/module/web/server/http.scm +++ b/module/web/server/http.scm @@ -1,6 +1,6 @@ ;;; Web I/O: HTTP -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -121,7 +121,7 @@ (let ((req (read-request port))) (values port req - (read-request-body/bytevector req)))) + (read-request-body req)))) (lambda (k . args) (false-if-exception (close-port port))))))))))))) @@ -142,12 +142,10 @@ (port (response-port response))) (cond ((not body)) ; pass - ((string? body) - (write-response-body/latin-1 response body)) ((bytevector? body) - (write-response-body/bytevector response body)) + (write-response-body response body)) (else - (error "Expected a string or bytevector for body" body))) + (error "Expected a bytevector for body" body))) (cond ((keep-alive? response) (force-output port) diff --git a/test-suite/tests/web-request.test b/test-suite/tests/web-request.test index 32b99dd99..e1eec2f74 100644 --- a/test-suite/tests/web-request.test +++ b/test-suite/tests/web-request.test @@ -51,11 +51,8 @@ Accept-Language: en-gb, en;q=0.9\r (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux"))) - (pass-if (equal? (read-request-body/latin-1 r) #f)) - ;; Since it's #f, should be an idempotent read, so we can try - ;; bytevectors too - (pass-if (equal? (read-request-body/bytevector r) #f)) - + (pass-if (equal? (read-request-body r) #f)) + (pass-if "checking all headers" (equal? (request-headers r) diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test index 7e7331ea7..a21a70207 100644 --- a/test-suite/tests/web-response.test +++ b/test-suite/tests/web-response.test @@ -20,6 +20,7 @@ (define-module (test-suite web-response) #:use-module (web uri) #:use-module (web response) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) #:use-module (test-suite lib)) @@ -53,9 +54,9 @@ abcdefghijklmnopqrstuvwxyz0123456789") (set! r (read-response (open-input-string example-1))) (response? r))) - (pass-if "read-response-body/latin-1" + (pass-if "read-response-body" (begin - (set! body (read-response-body/latin-1 r)) + (set! body (read-response-body r)) #t)) (pass-if (equal? (response-version r) '(1 . 1))) @@ -64,7 +65,9 @@ abcdefghijklmnopqrstuvwxyz0123456789") (pass-if (equal? (response-reason-phrase r) "OK")) - (pass-if (equal? body "abcdefghijklmnopqrstuvwxyz0123456789")) + (pass-if (equal? body + (string->utf8 + "abcdefghijklmnopqrstuvwxyz0123456789"))) (pass-if "checking all headers" (equal? @@ -88,10 +91,10 @@ abcdefghijklmnopqrstuvwxyz0123456789") (with-output-to-string (lambda () (let ((r (write-response r (current-output-port)))) - (write-response-body/latin-1 r body)))) + (write-response-body r body)))) (lambda () (let ((r (read-response (current-input-port)))) - (values r (read-response-body/latin-1 r)))))) + (values r (read-response-body r)))))) (lambda (r* body*) (responses-equal? r body r* body*))))