substitute-binary: Support decompression from non-file ports.

* guix/scripts/substitute-binary.scm (filtered-port): Move to utils.scm.
  (decompressed-port): Upon "none", return '() as the second value.
  (guix-substitute-binary): Expect `decompressed-port' to return a list
  of PIDs as its second value.
* guix/utils.scm (filtered-port): New procedure.  Add case for when
  INPUT is not `file-port?'.
* tests/utils.scm ("filtered-port, file", "filtered-port, non-file"):
  New tests.

guix/scripts/substitute-binary.scm

@@ -348,26 +348,10 @@ indefinitely."
     (call-with-output-file expiry-file
       (cute write (time-second now) <>))))
 
-(define (filtered-port command input)
-  "Return an input port (and PID) where data drained from INPUT is filtered
-through COMMAND.  INPUT must be a file input port."
-  (let ((i+o (pipe)))
-    (match (primitive-fork)
-      (0
-       (close-port (car i+o))
-       (close-port (current-input-port))
-       (dup2 (fileno input) 0)
-       (close-port (current-output-port))
-       (dup2 (fileno (cdr i+o)) 1)
-       (apply execl (car command) command))
-      (child
-       (close-port (cdr i+o))
-       (values (car i+o) child)))))
-
 (define (decompressed-port compression input)
   "Return an input port where INPUT is decompressed according to COMPRESSION."
   (match compression
-    ("none"  (values input #f))
+    ("none"  (values input '()))
     ("bzip2" (filtered-port `(,%bzip2 "-dc") input))
     ("xz"    (filtered-port `(,%xz "-dc") input))
     ("gzip"  (filtered-port `(,%gzip "-dc") input))
@@ -442,7 +426,7 @@ through COMMAND.  INPUT must be a file input port."
 
        (let*-values (((raw download-size)
                       (fetch uri))
-                     ((input pid)
+                     ((input pids)
                       (decompressed-port (narinfo-compression narinfo)
                                          raw)))
          ;; Note that Hydra currently generates Nars on the fly and doesn't
@@ -455,7 +439,7 @@ through COMMAND.  INPUT must be a file input port."
 
          ;; Unpack the Nar at INPUT into DESTINATION.
          (restore-file input destination)
-         (or (not pid) (zero? (cdr (waitpid pid)))))))
+         (every (compose zero? cdr waitpid) pids))))
     (("--version")
      (show-version-and-exit "guix substitute-binary"))))
 

guix/utils.scm

@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-60)
   #:use-module (rnrs bytevectors)
   #:use-module ((rnrs io ports) #:select (put-bytevector))
+  #:use-module ((guix build utils) #:select (dump-port))
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
   #:autoload   (ice-9 popen)  (open-pipe*)
@@ -62,7 +63,8 @@
             package-name->name+version
             file-extension
             call-with-temporary-output-file
-            fold2))
+            fold2
+            filtered-port))
 
 
 ;;;
@@ -153,6 +155,50 @@ evaluate to a simple datum."
               (bytevector->pointer bv) (bytevector-length bv))
         digest))))
 
+
+;;;
+;;; Filtering & pipes.
+;;;
+
+(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."
+  (let loop ((input input)
+             (pids '()))
+    (if (file-port? input)
+        (match (pipe)
+          ((in . out)
+           (match (primitive-fork)
+             (0
+              (close-port in)
+              (close-port (current-input-port))
+              (dup2 (fileno input) 0)
+              (close-port (current-output-port))
+              (dup2 (fileno out) 1)
+              (apply execl (car command) command))
+             (child
+              (close-port out)
+              (values in (cons child pids))))))
+
+        ;; INPUT is not a file port, so fork just for the sake of tunneling it
+        ;; through a file port.
+        (match (pipe)
+          ((in . out)
+           (match (primitive-fork)
+             (0
+              (dynamic-wind
+                (const #t)
+                (lambda ()
+                  (close-port in)
+                  (dump-port input out))
+                (lambda ()
+                  (false-if-exception (close out))
+                  (primitive-exit 0))))
+             (child
+              (close-port out)
+              (loop in (cons child pids)))))))))
+
 
 ;;;
 ;;; Nixpkgs.

tests/utils.scm

@@ -17,12 +17,14 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (test-utils)
+  #:use-module ((guix config) #:select (%gzip))
   #:use-module (guix utils)
   #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
   #:use-module (ice-9 match))
 
 (test-begin "utils")
@@ -89,6 +91,31 @@
                '(0 1 2 3)))
     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))))))))
+
+(test-assert "filtered-port, non-file"
+  (let ((data (call-with-input-file (search-path %load-path "guix.scm")
+                get-bytevector-all)))
+    (let*-values (((compressed pids1)
+                   (filtered-port `(,%gzip "-c" "--fast")
+                                  (open-bytevector-input-port data)))
+                  ((decompressed pids2)
+                   (filtered-port `(,%gzip "-d") compressed)))
+      (and (pk (every (compose zero? cdr waitpid)
+                   (append pids1 pids2)))
+           (equal? (get-bytevector-all decompressed) data)))))
+
 (test-assert "define-record-type*"
   (begin
     (define-record-type* <foo> foo make-foo