diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2021-03-23 21:07:55 -0700 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-03-23 21:10:35 -0700 |
commit | 72cfc459c8dee8b78c2a9908bd5b0679fe2e82fc (patch) | |
tree | 7c35832782abab3b22df795a94f23e73df403bf4 /src/connection | |
parent | f5003995e4b2ea9a0fb80a89da37af928ddd5ef9 (diff) | |
download | consfigurator-72cfc459c8dee8b78c2a9908bd5b0679fe2e82fc.tar.gz |
factor out CONSFIGURATOR.CONNECTION.FORK package
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'src/connection')
-rw-r--r-- | src/connection/chroot/fork.lisp | 64 | ||||
-rw-r--r-- | src/connection/fork.lisp | 80 |
2 files changed, 86 insertions, 58 deletions
diff --git a/src/connection/chroot/fork.lisp b/src/connection/chroot/fork.lisp index d01faa5..0983def 100644 --- a/src/connection/chroot/fork.lisp +++ b/src/connection/chroot/fork.lisp @@ -20,67 +20,15 @@ #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require "sb-posix")) -;; use only implementation-specific fork and waitpid calls to avoid thread -;; woes. chroot(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 chroot (path) #+sbcl (sb-posix:chroot path) #-(or sbcl) (foreign-funcall "chroot" :string path :int)) (defmethod establish-connection ((type (eql :chroot.fork)) remaining &key into) - (unless (lisp-connection-p) - (error "Forking into a chroot requires a Lisp-type connection")) - #-(or sbcl) (error "Don't know how to safely fork() in this Lisp") (informat 1 "~&Forking into chroot at ~A" into) - ;; 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-case - (progn - ;; 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*)) - (unless (zerop (chroot into)) - (error "chroot(2) failed; are you root?")) - ;; chdir, else our current working directory is a pointer to - ;; something outside the chroot - (uiop:chdir "/") - ;; 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)) - (serious-condition (c) - (format *error-output* ":CHROOT.FORK child failed: ~A~%" c) - (uiop:quit 2)))) - (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 ":CHROOT.FORK child failed, status #x~(~4,'0X~)" status))) - nil)))) + (with-fork-connection (remaining) + (unless (zerop (chroot into)) + (error "chroot(2) failed; are you root?")) + ;; chdir, else our current working directory is a pointer to something + ;; outside the chroot + (uiop:chdir "/"))) diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp new file mode 100644 index 0000000..702ca96 --- /dev/null +++ b/src/connection/fork.lisp @@ -0,0 +1,80 @@ +;;; Consfigurator -- Lisp declarative configuration management system + +;;; Copyright (C) 2021 Sean Whitton <spwhitton@spwhitton.name> + +;;; This file is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3, or (at your option) +;;; any later version. + +;;; This file is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. + +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(in-package :consfigurator.connection.fork) +(named-readtables:in-readtable :consfigurator) +#+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) + (require "sb-posix")) + +;; 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)) + +(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-case + (progn + ;; 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*)) + ,@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)) + (serious-condition (c) + (format *error-output* "Fork connection child failed: ~A~%" c) + (uiop:quit 2)))) + (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))))) |