utils: Add 'decompressed-port' and 'compressed-port'.
* guix/utils.scm (decompressed-port, compressed-port): New procedures. * guix/scripts/substitute-binary.scm (decompressed-port): Remove. (guix-substitute-binary): Pass a symbol or #f as the first argument to 'decompress-port'. * tests/utils.scm ("compressed-port, decompressed-port, non-file"): New test.
This commit is contained in:
parent
443eb4e950
commit
7a8024a33a
|
@ -400,16 +400,6 @@ indefinitely."
|
||||||
(call-with-output-file expiry-file
|
(call-with-output-file expiry-file
|
||||||
(cute write (time-second now) <>))))
|
(cute write (time-second now) <>))))
|
||||||
|
|
||||||
(define (decompressed-port compression input)
|
|
||||||
"Return an input port where INPUT is decompressed according to COMPRESSION,
|
|
||||||
along with a list of PIDs to wait for."
|
|
||||||
(match compression
|
|
||||||
("none" (values input '()))
|
|
||||||
("bzip2" (filtered-port `(,%bzip2 "-dc") input))
|
|
||||||
("xz" (filtered-port `(,%xz "-dc") input))
|
|
||||||
("gzip" (filtered-port `(,%gzip "-dc") input))
|
|
||||||
(else (error "unsupported compression scheme" compression))))
|
|
||||||
|
|
||||||
(define (progress-report-port report-progress port)
|
(define (progress-report-port report-progress port)
|
||||||
"Return a port that calls REPORT-PROGRESS every time something is read from
|
"Return a port that calls REPORT-PROGRESS every time something is read from
|
||||||
PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
|
PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
|
||||||
|
@ -598,7 +588,8 @@ substituter disabled~%")
|
||||||
(current-error-port))))
|
(current-error-port))))
|
||||||
(progress-report-port progress raw)))
|
(progress-report-port progress raw)))
|
||||||
((input pids)
|
((input pids)
|
||||||
(decompressed-port (narinfo-compression narinfo)
|
(decompressed-port (and=> (narinfo-compression narinfo)
|
||||||
|
string->symbol)
|
||||||
progress)))
|
progress)))
|
||||||
;; Unpack the Nar at INPUT into DESTINATION.
|
;; Unpack the Nar at INPUT into DESTINATION.
|
||||||
(restore-file input destination)
|
(restore-file input destination)
|
||||||
|
|
|
@ -70,7 +70,10 @@
|
||||||
call-with-temporary-output-file
|
call-with-temporary-output-file
|
||||||
with-atomic-file-output
|
with-atomic-file-output
|
||||||
fold2
|
fold2
|
||||||
filtered-port))
|
|
||||||
|
filtered-port
|
||||||
|
compressed-port
|
||||||
|
decompressed-port))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
@ -200,6 +203,26 @@ buffered data is lost."
|
||||||
(close-port out)
|
(close-port out)
|
||||||
(loop in (cons child pids)))))))))
|
(loop in (cons child pids)))))))))
|
||||||
|
|
||||||
|
(define (decompressed-port compression input)
|
||||||
|
"Return an input port where INPUT is decompressed according to COMPRESSION,
|
||||||
|
a symbol such as 'xz."
|
||||||
|
(match compression
|
||||||
|
((or #f 'none) (values input '()))
|
||||||
|
('bzip2 (filtered-port `(,%bzip2 "-dc") input))
|
||||||
|
('xz (filtered-port `(,%xz "-dc") input))
|
||||||
|
('gzip (filtered-port `(,%gzip "-dc") input))
|
||||||
|
(else (error "unsupported compression scheme" compression))))
|
||||||
|
|
||||||
|
(define (compressed-port compression input)
|
||||||
|
"Return an input port where INPUT is decompressed according to COMPRESSION,
|
||||||
|
a symbol such as 'xz."
|
||||||
|
(match compression
|
||||||
|
((or #f 'none) (values input '()))
|
||||||
|
('bzip2 (filtered-port `(,%bzip2 "-c") input))
|
||||||
|
('xz (filtered-port `(,%xz "-c") input))
|
||||||
|
('gzip (filtered-port `(,%gzip "-c") input))
|
||||||
|
(else (error "unsupported compression scheme" compression))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Nixpkgs.
|
;;; Nixpkgs.
|
||||||
|
|
|
@ -150,6 +150,17 @@
|
||||||
(any (compose (negate zero?) cdr waitpid)
|
(any (compose (negate zero?) cdr waitpid)
|
||||||
pids))))
|
pids))))
|
||||||
|
|
||||||
|
(test-assert "compressed-port, decompressed-port, non-file"
|
||||||
|
(let ((data (call-with-input-file (search-path %load-path "guix.scm")
|
||||||
|
get-bytevector-all)))
|
||||||
|
(let*-values (((compressed pids1)
|
||||||
|
(compressed-port 'xz (open-bytevector-input-port data)))
|
||||||
|
((decompressed pids2)
|
||||||
|
(decompressed-port 'xz compressed)))
|
||||||
|
(and (every (compose zero? cdr waitpid)
|
||||||
|
(append pids1 pids2))
|
||||||
|
(equal? (get-bytevector-all decompressed) data)))))
|
||||||
|
|
||||||
(false-if-exception (delete-file temp-file))
|
(false-if-exception (delete-file temp-file))
|
||||||
(test-equal "fcntl-flock wait"
|
(test-equal "fcntl-flock wait"
|
||||||
42 ; the child's exit status
|
42 ; the child's exit status
|
||||||
|
|
Loading…
Reference in New Issue