diff options
Diffstat (limited to 'src/connection/fork.lisp')
-rw-r--r-- | src/connection/fork.lisp | 100 |
1 files changed, 51 insertions, 49 deletions
diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp index 87355c9..67ce84e 100644 --- a/src/connection/fork.lisp +++ b/src/connection/fork.lisp @@ -41,52 +41,54 @@ for example, such that we don't see it." (and #+sbcl (> 2 (length (sb-thread:list-all-threads))))) -;; TODO there is unwanted variable capture going on here -(defmacro with-fork-connection ((remaining) &body forms) - `(progn - (unless (lisp-connection-p) - (error "Forking requires a Lisp-type connection.")) - #-(or sbcl) (error "Don't know how to safely fork() in this Lisp") - ;; TODO copy required prerequisite data into the chroot -- propellor uses - ;; a bind mount but we might be the root Lisp, in which case we don't - ;; have a cache to bind mount in. use chroot.shell connection to upload? - (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 - (handler-bind ((serious-condition - (lambda (c) - (trivial-backtrace:print-backtrace - c :output *error-output*) - (uiop:quit 2)))) - ;; TODO either (reset-data-sources), or bind a restart to - ;; convert data source errors into failed-change (or ignore - ;; them? or what?), as they may or may not be available - ;; inside the chroot, depending on whether the data source - ;; code needs to read files outside of the chroot or already - ;; has the data cached, a socket open etc. - (mapc #'clear-input - (list *standard-input* *debug-io* *terminal-io*)) - (reset-remote-home) - ,@forms - ;; 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* ,remaining) - (uiop:quit 0))) - (t - (multiple-value-bind (_ status) (waitpid child 0) - (declare (ignore _)) - (unless (zerop status) - ;; TODO instead of parsing the status ourselves here, maybe we - ;; can call the various C macros for parsing the status in - ;; wait(2) - (error - "Fork connection child failed, status #x~(~4,'0X~)" status))) - nil))))) +(defclass fork-connection (lisp-connection) ()) + +(defgeneric post-fork (connection) + (:documentation + "Code to execute after forking but before calling CONTINUE-DEPLOY*.")) + +(defmethod continue-connection ((connection fork-connection) remaining) + (unless (lisp-connection-p) + (error "Forking requires a Lisp-type connection.")) + #-(or sbcl) (error "Don't know how to safely fork() in this Lisp") + (upload-all-prerequisite-data + :connection connection :upload-string-data nil) + (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 + (handler-bind ((serious-condition + (lambda (c) + (trivial-backtrace:print-backtrace + c :output *error-output*) + (uiop:quit 2)))) + (mapc #'clear-input + (list *standard-input* *debug-io* *terminal-io*)) + ;; 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* remaining) + (uiop:quit 0))) + (t + (multiple-value-bind (_ status) (waitpid child 0) + (declare (ignore _)) + (unless (zerop status) + ;; TODO instead of parsing the status ourselves here, maybe we + ;; can call the various C macros for parsing the status in wait(2) + (error + "Fork connection child failed, status #x~(~4,'0X~)" status))) + ;; return nil to %CONSFIGURE + nil)))) |