rework fork(2) connections

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

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))))