summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-01-10 22:09:57 -0800
committerAndy Wingo <wingo@pobox.com>2011-01-10 22:44:36 -0800
commit3475fbb5722fb53a413a89db231ed543cc27c05d (patch)
tree33e94b9a1c3efc9efaa764c5029d0cc2004a2789
parentff8339db69811ef9c736379b9127e60a3ff74b05 (diff)
downloadguile-3475fbb5722fb53a413a89db231ed543cc27c05d.tar.gz
(web response) and (web request): bodies are bytevectors
* module/web/request.scm (read-request-body, write-request-body): Rename from read-request-body/bytevector and write-request-body/bytevector. Remove the /latin-1 variants, as they were unused and a bad idea. * module/web/response.scm (read-response-body, write-response-body): Likewise. * module/web/server/http.scm (http-read, http-write): Adapt to request/response change. * test-suite/tests/web-request.test: * test-suite/tests/web-response.test: Update tests.
-rw-r--r--module/web/request.scm48
-rw-r--r--module/web/response.scm48
-rw-r--r--module/web/server/http.scm10
-rw-r--r--test-suite/tests/web-request.test7
-rw-r--r--test-suite/tests/web-response.test13
5 files changed, 22 insertions, 104 deletions
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*))))