new approach to calling fork(2) in remote Lisp images

Drop CAN-PROBABLY-FORK because we now only try to fork(2) in contexts in which
there shouldn't ever be any other threads running, apart from Lisp
implementation finaliser threads and the like.

We no longer need to RESET-DATA-SOURCES before CONTINUE-DEPLOY* because we now
only fork(2) in contexts in which *NO-DATA-SOURCES* is t.

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

3 files changed, 12 insertions, 93 deletions

diff --git a/src/connection/as.lisp b/src/connection/as.lisp
index 6f6edc6..a31a338 100644
--- a/src/connection/as.lisp
+++ b/src/connection/as.lisp
@@ -30,8 +30,6 @@ whether it is possible to establish a :SETUID connection.
 Note that both these connection types require root."
   ;; An alternative to :SU would be :SUDO or runuser(1), but :SU is more
   ;; portable.
-  (establish-connection (if (and (lisp-connection-p)
-                                 (can-setuid)
-                                 (can-probably-fork))
+  (establish-connection (if (and (lisp-connection-p) (can-setuid))
                             :setuid :su)
                         remaining :to to))
diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp
index d0d59ac..836124f 100644
--- a/src/connection/chroot.lisp
+++ b/src/connection/chroot.lisp
@@ -24,9 +24,7 @@
   (zerop (foreign-funcall "geteuid" :int)))
 
 (defmethod establish-connection ((type (eql :chroot)) remaining &key into)
-  (establish-connection (if (and (lisp-connection-p)
-                                 (can-chroot)
-                                 (can-probably-fork))
+  (establish-connection (if (and (lisp-connection-p) (can-chroot))
                             :chroot.fork
                             :chroot.shell)
                         remaining
diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp
index 746b9ed..5def543 100644
--- a/src/connection/fork.lisp
+++ b/src/connection/fork.lisp
@@ -18,33 +18,6 @@
 (in-package :consfigurator.connection.fork)
 (named-readtables:in-readtable :consfigurator)
 
-;; Use only implementation-specific fork and waitpid calls to avoid thread
-;; woes.  Things like chroot(2) and setuid(2), however, should be okay.
-
-(defun fork ()
-  #+sbcl (sb-posix:fork))
-
-(defun waitpid (pid options)
-  ;; normalise any other implementations such that we always return
-  ;; (values PID EXIT-STATUS), as SB-POSIX:WAITPID does
-  #+sbcl (sb-posix:waitpid pid options))
-
-(defun wifexited (status)
-  #+sbcl (sb-posix:wifexited status))
-
-(defun wexitstatus (status)
-  #+sbcl (sb-posix:wexitstatus status))
-
-(defun can-probably-fork ()
-  "Return nil if we can detect other running threads, and the Lisp
-implementation is known not to support forking when there are other threads.
-A return value other than nil indicates only that we couldn't detect
-circumstances in which it is known that we cannot fork, not that we are sure
-we can fork -- a thread might be only partly initialised at the time we check,
-for example, such that we don't see it."
-  (and
-   #+sbcl (> 2 (length (sb-thread:list-all-threads)))))
-
 (defclass fork-connection (local-connection) ())
 
 (defgeneric post-fork (connection)
@@ -52,63 +25,13 @@ for example, such that we don't see it."
    "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)
-  (with-remote-temporary-file (output)
-    (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)))))))))
+  (upload-all-prerequisite-data connection)
+  (eval-in-grandchild `(progn (post-fork ,connection)
+                              (continue-deploy* ,connection ',remaining))
+      (out err exit)
+    (fresh-line)
+    (princ out)
+    (return-exit
+     exit
+     :on-failure (failed-change
+                  "~&Fork connection child failed; stderr was ~%~%~A" err))))