[Guile-commits] 01/01: Fix reading of HTTPS responses that are smaller than port buffer

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 0c102b56e98da39b5a3213bdc567a31ad8ef3e73
Author: Andy Wingo <address@hidden>
Date:   Fri Apr 28 13:38:41 2017 +0200

    Fix reading of HTTPS responses that are smaller than port buffer
    
    * module/web/client.scm (tls-wrap): Use get-bytevector-some instead of
      get-bytevector-n, to prevent Guile from attempting to read more bytes
      than are available.  Normally trying to read data on a shut-down
      socket is fine, but but gnutls issues an error if you attempt to read
      data from a shut-down socket, and that appears to be a security
      property.  Fixes HTTPS requests whose responses are smaller than the
      port buffer.
---
 module/web/client.scm | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

diff --git a/module/web/client.scm b/module/web/client.scm
index 0c055ab..c30fa99 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -130,16 +130,25 @@ host name without trailing dot."
     ;;(set-log-procedure! log)
 
     (handshake session)
+    ;; FIXME: It appears that session-record-port is entirely
+    ;; sufficient; it's already a port.  The only value of this code is
+    ;; to keep a reference on "port", to keep it alive!  To fix this we
+    ;; need to arrange to either hand GnuTLS its own fd to close, or to
+    ;; arrange a reference from the session-record-port to the
+    ;; underlying socket.
     (let ((record (session-record-port session)))
       (define (read! bv start count)
-        (define read-bv (get-bytevector-n record count))
+        (define read-bv (get-bytevector-some record))
         (if (eof-object? read-bv)
             0  ; read! returns 0 on eof-object
             (let ((read-bv-len (bytevector-length read-bv)))
-              (bytevector-copy! read-bv 0 bv start read-bv-len)
+              (bytevector-copy! read-bv 0 bv start (min read-bv-len count))
+              (when (< count read-bv-len)
+                (unget-bytevector record bv count (- read-bv-len count)))
               read-bv-len)))
       (define (write! bv start count)
         (put-bytevector record bv start count)
+        (force-output record)
         count)
       (define (get-position)
         (rnrs-ports:port-position record))
@@ -150,6 +159,7 @@ host name without trailing dot."
           (close-port port))
         (unless (port-closed? record)
           (close-port record)))
+      (setvbuf record 'block)
       (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
                                             get-position set-position!
                                             close))))