aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xguix/scripts/substitute-binary.scm22
-rw-r--r--guix/utils.scm48
-rw-r--r--tests/utils.scm27
3 files changed, 77 insertions, 20 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 87561db4b3..995078e630 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/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"))))
diff --git a/guix/utils.scm b/guix/utils.scm
index 3cbed2fd0f..aec07301da 100644
--- a/guix/utils.scm
+++ b/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))
;;;
@@ -155,6 +157,50 @@ evaluate to a simple datum."
;;;
+;;; 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.
;;;
diff --git a/tests/utils.scm b/tests/utils.scm
index fa7d7b03fd..2fc8eaec12 100644
--- a/tests/utils.scm
+++ b/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