From 75d6c59fc25cdcc02f19b626961d46a96bb33234 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 28 Nov 2012 22:26:44 +0100 Subject: [PATCH] web: Add `response-body-port'. * module/web/response.scm (make-delimited-input-port, response-body-port): New procedures. (read-response-body): Use `response-body-port'. * test-suite/tests/web-response.test ("example-1")["response-body-port"]: New test. ("example-2")["response-body-port"]: New test. --- doc/ref/web.texi | 10 +++++ module/web/response.scm | 70 +++++++++++++++++++++++++----- test-suite/tests/web-response.test | 18 +++++++- 3 files changed, 85 insertions(+), 13 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index a93072f96..3b53ccdd6 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1315,6 +1315,16 @@ Note also, though, that responses to @code{HEAD} requests must also not have a body. @end deffn +@deffn {Scheme Procedure} response-body-port r [#:decode?=#t] [#:keep-alive?=#t] +Return an input port from which the body of @var{r} can be read. The encoding +of the returned port is set according to @var{r}'s @code{content-type} header, +when it's textual, except if @var{decode?} is @code{#f}. Return @code{#f} +when no body is available. + +When @var{keep-alive?} is @code{#f}, closing the returned port also closes +@var{r}'s response port. +@end deffn + @deffn {Scheme Procedure} read-response-body r Read the response body from @var{r}, as a bytevector. Returns @code{#f} if there was no response body. diff --git a/module/web/response.scm b/module/web/response.scm index 46345c0fd..5ca727409 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -23,6 +23,7 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) #:use-module (srfi srfi-9) #:use-module (web http) #:export (response? @@ -37,6 +38,7 @@ write-response response-must-not-include-body? + response-body-port read-response-body write-response-body @@ -233,20 +235,66 @@ This is true for some response types, like those with code 304." (= (response-code r) 204) (= (response-code r) 304))) +(define (make-delimited-input-port port len keep-alive?) + "Return an input port that reads from PORT, and makes sure that +exactly LEN bytes are available from PORT. Closing the returned port +closes PORT, unless KEEP-ALIVE? is true." + (define bytes-read 0) + + (define (fail) + (bad-response "EOF while reading response body: ~a bytes of ~a" + bytes-read len)) + + (define (read! bv start count) + (let ((ret (get-bytevector-n! port bv start count))) + (if (eof-object? ret) + (if (= bytes-read len) + 0 + (fail)) + (begin + (set! bytes-read (+ bytes-read ret)) + (if (> bytes-read len) + (fail) + ret))))) + + (define close + (and (not keep-alive?) + (lambda () + (close port)))) + + (make-custom-binary-input-port "delimited input port" read! #f #f close)) + +(define* (response-body-port r #:key (decode? #t) (keep-alive? #t)) + "Return an input port from which the body of R can be read. The +encoding of the returned port is set according to R's ‘content-type’ +header, when it's textual, except if DECODE? is #f. Return #f when no +body is available. + +When KEEP-ALIVE? is #f, closing the returned port also closes R's +response port." + (define port + (if (member '(chunked) (response-transfer-encoding r)) + (make-chunked-input-port (response-port r) + #:keep-alive? keep-alive?) + (let ((len (response-content-length r))) + (and len + (make-delimited-input-port (response-port r) + len keep-alive?))))) + + (when (and decode? port) + (match (response-content-type r) + (((? text-content-type?) . props) + (set-port-encoding! port + (or (assq-ref props 'charset) + "ISO-8859-1"))) + (_ #f))) + + port) + (define (read-response-body r) "Reads the response body from R, as a bytevector. Returns ‘#f’ if there was no response body." - (if (member '(chunked) (response-transfer-encoding r)) - (let ((chunk-port (make-chunked-input-port (response-port r) - #:keep-alive? #t))) - (get-bytevector-all chunk-port)) - (let ((nbytes (response-content-length r))) - (and nbytes - (let ((bv (get-bytevector-n (response-port r) nbytes))) - (if (= (bytevector-length bv) nbytes) - bv - (bad-response "EOF while reading response body: ~a bytes of ~a" - (bytevector-length bv) nbytes))))))) + (and=> (response-body-port r #:decode? #f) get-bytevector-all)) (define (write-response-body r bv) "Write BV, a bytevector, to the port corresponding to the HTTP diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test index 721643b53..f9679f5e2 100644 --- a/test-suite/tests/web-response.test +++ b/test-suite/tests/web-response.test @@ -21,6 +21,7 @@ #:use-module (web uri) #:use-module (web response) #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) #:use-module (srfi srfi-19) #:use-module (test-suite lib)) @@ -109,7 +110,14 @@ consectetur adipisicing elit,\r (pass-if-equal "by accessor" '(gzip) - (response-content-encoding r)))) + (response-content-encoding r)) + + (pass-if-equal "response-body-port" + `("utf-8" ,body) + (with-fluids ((%default-port-encoding #f)) + (let* ((r (read-response (open-input-string example-1))) + (p (response-body-port r))) + (list (port-encoding p) (get-bytevector-all p))))))) (with-test-prefix "example-2" (let* ((r (read-response (open-input-string example-2))) @@ -121,4 +129,10 @@ consectetur adipisicing elit,\r (string-append "Lorem ipsum dolor sit amet, consectetur adipisicing elit," " sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.")) - b))) + b) + (pass-if-equal "response-body-port" + `("ISO-8859-1" ,(utf8->string b)) ; no `charset', hence ISO-8859-1 + (with-fluids ((%default-port-encoding #f)) + (let* ((r (read-response (open-input-string example-2))) + (p (response-body-port r))) + (list (port-encoding p) (get-string-all p))))))) -- 2.20.1