diff options
Diffstat (limited to 'src/image.lisp')
| -rw-r--r-- | src/image.lisp | 218 |
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)) |