diff options
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 22 | ||||
| -rw-r--r-- | guix/utils.scm | 48 | ||||
| -rw-r--r-- | tests/utils.scm | 27 |
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 |