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>

1 files changed, 212 insertions, 6 deletions

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