utils: 'filtered-port' doesn't leave dangling processes behind.

* guix/utils.scm (filtered-port): Make sure the 'execl' child process
  always exits, and does (primitive-_exit 1) upon execution failure.
  Use 'primitive-_exit' in the 'dump-port' child process.
* tests/utils.scm ("filtered-port, does not exist"): New test.

2 files changed, 27 insertions, 8 deletions

diff --git a/guix/utils.scm b/guix/utils.scm
index 68329ec915..15a4390074 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -155,18 +155,29 @@ COMMAND (a list).  In addition, return a list of PIDs that the caller must
 wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
 buffered data is lost."
   (let loop ((input input)
-             (pids '()))
+             (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))
+              (dynamic-wind
+                (const #f)
+                (lambda ()
+                  (close-port in)
+                  (close-port (current-input-port))
+                  (dup2 (fileno input) 0)
+                  (close-port (current-output-port))
+                  (dup2 (fileno out) 1)
+                  (catch 'system-error
+                    (lambda ()
+                      (apply execl (car command) command))
+                    (lambda args
+                      (format (current-error-port)
+                              "filtered-port: failed to execute '~{~a ~}': ~a~%"
+                              command (strerror (system-error-errno args))))))
+                (lambda ()
+                  (primitive-_exit 1))))
              (child
               (close-port out)
               (values in (cons child pids))))))
@@ -184,7 +195,7 @@ buffered data is lost."
                   (dump-port input out))
                 (lambda ()
                   (false-if-exception (close out))
-                  (primitive-exit 0))))
+                  (primitive-_exit 0))))
              (child
               (close-port out)
               (loop in (cons child pids)))))))))
diff --git a/tests/utils.scm b/tests/utils.scm
index adac5d4381..85daa3db91 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -142,6 +142,14 @@
                    (append pids1 pids2)))
            (equal? (get-bytevector-all decompressed) data)))))
 
+(test-assert "filtered-port, does not exist"
+  (let* ((file  (search-path %load-path "guix.scm"))
+         (input (open-file file "r0b")))
+    (let-values (((port pids)
+                  (filtered-port '("/does/not/exist") input)))
+      (any (compose (negate zero?) cdr waitpid)
+           pids))))
+
 (false-if-exception (delete-file temp-file))
 (test-equal "fcntl-flock wait"
   42                                              ; the child's exit status