capture fork child stderr & include in call to FAILED-CHANGE

This mirrors what we do with stderr from remote Lisp images.

Before this change, when a remote Lisp image forks, the child's stderr is sent
to the parent's stderr.  But if the parent exits successfully its stderr is
discarded (see the :SBCL connection).  So if the child failed but the
FAILED-CHANGE was handled, perhaps because the fork occurs within SEQPROPS,
the user has no way to get at the child's error output.  After this change,
the error output should be printed to stdout by WITH-SKIP-FAILED-CHANGES.

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 54 insertions, 48 deletions

diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp
index 1eb6568..746b9ed 100644
--- a/src/connection/fork.lisp
+++ b/src/connection/fork.lisp
@@ -58,51 +58,57 @@ for example, such that we don't see it."
   (upload-all-prerequisite-data
    :connection connection :upload-string-data nil)
   (with-remote-temporary-file (output)
-    (mapc #'force-output
-          (list *standard-output* *error-output* *debug-io* *terminal-io*))
-    (let ((child (fork)))
-      (case child
-        ;; note that SB-POSIX:FORK can only return >=0
-        (-1
-         (error "fork(2) failed"))
-        (0
-         (with-backtrace-and-exit-code
-           ;; Capture child stdout in case *STANDARD-OUTPUT* has been rebound
-           ;; to somewhere else in the parent, e.g. by APPLY-AND-PRINT.  The
-           ;; parent can then send the contents of the file named by OUTPUT to
-           ;; the correct stream.  We don't use pipe(2) because then we'd need
-           ;; implementation-specific code to bind streams to the FDs.
-           (with-open-file (*standard-output*
-                            output :direction :output :if-exists :append)
-             (mapc #'clear-input
-                   (list *standard-input* *debug-io* *terminal-io*))
-             (cancel-unwind-protect-in-parent-cleanup)
-             ;; While some kinds of data source will still work given certain
-             ;; subtypes of FORK-CONNECTION (e.g. if they've already cached
-             ;; the data in memory, or if it's also accessible to whomever we
-             ;; will SETUID to), others won't, so drop all registrations and
-             ;; rely on the call to UPLOAD-ALL-PREREQUISITE-DATA above.
-             (reset-data-sources)
-             (post-fork connection)
-             ;; It would be nice to reenter Consfigurator's primary loop by
-             ;; just calling (return-from establish-connection
-             ;; (establish-connection :local)) here, but we need to kill off
-             ;; the child afterwards, rather than returning to the child's
-             ;; REPL or whatever else.
-             (continue-deploy* connection remaining))))
-        (t
-         (multiple-value-bind (pid status) (waitpid child 0)
-           (declare (ignore pid))
-           (fresh-line)
-           (princ (readfile output))
-           (let ((exited (wifexited status)))
-             (unless exited
-               (failed-change
-                "Fork connection child did not exit normally, status #x~(~4,'0X~)"
-                status))
-             (let ((exit-status (wexitstatus status)))
-               (return-exit
-                exit-status
-                :on-failure
-                (failed-change "Fork connection child failed, exit code ~D"
-                               exit-status))))))))))
+    (with-remote-temporary-file (error)
+      (mapc #'force-output
+            (list *standard-output* *error-output* *debug-io* *terminal-io*))
+      (let ((child (fork)))
+        (case child
+          ;; note that SB-POSIX:FORK can only return >=0
+          (-1
+           (error "fork(2) failed"))
+          (0
+           (with-backtrace-and-exit-code
+             ;; Capture child stdout in case *STANDARD-OUTPUT* has been
+             ;; rebound to somewhere else in the parent, e.g. by
+             ;; APPLY-AND-PRINT.  The parent can then send the contents of the
+             ;; file named by OUTPUT to the correct stream.  Capture child
+             ;; stderr so that we can include it in FAILED-CHANGE condition;
+             ;; otherwise if we are within SEQPROPS, for example, stderr won't
+             ;; be made visible to the user.  We don't use pipe(2) because
+             ;; then we'd need implementation-specific code to bind streams to
+             ;; the FDs.
+             (with-open-file (*standard-output*
+                              output :direction :output :if-exists :append)
+               (with-open-file (*error-output*
+                                error :direction :output :if-exists :append)
+                 (mapc #'clear-input
+                       (list *standard-input* *debug-io* *terminal-io*))
+                 (cancel-unwind-protect-in-parent-cleanup)
+                 ;; While some kinds of data source will still work given
+                 ;; certain subtypes of FORK-CONNECTION (e.g. if they've
+                 ;; already cached the data in memory, or if it's also
+                 ;; accessible to whomever we will SETUID to), others won't,
+                 ;; so drop all registrations and rely on the call to
+                 ;; UPLOAD-ALL-PREREQUISITE-DATA above.
+                 (reset-data-sources)
+                 (post-fork connection)
+                 ;; It would be nice to reenter Consfigurator's primary loop
+                 ;; by just calling (return-from establish-connection
+                 ;; (establish-connection :local)) here, but we need to kill
+                 ;; off the child afterwards, rather than returning to the
+                 ;; child's REPL or whatever else.
+                 (continue-deploy* connection remaining)))))
+          (t
+           (multiple-value-bind (pid status) (waitpid child 0)
+             (declare (ignore pid))
+             (fresh-line)
+             (princ (readfile output))
+             (if (wifexited status)
+                 (return-exit
+                  (wexitstatus status)
+                  :on-failure (failed-change
+                               "~&Fork connection child failed; stderr was~%~%~A"
+                               (readfile error)))
+                 (failed-change
+                  "~&Fork connection child did not exit normally, status #x~(~4,'0X~)"
+                  status)))))))))