substitute-binary: Pass `filtered-port' an unbuffered port.

This fixes a bug whereby `read-response' would read more than just the
response, with the extra data going into the port's buffer; the
"bzip2 -dc" process spawned by `filtered-port' would not see the those
buffered data, which are definitely lost, and would bail out with
"bzip2: (stdin) is not a bzip2 file."

* guix/utils.scm (filtered-port): Document that INPUT must be
  unbuffered.
* guix/web.scm (http-fetch): Add `buffered?' parameter.  Call
  `open-socket-for-uri' explicitly, and call `setvbuf' when BUFFERED? is
  false.  Pass the port to `http-get'.  Close it upon 301/302.
* guix/scripts/substitute-binary.scm (fetch): Add `buffered?'
  parameter.  Pass it to `http-fetch'; honor it for `file' URIs.
  (guix-substitute-binary): Call `fetch' with #:buffered? #f for port RAW.
* tests/utils.scm ("filtered-port, file"): Open FILE as unbuffered.

4 files changed, 34 insertions, 21 deletions

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 27a43b9e3fc..1317a72fb1a 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -117,15 +117,17 @@ pairs."
           (else
            (error "unmatched line" line)))))
 
-(define (fetch uri)
+(define* (fetch uri #:key (buffered? #t))
   "Return a binary input port to URI and the number of bytes it's expected to
 provide."
   (case (uri-scheme uri)
     ((file)
      (let ((port (open-input-file (uri-path uri))))
+       (unless buffered?
+         (setvbuf port _IONBF))
        (values port (stat:size (stat port)))))
     ((http)
-     (http-fetch uri #:text? #f))))
+     (http-fetch uri #:text? #f #:buffered? buffered?))))
 
 (define-record-type <cache>
   (%make-cache url store-directory wants-mass-query?)
@@ -423,7 +425,7 @@ indefinitely."
        (format #t "~a~%" (narinfo-hash narinfo))
 
        (let*-values (((raw download-size)
-                      (fetch uri))
+                      (fetch uri #:buffered? #f))
                      ((input pids)
                       (decompressed-port (narinfo-compression narinfo)
                                          raw)))
diff --git a/guix/utils.scm b/guix/utils.scm
index c2d2808f766..25a392e6a88 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -163,7 +163,8 @@ evaluate to a simple datum."
 (define (filtered-port command input)
   "Return an input port where data drained from INPUT is filtered through
 COMMAND (a list).  In addition, return a list of PIDs that the caller must
-wait."
+wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
+buffered data is lost."
   (let loop ((input input)
              (pids '()))
     (if (file-port? input)
diff --git a/guix/web.scm b/guix/web.scm
index 2236bfd6216..e9c69cb0c05 100644
--- a/guix/web.scm
+++ b/guix/web.scm
@@ -141,20 +141,30 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true."
 (module-define! (resolve-module '(web client))
                 'shutdown (const #f))
 
-(define* (http-fetch uri #:key (text? #f))
+(define* (http-fetch uri #:key (text? #f) (buffered? #t))
   "Return an input port containing the data at URI, and the expected number of
 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
-textual.  Follow any HTTP redirection."
+textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
+unbuffered port, suitable for use in `filtered-port'."
   (let loop ((uri uri))
+    (define port
+      (let ((s (open-socket-for-uri uri)))
+        (unless buffered?
+          (setvbuf s _IONBF))
+        s))
+
     (let*-values (((resp data)
                    ;; Try hard to use the API du jour to get an input port.
                    ;; On Guile 2.0.5 and before, we can only get a string or
                    ;; bytevector, and not an input port.  Work around that.
                    (if (version>? "2.0.7" (version))
                        (if (defined? 'http-get*)
-                           (http-get* uri #:decode-body? text?) ; 2.0.7
-                           (http-get uri #:decode-body? text?)) ; 2.0.5-
-                       (http-get uri #:streaming? #t)))         ; 2.0.9+
+                           (http-get* uri #:decode-body? text?
+                                      #:port port)              ; 2.0.7
+                           (http-get uri #:decode-body? text?
+                                     #:port port))              ; 2.0.5-
+                       (http-get uri #:streaming? #t
+                                 #:port port)))                 ; 2.0.9+
                   ((code)
                    (response-code resp)))
       (case code
@@ -182,7 +192,8 @@ textual.  Follow any HTTP redirection."
         ((301                                      ; moved permanently
           302)                                     ; found (redirection)
          (let ((uri (response-location resp)))
-           (format #t "following redirection to `~a'...~%"
+           (close-port port)
+           (format #t (_ "following redirection to `~a'...~%")
                    (uri->string uri))
            (loop uri)))
         (else
diff --git a/tests/utils.scm b/tests/utils.scm
index c2fb2741930..e8549204d07 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -102,17 +102,16 @@
     list))
 
 (test-assert "filtered-port, file"
-  (let ((file (search-path %load-path "guix.scm")))
-    (call-with-input-file file
-      (lambda (input)
-        (let*-values (((compressed pids1)
-                       (filtered-port `(,%gzip "-c" "--fast") input))
-                      ((decompressed pids2)
-                       (filtered-port `(,%gzip "-d") compressed)))
-          (and (every (compose zero? cdr waitpid)
-                      (append pids1 pids2))
-               (equal? (get-bytevector-all decompressed)
-                       (call-with-input-file file get-bytevector-all))))))))
+  (let* ((file  (search-path %load-path "guix.scm"))
+         (input (open-file file "r0")))
+    (let*-values (((compressed pids1)
+                   (filtered-port `(,%gzip "-c" "--fast") input))
+                  ((decompressed pids2)
+                   (filtered-port `(,%gzip "-d") compressed)))
+      (and (every (compose zero? cdr waitpid)
+                  (append pids1 pids2))
+           (equal? (get-bytevector-all decompressed)
+                   (call-with-input-file file get-bytevector-all))))))
 
 (test-assert "filtered-port, non-file"
   (let ((data (call-with-input-file (search-path %load-path "guix.scm")