From 83dab1b451746054d86f1c000a27ac8f3796dbc0 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sat, 27 Mar 2021 16:28:57 -0700 Subject: rework fork(2) connections Signed-off-by: Sean Whitton --- consfigurator.asd | 1 + src/connection/chroot/fork.lisp | 27 ++++++++--- src/connection/fork.lisp | 100 ++++++++++++++++++++-------------------- src/connection/rehome.lisp | 55 ++++++++++++++++++++++ src/connection/setuid.lisp | 38 +++++++++++---- src/package.lisp | 10 +++- 6 files changed, 167 insertions(+), 64 deletions(-) create mode 100644 src/connection/rehome.lisp diff --git a/consfigurator.asd b/consfigurator.asd index c65813e..c478b66 100644 --- a/consfigurator.asd +++ b/consfigurator.asd @@ -36,6 +36,7 @@ (:file "src/property/gnupg") (:file "src/connection/shell-wrap") (:file "src/connection/fork") + (:file "src/connection/rehome") (:file "src/connection/ssh") (:file "src/connection/sudo") (:file "src/connection/su") diff --git a/src/connection/chroot/fork.lisp b/src/connection/chroot/fork.lisp index 50dcbc9..69a9d12 100644 --- a/src/connection/chroot/fork.lisp +++ b/src/connection/chroot/fork.lisp @@ -24,13 +24,28 @@ #+sbcl (sb-posix:chroot path) #-(or sbcl) (foreign-funcall "chroot" :string path :int)) +(defclass chroot.fork-connection (rehome-connection fork-connection) + ((into :type :string :initarg :into))) + (defmethod establish-connection ((type (eql :chroot.fork)) remaining &key into) (unless (and (lisp-connection-p) (zerop (foreign-funcall "geteuid" :int))) (error "~&Forking into a chroot requires a Lisp image running as root")) (informat 1 "~&Forking into chroot at ~A" into) - (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 "/"))) + (let* ((datadir-inside + (stripln + (mrun + "chroot" into + "echo" "${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/"))) + (datadir (ensure-pathname + (subseq datadir-inside 1) + :defaults into :ensure-absolute t :ensure-directory t))) + (continue-connection + (make-instance 'chroot.fork-connection :into into :datadir datadir) + remaining))) + +(defmethod post-fork ((connection chroot.fork-connection)) + (unless (zerop (chroot (slot-value connection 'into))) + (error "chroot(2) failed!")) + ;; 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 index 87355c9..67ce84e 100644 --- a/src/connection/fork.lisp +++ b/src/connection/fork.lisp @@ -41,52 +41,54 @@ for example, such that we don't see it." (and #+sbcl (> 2 (length (sb-thread:list-all-threads))))) -;; TODO there is unwanted variable capture going on here -(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-bind ((serious-condition - (lambda (c) - (trivial-backtrace:print-backtrace - c :output *error-output*) - (uiop:quit 2)))) - ;; 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*)) - (reset-remote-home) - ,@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))) - (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))))) +(defclass fork-connection (lisp-connection) ()) + +(defgeneric post-fork (connection) + (:documentation + "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) + (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-bind ((serious-condition + (lambda (c) + (trivial-backtrace:print-backtrace + c :output *error-output*) + (uiop:quit 2)))) + (mapc #'clear-input + (list *standard-input* *debug-io* *terminal-io*)) + ;; 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* remaining) + (uiop:quit 0))) + (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))) + ;; return nil to %CONSFIGURE + nil)))) diff --git a/src/connection/rehome.lisp b/src/connection/rehome.lisp new file mode 100644 index 0000000..ec943f1 --- /dev/null +++ b/src/connection/rehome.lisp @@ -0,0 +1,55 @@ +;;; Consfigurator -- Lisp declarative configuration management system + +;;; Copyright (C) 2021 Sean Whitton + +;;; 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 . + +(in-package :consfigurator.connection.rehome) +(named-readtables:in-readtable :consfigurator) + +(defclass rehome-connection () + ((datadir + :type :string :initarg :datadir :reader datadir + :documentation + "Where Consfigurator would cache items of prerequisite data in the new HOME.")) + (:documentation + "A connection which works by switching to a new HOME on the same host.")) + +(defmethod post-fork :before ((connection rehome-connection)) + (reset-remote-home)) + +(defmethod connection-upload ((connection rehome-connection) (data file-data)) + (with-slots (iden1 iden2 data-version) data + (let ((inside (data-pathname + (datadir connection) iden1 iden2 data-version)) + (outside (remote-data-pathname iden1 iden2 data-version))) + (mrun "mkdir" "-p" (pathname-directory-pathname inside)) + (if (remote-exists-p outside) + (mrun "cp" outside inside) + (let (done) + (unwind-protect + (progn + (connection-upload (connection-parent connection) data) + (mrun "mv" outside inside) + (setq done t)) + (unless done (mrun "rm" "-f" outside)))))))) + +(defmethod connection-clear-data-cache + ((connection rehome-connection) iden1 iden2) + (with-slots (datadir) connection + (mrun "rm" "-rf" (data-pathname (datadir connection) iden1 iden2)))) + +(defmethod get-remote-cached-prerequisite-data + ((connection rehome-connection)) + (get-local-cached-prerequisite-data (datadir connection))) diff --git a/src/connection/setuid.lisp b/src/connection/setuid.lisp index 76d7fd4..1397599 100644 --- a/src/connection/setuid.lisp +++ b/src/connection/setuid.lisp @@ -28,17 +28,39 @@ #+sbcl (sb-posix:setgid gid) #-(or sbcl) (foreign-funcall "setgid" :unsigned-int uid :int)) +(defclass setuid-connection (rehome-connection fork-connection) + ((uid :type :integer :initarg :uid) + (gid :type :integer :initarg :gid) + (home :type :string :initarg :home))) + (defmethod establish-connection ((type (eql :setuid)) remaining &key to) (unless (and (lisp-connection-p) (zerop (foreign-funcall "geteuid" :int))) (error "~&SETUIDing requires a Lisp image running as root")) (informat 1 "~&SETUIDing to ~A" to) (re:register-groups-bind ((#'parse-integer uid gid)) (#?/uid=([0-9]+).+gid=([0-9]+)/ (mrun "id" to)) - (let ((home (user:passwd-entry 5 uid))) - (with-fork-connection (remaining) - (unless (zerop (setgid gid)) - (error "setgid(2) failed; are you root?")) - (unless (zerop (setuid uid)) - (error "setuid(2) failed; are you root?")) - (setf (getenv "HOME") home) - (uiop:chdir home))))) + (let ((home (user:passwd-entry 5 uid)) + (datadir + (ensure-directory-pathname + (stripln + (mrun + "su" to "-c" + "echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/"))))) + (continue-connection + (make-instance + 'setuid-connection :uid uid :gid gid :datadir datadir :home home) + remaining)))) + +(defmethod post-fork ((connection setuid-connection)) + ;; TODO Set up the new environment more systematically. Perhaps look at how + ;; runuser(1) uses PAM to do this. + (with-slots (uid gid home datadir) connection + (run-program (list "chown" "-R" + (format nil "~A:~A" uid gid) + (unix-namestring datadir))) + (unless (zerop (setgid gid)) + (error "setgid(2) failed!")) + (unless (zerop (setuid uid)) + (error "setuid(2) failed!")) + (setf (getenv "HOME") home) + (uiop:chdir home))) diff --git a/src/package.lisp b/src/package.lisp index 26d5ef8..5631860 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -301,9 +301,15 @@ (defpackage :consfigurator.connection.fork (:use #:cl #:consfigurator) - (:export #:with-fork-connection + (:export #:fork-connection + #:post-fork #:can-probably-fork)) +(defpackage :consfigurator.connection.rehome + (:use #:cl #:consfigurator #:consfigurator.connection.fork) + (:export #:rehome-connection + #:datadir)) + (defpackage :consfigurator.connection.as (:use #:cl #:consfigurator @@ -341,6 +347,7 @@ (:use #:cl #:consfigurator #:consfigurator.connection.fork + #:consfigurator.connection.rehome #:cffi)) (defpackage :consfigurator.connection.chroot.shell @@ -352,6 +359,7 @@ (:use #:cl #:consfigurator #:consfigurator.connection.fork + #:consfigurator.connection.rehome #:cffi) (:local-nicknames (#:re #:cl-ppcre) (#:user #:consfigurator.property.user))) -- cgit v1.2.3