[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-157-g802a25b

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=802a25b1ed5c738aa5f9d3d01f33eb89b22afd1b

The branch, stable-2.0 has been updated
       via  802a25b1ed5c738aa5f9d3d01f33eb89b22afd1b (commit)
       via  6df03222128887bf9982631183ab1cf6c144fe42 (commit)
      from  2d6a3144a122982d5b6a9365943f73891bdb87d3 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 802a25b1ed5c738aa5f9d3d01f33eb89b22afd1b
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jan 15 23:41:23 2014 +0100

    web: Don't throw if a response is longer than its Content-Length says.
    
    * module/web/response.scm (make-delimited-input-port): Read at most LEN
      bytes from PORT, instead of trying to read more and returning an error
      if more is available.  Try again when 'get-bytevector-n!' return zero.
    * test-suite/tests/web-response.test (example-1): Add garbage after the
      body itself.

commit 6df03222128887bf9982631183ab1cf6c144fe42
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jan 15 23:07:25 2014 +0100

    Custom binary input ports sanity-check the return value of 'read!'.
    
    * libguile/r6rs-ports.c (cbip_fill_input): Throw an exception when
      C_OCTETS is greater than what was requested.
    * test-suite/tests/r6rs-ports.test ("7.2.7 Input Ports")["custom binary
      input port 'read!' returns too much"]: New test.

-----------------------------------------------------------------------

Summary of changes:
 libguile/r6rs-ports.c              |   10 +++++++---
 module/web/response.scm            |   27 ++++++++++++++++-----------
 test-suite/tests/r6rs-ports.test   |    9 +++++++++
 test-suite/tests/web-response.test |    6 ++++--
 4 files changed, 36 insertions(+), 16 deletions(-)

diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 790c24c..0b1d162 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -350,9 +350,11 @@ cbip_fill_input (SCM port)
   if (c_port->read_pos >= c_port->read_end)
     {
       /* Invoke the user's `read!' procedure.  */
-      unsigned c_octets;
+      size_t c_octets, c_requested;
       SCM bv, read_proc, octets;
 
+      c_requested = c_port->read_buf_size;
+
       /* Use the bytevector associated with PORT as the buffer passed to the
         `read!' procedure, thereby avoiding additional allocations.  */
       bv = SCM_CBIP_BYTEVECTOR (port);
@@ -366,8 +368,10 @@ cbip_fill_input (SCM port)
              == SCM_BYTEVECTOR_LENGTH (bv));
 
       octets = scm_call_3 (read_proc, bv, SCM_INUM0,
-                          SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
-      c_octets = scm_to_uint (octets);
+                          scm_from_size_t (c_requested));
+      c_octets = scm_to_size_t (octets);
+      if (SCM_UNLIKELY (c_octets > c_requested))
+       scm_out_of_range (FUNC_NAME, octets);
 
       c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
       c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
diff --git a/module/web/response.scm b/module/web/response.scm
index 570a2d7..58e3f11 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -1,6 +1,6 @@
 ;;; HTTP response objects
 
-;; Copyright (C)  2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012, 2013, 2014 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
@@ -246,16 +246,21 @@ closes PORT, unless KEEP-ALIVE? is true."
                   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)))))
+    ;; Read at most LEN bytes in total.  HTTP/1.1 doesn't say what to do
+    ;; when a server provides more than the Content-Length, but it seems
+    ;; wise to just stop reading at LEN.
+    (let ((count (min count (- len bytes-read))))
+      (let loop ((ret (get-bytevector-n! port bv start count)))
+        (cond ((eof-object? ret)
+               (if (= bytes-read len)
+                   0                              ; EOF
+                   (fail)))
+              ((and (zero? ret) (> count 0))
+               ;; Do not return zero since zero means EOF, so try again.
+               (loop (get-bytevector-n! port bv start count)))
+              (else
+               (set! bytes-read (+ bytes-read ret))
+               ret)))))
 
   (define close
     (and (not keep-alive?)
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index eaae29f..2b62bed 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -411,6 +411,15 @@
       (not (or (port-has-port-position? port)
                (port-has-set-port-position!? port)))))
 
+  (pass-if-exception "custom binary input port 'read!' returns too much"
+      exception:out-of-range
+    ;; In Guile <= 2.0.9 this would segfault.
+    (let* ((read! (lambda (bv start count)
+                    (+ count 4242)))
+           (port (make-custom-binary-input-port "the port" read!
+                                                #f #f #f)))
+      (get-bytevector-all port)))
+
   (pass-if-equal "custom binary input port supports `port-position', \
 not `set-port-position!'"
       42
diff --git a/test-suite/tests/web-response.test 
b/test-suite/tests/web-response.test
index f9679f5..99b1293 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
 ;;;; web-response.test --- HTTP responses       -*- mode: scheme; coding: 
utf-8; -*-
 ;;;;
-;;;;   Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2010, 2011, 2012, 2014 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
@@ -39,7 +39,9 @@ Content-Encoding: gzip\r
 Content-Length: 36\r
 Content-Type: text/html; charset=utf-8\r
 \r
-abcdefghijklmnopqrstuvwxyz0123456789")
+abcdefghijklmnopqrstuvwxyz0123456789
+-> Here is trailing garbage that should be ignored because it is
+   beyond Content-Length.")
 
 (define example-2
   "HTTP/1.1 200 OK\r


hooks/post-receive
-- 
GNU Guile