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.

diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index a93072f..3b53ccd 100644 (file)
--- 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 46345c0..5ca7274 100644 (file)
--- 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 721643b..f9679f5 100644 (file)
--- 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)))))))