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>

10 files changed, 325 insertions, 133 deletions

diff --git a/doc/connections.rst b/doc/connections.rst
index 58b8dfe..cbb1597 100644
--- a/doc/connections.rst
+++ b/doc/connections.rst
@@ -112,22 +112,17 @@ in that saved image.  Typically a ``:SUDO`` connection hop is used before hops
 which start up remote Lisp images, so these issues will not arise for most
 users.
 
-``:CHROOT.FORK``
-~~~~~~~~~~~~~~~~
-
-Since forking is typically only possible when it is not the case that multiple
-threads are running, it is better to avoid using this connection type as the
-first hop, i.e., directly out of the root Lisp (this is not much of a
-restriction, since typically the root Lisp is running under a uid which cannot
-use the ``chroot(2)`` system call anyway).  More generally, you should avoid
-using this connection type within a Lisp image which might try to execute
-other deployments in parallel.  Typical usage would be something like::
+Connections which fork: ``:CHROOT.FORK``, ``:SETUID``
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+These connection types cannot be used as the first hop, i.e., directly out of
+the root Lisp.  This is because they must call fork(2), and Consfigurator only
+makes this system call in contexts in which there shouldn't ever be more than
+one thread (excluding Lisp implementation finaliser threads and the like).
+The root Lisp is not such a context, because it is often multithreaded due to
+the use of SLIME.  This is, however, not much of a restriction, because
+typically the root Lisp is running under a UID which cannot use system calls
+like chroot(2) and setuid(2) anyway.  Thus, typical usage on localhost would
+be something like::
 
   (deploy (:sudo :sbcl (:chroot.fork :into "...")) ...)
-
-In some situations you might want to have a connection chain which effectively
-uses a connection type like ``:SBCL`` twice in a row, so that the first Lisp
-image can execute deployments in parallel while the second forks into the
-chroot (typically by having a ``DEPLOYS`` property with connection type
-``:SBCL`` as one of the properties applied by a deployment whose connection
-chain itself ends with ``:SBCL``).
diff --git a/doc/ideas.rst b/doc/ideas.rst
index e93e42d..11f8c12 100644
--- a/doc/ideas.rst
+++ b/doc/ideas.rst
@@ -61,10 +61,11 @@ Core
 - A CONCURRENTLY combinator for property application specifications, which
   means to apply each of the enclosed properties in parallel.  Particularly
   useful surrounding a set of DEPLOYS applications, to concurrently deploy a
-  number of hosts.  We use ``WITH-CURRENT-DIRECTORY`` in various places, so we
-  may not be able to do this using threads.  But if we want to do it with lots
-  of forking, then practically speaking usage of this combinator will be
-  restricted to connection chains which start up remote Lisp images.
+  number of hosts.  Now that we don't call fork(2) while executing
+  deployments, we ought to be able to do this using threads, and so it can
+  work in the root Lisp too.  However, we still use ``WITH-CURRENT-DIRECTORY``
+  in various places.  Perhaps that macro could be changed to only affect RUN,
+  MRUN etc. for the sake of enabling multithreading.
 
 - It might be useful to have a restart for the case where an attempt is made
   to apply a list of properties containing some ``:LISP`` properties with a
diff --git a/src/connection.lisp b/src/connection.lisp
index 7dbe5d3..6ceb837 100644
--- a/src/connection.lisp
+++ b/src/connection.lisp
@@ -69,6 +69,8 @@ For an example of usage, see the :SUDO connection type."))
     :initform nil
     :documentation "This connection's connection attributes.")))
 
+(define-print-object-for-structlike connection)
+
 (defclass lisp-connection (connection) ())
 
 (defclass posix-connection (connection) ())
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))))
diff --git a/src/data.lisp b/src/data.lisp
index d09e4e2..c78784c 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -330,19 +330,12 @@ new versions of data, to avoid them piling up."))
     ((connection connection) (k (eql 'cached-data)))
   (make-hash-table :test #'equal))
 
-(defun upload-all-prerequisite-data
-    (&key (upload-string-data t) (connection *connection*))
+(defun upload-all-prerequisite-data (&optional (connection *connection*))
   "Upload all prerequisite data required by the current deployment to the remote
 cache of the current connection hop, or to the remote cache of CONNECTION.
 
-If UPLOAD-STRING-DATA is false, don't upload items of string data, but
-retrieve them from data sources and keep in memory.  This is for connection
-types which will do something like fork after calling this function.
-
 This is called by implementations of ESTABLISH-CONNECTION which call
 CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM."
-  ;; Retrieving & keeping in memory refers to how %GET-DATA stores items of
-  ;; string data in *STRING-DATA*.
   (flet ((record-cached-data (iden1 iden2 version)
            (let ((*connection* connection))
              (setf (gethash (cons iden1 iden2) (get-connattr 'cached-data))
@@ -366,11 +359,9 @@ CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM."
                   (or (not highest-remote-version)
                       (version> highest-local-version highest-remote-version)))
             do (let ((data (funcall thunk)))
-                 (when (or upload-string-data
-                           (not (subtypep (type-of data) 'string-data)))
-                   (connection-clear-data-cache connection iden1 iden2)
-                   (connection-upload connection data)
-                   (record-cached-data iden1 iden2 (data-version data))))
+                 (connection-clear-data-cache connection iden1 iden2)
+                 (connection-upload connection data)
+                 (record-cached-data iden1 iden2 (data-version data)))
           else if highest-remote-version
                  do (informat 3 "~&Not uploading ~S | ~S ver ~S as remote has ~S"
                               iden1 iden2
diff --git a/src/image.lisp b/src/image.lisp
index b7e6225..70781a0 100644
--- a/src/image.lisp
+++ b/src/image.lisp
@@ -20,6 +20,211 @@
 
 ;;;; Remote Lisp images
 
+;;; Remote Lisp images fork right after loading all required ASDF systems.
+;;; The parent then enters %CONSFIGURE.  Further connection hops of type
+;;; FORK-CONNECTION are established in grandchildren (actually
+;;; great-grandchildren) such that (i) if establishing those hops requires
+;;; calling things like chroot(2), setuid(2) and setns(2), then the parent
+;;; doesn't get stuck in those contexts; and (ii) subdeployments executed in
+;;; those contexts will not have access to any secrets the parent might have
+;;; read into its memory.
+;;;
+;;; Similar considerations apply to dumping executables.
+;;;
+;;; Previously we forked the original process right before chrooting,
+;;; setuiding, etc., but this failed to ensure (ii), meant that the parent
+;;; could not be multithreaded as it might later need to fork, and required us
+;;; to take extra steps when using UNWIND-PROTECT to ensure cleanup forms
+;;; weren't executed on both sides of any forks, using a specialised macro.
+;;;
+;;; Right before establishing the FORK-CONNECTION, the grandchild also
+;;; recursively sets up infrastructure to request grandchildren for
+;;; establishing further connection hops or dumping executables, such that it
+;;; too can be multithreaded even if there are sub-subdeployments, etc..
+;;;
+;;; We use named pipes for the IPC to minimise implementation-specific code.
+
+(defparameter *fork-control* nil)
+
+(defmacro with-fork-request (request (out err exit) &body forms)
+  (with-gensyms (input output)
+    `(progn
+       (unless (lisp-connection-p)
+         (failed-change "Forking requires a Lisp-type connection."))
+       (unless *fork-control*
+         (failed-change
+          "Fork requested but no fork control child; is this the root Lisp?"))
+       (informat 3 "~&Making grandchild request ~S" ,request)
+       (with-mkfifos (,input ,output)
+         ;; We send the path to a named pipe, INPUT, rather than our actual
+         ;; request.  That way we can be confident that what we send into the
+         ;; (shared) requests pipe will be less than PIPE_BUF (see pipe(7)).
+         (write-to-mkfifo (cons ,input ,output) *fork-control*)
+         (with-open-file (,input ,input :direction :output :if-exists :append
+                                        :element-type 'character)
+           (write-to-mkfifo ,request ,input))
+         (destructuring-bind (,out ,err ,exit)
+             (safe-read-file-form ,output :element-type 'character)
+           ,@forms)))))
+
+;;; These are the two requests we expect to make of grandchildren: complete
+;;; the work of an enclosing call to DEPLOY* or DEPLOY-THESE*, or dump an
+;;; image which will evaluate a form.  In the former case we always want to
+;;; carry over *HOST*, *CONNECTION* and *CONSFIGURATOR-DEBUG-LEVEL*, and in
+;;; the latter case we do not carry over any of these by default.
+
+(defmacro eval-in-grandchild (request (out err exit) &body forms)
+  "Evaluate REQUEST, a readably printable Lisp form, in a grandchild process.
+REQUEST must be evaluable using only definitions established statically by
+your consfig, or in one of the ASDF systems upon which your consfig depends.
+Then bind OUT, ERR and EXIT to the stdout, stderr and exit code of that
+process, respectively, and evaluate FORMS."
+  `(with-fork-request
+       `(let ((*host* ,*host*)
+              (*connection* ,*connection*)
+              (*no-data-sources* t)
+              (*consfigurator-debug-level* ,*consfigurator-debug-level*))
+          ,,request)
+       (,out ,err ,exit)
+     ,@forms))
+
+(defun dump-consfigurator (filename form)
+  (umask #o077)
+  (uiop:register-image-restore-hook (lambda () (eval form)) nil)
+  (uiop:dump-image filename :executable t))
+
+(defun dump-consfigurator-in-grandchild
+    (filename &optional (form `(let ((*no-data-sources* t)
+                                     (*connection* ,*connection*)
+                                     (*consfigurator-debug-level*
+                                       ,*consfigurator-debug-level*))
+                                 (with-deployment-report
+                                   (with-fork-control
+                                     (%consfigure nil ,*host*)))
+                                 (fresh-line))))
+  "Dump an executable image to FILENAME which will evaluate the readably
+printable Lisp form FORM, which defaults to one which will execute the current
+deployment.  FORM must be evaluable using only definitions established
+statically by your consfig, or in one of the ASDF systems upon which your
+consfig depends.
+
+Only :LISP property :APPLY subroutines should call this.
+
+The process which performs the dump will have its umask set to #o077, but
+implementation-specific image dumping code might undo this (SBCL, for example,
+changes the mode of the file to #o755).  You might want to ensure that the
+directory containing FILENAME is locked down."
+  (with-fork-request `(dump-consfigurator ,filename ',form) (out err exit)
+    (declare (ignore out))
+    (unless (zerop exit)
+      (failed-change "~&Failed to dump image; stderr was ~%~%~A" err))))
+
+(defmacro with-fork-control (&body forms &aux (fork-control (gensym)))
+  `(let ((,fork-control (mkfifo)))
+     (forked-progn child
+         ;; We use MAPC-OPEN-INPUT-STREAMS because (i) the input streams may
+         ;; already have been closed if this is a recursive call; (ii) we
+         ;; don't want to close the output streams in the case of *DEBUG-IO*
+         ;; and *TERMINAL-IO*; and (iii) there is some ambiguity in the
+         ;; standard about closing synonym streams; see
+         ;; <https://bugs.launchpad.net/sbcl/+bug/1904257>.
+         (loop initially (mapc-open-input-streams
+                          #'close *standard-input* *debug-io* *terminal-io*)
+               with ,fork-control = (open ,fork-control
+                                          :element-type 'character)
+               for (input . output) = (handler-case (with-safe-io-syntax ()
+                                                      (read ,fork-control))
+                                        (end-of-file ()
+                                          (close ,fork-control)
+                                          (uiop:quit)))
+               do (mapc-open-output-streams
+                   #'force-output
+                   *standard-output* *error-output* *debug-io* *terminal-io*)
+               when (zerop (fork))
+                 do (setsid)
+                    (close ,fork-control)
+                    (handle-fork-request input output)
+                    (uiop:quit))
+       (let ((*fork-control* (open ,fork-control
+                                   :direction :output :if-exists :append
+                                   :element-type 'character)))
+         ;; Opening named pipes for writing blocks on the other end being
+         ;; opened for reading, so at this point we know the child has it
+         ;; open.  Then delete the filesystem reference right away in case we
+         ;; are about to chroot or similar, such that we couldn't do it later.
+         (delete-file ,fork-control)
+         (unwind-protect (progn ,@forms)
+           (close *fork-control*)
+           (let ((status (nth-value 1 (waitpid child 0))))
+             (unless (and (wifexited status) (zerop (wexitstatus status)))
+               (error "Fork control child did not exit zero."))))))))
+
+;; IPC security considerations
+;;
+;; The grandchild initially shouldn't have anything in memory other than the
+;; ASDF systems we've loaded, and a few bits of IPC information like OUT and
+;; ERR.  The INPUT pipe has mode 0600.  So by directly evaluating the first
+;; thing we receive all that we're permitting is for a process with the same
+;; UID and a sufficiently similar view of the filesystem as us to execute and
+;; potentially introspect the consfig.  That should not in itself be a
+;; security concern, because the consfig should not contain any secrets.
+;;
+;; The data we get from INPUT is potentially security-sensitive; for example,
+;; specifications of onward connection chains might contain sudo passwords
+;; (though this would be an unusual way to use Consfigurator).  Another writer
+;; to the pipe might insert a reference to the #. reader macro which causes us
+;; to reveal what we get from INPUT, or another reader from the pipe might be
+;; able to get some of INPUT.  Again, however, only an attacker who has
+;; already managed to change to our UID or otherwise circumvent normal POSIX
+;; permissions could do any of this.  We might consider encrypting the data we
+;; send down the named pipes using a pre-shared key.
+;;
+;; An alternative to forking would be to dump an image which we reexecute each
+;; time we would have created another grandchild; then we can send the request
+;; on stdin.  That would mean writing ~75MB out to disk every time we start up
+;; a remote Lisp image and every time we establish a further FORK-CONNECTION,
+;; however.  If we took this approach, then we'd have implementation-specific
+;; dumping code but the code to reinvoke the dumped images would be fully
+;; portable.  In place of :SETUID connections we might runuser(1) the image,
+;; which would have the advantage of getting us a fresh PAM session, although
+;; it would mean making the executable readable by the target user.
+(defun handle-fork-request (input output &aux (out (mkfifo)) (err (mkfifo)))
+  (forked-progn child
+      (with-backtrace-and-exit-code
+        ;; Capture stdout and leave it to the request submitter to decide what
+        ;; to do with it, because perhaps the requester has rebound
+        ;; *STANDARD-OUTPUT*, e.g. in an enclosing call to APPLY-AND-PRINT.
+        ;;
+        ;; Similarly for stderr.  In particular, we discard the stderr from
+        ;; remote Lisp images unless they fail due to an unhandled error, so
+        ;; if we just leave stderr uncaptured then it might be the case that
+        ;; the user will never see it.  Also see commit 9e7ae48590.
+        (with-open-file (*standard-output* out :direction :output
+                                               :if-exists :append
+                                               :element-type 'character)
+          (with-open-file (*error-output* err :direction :output
+                                              :if-exists :append
+                                              :element-type 'character)
+            (with-fork-control
+              (eval (with-standard-io-syntax
+                      (read-file-form input :element-type 'character)))))))
+    (unwind-protect
+         (with-open-file (out out :element-type 'character)
+           (with-open-file (err err :element-type 'character)
+             (let ((status (nth-value 1 (waitpid child 0))))
+               (unless (wifexited status)
+                 (failed-change
+                  "~&Grandchild process did not exit normally, status #x~(~4,'0X~)."
+                  status))
+               (with-open-file (output output :direction :output
+                                              :if-exists :append
+                                              :element-type 'character)
+                 (write-to-mkfifo (list (slurp-stream-string out)
+                                        (slurp-stream-string err)
+                                        (wexitstatus status))
+                                  output)))))
+      (delete-file out) (delete-file err))))
+
 (defclass asdf-requirements ()
   ((asdf-requirements :type list :initform nil))
   (:documentation
@@ -147,8 +352,7 @@ host which will run the Lisp image must already be established.
 
 The program returned is a single string consisting of a number of sexps
 separated by newlines.  Each sexp must be evaluated by the remote Lisp image
-before the following sexp is offered to its reader.  Usually this can be
-achieved by sending the return value of this function into a REPL's stdin.")
+before the following sexp is offered to its reader, on standard input.")
   (:method (remaining-connections (asdf-requirements asdf-requirements))
     (unless (eq (type-of *host*) 'preprocessed-host)
       (error "Attempt to send unpreprocessed host to remote Lisp.
@@ -220,10 +424,12 @@ Preprocessing must occur in the root Lisp."))
                            collect cell into accum
                          else do (ignore-errors (delete-file (cdr cell)))
                          finally (setq record accum)))
-                 ;; Continue the deployment.
-                 ,(wrap
-                   `(with-backtrace-and-exit-code
-                      (%consfigure ',remaining-connections ,*host*))))))
+                 ;; Continue the deployment.  The READ indirection is to try
+                 ;; to ensure that the fork control child does not end up with
+                 ;; information about the deployment in its memory.
+                 ,(wrap `(with-backtrace-and-exit-code
+                           (with-fork-control (eval (read)))))
+                 (%consfigure ',remaining-connections ,*host*))))
         (handler-case
             (with-standard-io-syntax
               (let ((*allow-printing-passphrases* t))
diff --git a/src/package.lisp b/src/package.lisp
index bd40579..5d2166b 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -33,6 +33,9 @@
                           #:with-current-directory
                           #:delete-empty-directory
 			  #:delete-directory-tree
+                          #:with-safe-io-syntax
+                          #:read-file-form
+                          #:safe-read-file-form
                           #:safe-read-from-string
                           #:compile-file*
                           #:compile-file-pathname*)
@@ -66,6 +69,9 @@
            #:with-current-directory
            #:delete-empty-directory
 	   #:delete-directory-tree
+           #:with-safe-io-syntax
+           #:read-file-form
+           #:safe-read-file-form
            #:safe-read-from-string
            #:compile-file*
            #:compile-file-pathname*
@@ -286,6 +292,8 @@
            #:get-data-protected-string
 
            ;; image.lisp
+           #:eval-in-grandchild
+           #:dump-consfigurator-in-grandchild
            #:asdf-requirements-for-host-and-features
            #:request-asdf-requirements
            #:continue-deploy*-program))
diff --git a/src/util.lisp b/src/util.lisp
index 6de9e71..5524188 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -532,6 +532,47 @@ of this macro."
 Should be called soon after fork(2) in child processes."
   (signal 'in-child-process))
 
+;;; Use only implementation-specific fork, waitpid etc. calls to avoid thread
+;;; woes.  Things like chroot(2) and setuid(2), however, should be okay.
+
+(defun fork ()
+  ;; Normalise any other implementations such that we signal an error if
+  ;; fork(2) returns -1, so caller doesn't have to check for that.
+  #+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 setsid ()
+  #+sbcl (sb-posix:setsid))
+
+(defun umask (mode)
+  #+sbcl (sb-posix:umask mode))
+
+(defmacro forked-progn (child-pid child-form &body parent-forms)
+  (with-gensyms (retval)
+    `(progn
+       #-(or sbcl) (error "Don't know how to safely fork(2) in this Lisp.")
+       (mapc-open-output-streams
+        #'force-output
+        *standard-output* *error-output* *debug-io* *terminal-io*)
+       (let ((,retval (fork)))
+         (if (zerop ,retval)
+             ;; We leave it to the caller to appropriately call CLOSE or
+             ;; CLEAR-INPUT on input streams shared with the parent, because
+             ;; at least SBCL's CLEAR-INPUT clears the OS buffer as well as
+             ;; Lisp's, potentially denying data to both sides of the fork.
+             ,child-form
+             (let ((,child-pid ,retval)) ,@parent-forms))))))
+
 (define-condition skipped-properties () ()
   (:documentation
    "There were failed changes, but instead of aborting, that particular property
@@ -617,3 +658,32 @@ Does not currently establish a PAM session."
              (stream ,file :direction :output :if-exists :supersede)
            (with-standard-io-syntax
              (prin1 ,data stream)))))))
+
+
+;;;; Streams
+
+(defun stream->input-stream (stream)
+  (etypecase stream
+    (synonym-stream (stream->input-stream
+                     (symbol-value (synonym-stream-symbol stream))))
+    (two-way-stream (two-way-stream-input-stream stream))
+    (stream (and (input-stream-p stream) stream))))
+
+(defun mapc-open-input-streams (function &rest streams)
+  (dolist (stream streams streams)
+    (when-let ((input-stream (stream->input-stream stream)))
+      (when (open-stream-p input-stream)
+        (funcall function input-stream)))))
+
+(defun stream->output-stream (stream)
+  (etypecase stream
+    (synonym-stream (stream->output-stream
+                     (symbol-value (synonym-stream-symbol stream))))
+    (two-way-stream (two-way-stream-output-stream stream))
+    (stream (and (output-stream-p stream) stream))))
+
+(defun mapc-open-output-streams (function &rest streams)
+  (dolist (stream streams streams)
+    (when-let ((output-stream (stream->output-stream stream)))
+      (when (open-stream-p output-stream)
+        (funcall function output-stream)))))