diff options
Diffstat (limited to 'src/connection/fork.lisp')
-rw-r--r-- | src/connection/fork.lisp | 102 |
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))))))))) |