utils: Add 'filtered-output-port' and 'compressed-output-port'.

* guix/utils.scm (filtered-output-port, compressed-output-port): New
  procedures.
* tests/utils.scm ("compressed-output-port + decompressed-port"): New
  test.

2 files changed, 62 insertions, 1 deletions

diff --git a/guix/utils.scm b/guix/utils.scm
index f786c83f471..44060c46b59 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -73,7 +73,8 @@
 
             filtered-port
             compressed-port
-            decompressed-port))
+            decompressed-port
+            compressed-output-port))
 
 
 ;;;
@@ -223,6 +224,47 @@ a symbol such as 'xz."
     ('gzip         (filtered-port `(,%gzip "-c") input))
     (else          (error "unsupported compression scheme" compression))))
 
+(define (filtered-output-port command output)
+  "Return an output port.  Data written to that port is filtered through
+COMMAND and written to OUTPUT, an output file port.  In addition, return a
+list of PIDs to wait for.  OUTPUT must be unbuffered; otherwise, any buffered
+data is lost."
+  (match (pipe)
+    ((in . out)
+     (match (primitive-fork)
+       (0
+        (dynamic-wind
+          (const #f)
+          (lambda ()
+            (close-port out)
+            (close-port (current-input-port))
+            (dup2 (fileno in) 0)
+            (close-port (current-output-port))
+            (dup2 (fileno output) 1)
+            (catch 'system-error
+              (lambda ()
+                (apply execl (car command) command))
+              (lambda args
+                (format (current-error-port)
+                        "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
+                        command (strerror (system-error-errno args))))))
+          (lambda ()
+            (primitive-_exit 1))))
+       (child
+        (close-port in)
+        (values out (list child)))))))
+
+(define (compressed-output-port compression output)
+  "Return an output port whose input is compressed according to COMPRESSION,
+a symbol such as 'xz, and then written to OUTPUT.  In addition return a list
+of PIDs to wait for."
+  (match compression
+    ((or #f 'none) (values output '()))
+    ('bzip2        (filtered-output-port `(,%bzip2 "-c") output))
+    ('xz           (filtered-output-port `(,%xz "-c") output))
+    ('gzip         (filtered-output-port `(,%gzip "-c") output))
+    (else          (error "unsupported compression scheme" compression))))
+
 
 ;;;
 ;;; Nixpkgs.
diff --git a/tests/utils.scm b/tests/utils.scm
index 39cad701b89..adbfdf55baa 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -162,6 +162,25 @@
            (equal? (get-bytevector-all decompressed) data)))))
 
 (false-if-exception (delete-file temp-file))
+(test-equal "compressed-output-port + decompressed-port"
+  '((0) "Hello, compressed port!")
+  (let ((text   "Hello, compressed port!")
+        (output (open-file temp-file "w0b")))
+    (let-values (((compressed pids)
+                  (compressed-output-port 'xz output)))
+      (display text compressed)
+      (close-port compressed)
+      (close-port output)
+      (and (every (compose zero? cdr waitpid) pids)
+           (let*-values (((input)
+                          (open-file temp-file "r0b"))
+                         ((decompressed pids)
+                          (decompressed-port 'xz input)))
+             (let ((str (get-string-all decompressed)))
+               (list (map (compose cdr waitpid) pids)
+                     str)))))))
+
+(false-if-exception (delete-file temp-file))
 (test-equal "fcntl-flock wait"
   42                                              ; the child's exit status
   (let ((file (open-file temp-file "w0")))