From b914693a33ffcf0764ea9bc87bcc573e5ddf9943 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 23 May 2021 13:19:46 -0700 Subject: convert CONNECTION slots to connattrs & fix finding homedirs HOME does not take into account /etc/passwd inside the chroot, even when starting a login shell with, e.g., "chroot /chroot sh -lc 'echo $HOME'" -- we would need something which emulates login(1), like su(1), but the -c argument to su(1) is not portable. getent(1) is not POSIX. So use tilde expansion. Additionally, avoid having UPLOAD-ALL-PREREQUISITE-DATA store values for the remote UID, remote homedir etc. from *before* the chroot/setuid operation. Signed-off-by: Sean Whitton --- src/connection.lisp | 160 +++++++++++++++++++++++++++++---------------- src/connection/chroot.lisp | 45 ++++++++----- src/connection/setuid.lisp | 47 +++++++------ src/connection/ssh.lisp | 1 + src/connection/sudo.lisp | 9 +-- src/data.lisp | 7 +- src/package.lisp | 5 +- src/property.lisp | 19 +----- src/property/ssh.lisp | 2 +- 9 files changed, 172 insertions(+), 123 deletions(-) diff --git a/src/connection.lisp b/src/connection.lisp index 2ac43d7..9af1f86 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -65,27 +65,9 @@ For an example of usage, see the :SUDO connection type.")) :documentation "The value of *CONNECTION* at the time this connection was established.") (connattrs + :initarg :connattrs :initform nil - :documentation "This connection's connection attributes.") - - ;; TODO some or all of these slots should probably become connattrs. for - ;; example, :CHROOT.FORK can have the remote-uid propagate. - (remote-home - :initform nil - :documentation - "The remote user's home directory.") - (current-directory - :initform nil - :documentation - "The current working directory for RUN, MRUN, READFILE and WRITEFILE.") - (remote-uid - :initform nil - :documentation - "Effective user-id of the remote (deploying) user") - (remote-user - :initform nil - :documentation - "The name of the remote user."))) + :documentation "This connection's connection attributes."))) (defclass lisp-connection (connection) ()) @@ -163,6 +145,86 @@ if they need to handle streams and strings differently.")) (defmethod connection-teardown ((connection connection)) (values)) +(defgeneric connection-connattr (connection k) + (:documentation "Get the connattr identified by K for CONNECTION.") + (:method :around ((connection connection) (k symbol)) + "Retrieve stored connattr or call next method to determine connattr." + (or (getf (slot-value connection 'connattrs) k) + (setf (getf (slot-value connection 'connattrs) k) + (let ((*connection* (slot-value connection 'parent))) + (call-next-method))))) + (:method ((connection connection) (k symbol)) + "Default: if no stored value, there is no connattr identified by K." + nil)) + +(defun (setf connection-connattr) (v connection k) + (setf (getf (slot-value connection 'connattrs) k) v)) + +(defgeneric propagate-connattr (type connattr connection) + (:documentation + "Possibly propagate CONNATTR, a connattr identified by TYPE, through to the +newly-established CONNECTION. Implementations should specialise on TYPE and +CONNECTION, not modify any of their arguments, and either return the new +connattr, or nil if nothing should be propagated.") + (:method (type connattr connection) + "Default implementation: don't propagate." + nil)) + +(defmethod initialize-instance :after ((connection connection) &key) + "Propagate connattrs which should be propagated." + (with-slots (parent) connection + (when (and parent (slot-boundp parent 'connattrs)) + (doplist (k v (slot-value parent 'connattrs)) + (when-let ((new (propagate-connattr k v connection))) + (setf (connection-connattr connection k) new)))))) + + +;;;; Default methods to set some global connattrs + +;;; For connection types where this default implementations won't work, either +;;; set the value of the connattr in ESTABLISH-CONNECTION or provide an +;;; implementation specialising on both arguments. + +(defmethod connection-connattr ((connection connection) (k (eql 'id))) + (multiple-value-bind (out exit) (connection-run connection "id" nil) + (if (zerop exit) + (stripln out) + (failed-change "Failed to run id(1) on remote system.")))) + +(defmethod connection-connattr + ((connection connection) (k (eql :remote-user))) + (parse-username-from-id (connection-connattr connection 'id))) + +(defmethod connection-connattr + ((connection connection) (k (eql :remote-uid))) + (multiple-value-bind (match groups) + (re:scan-to-strings "^uid=([0-9]+)" + (connection-connattr connection 'id)) + (and match (parse-integer (elt groups 0))))) + +(defmethod connection-connattr + ((connection connection) (k (eql :remote-gid))) + (multiple-value-bind (match groups) + (re:scan-to-strings "\\) gid=([0-9]+)" + (connection-connattr connection 'id)) + (and match (parse-integer (elt groups 0))))) + +(defmethod connection-connattr + ((connection connection) (k (eql :remote-home))) + "Fetch home directory using tilde expansion, which is POSIX. +Note that looking at $HOME can give the wrong answer when chrooting, as +/etc/passwd inside the chroot is not consulted even for login shells, e.g. +\"chroot /chroot sh -lc 'echo $HOME'\" (we would need something which emulates +login(1)). Tilde expansion works correctly." + (multiple-value-bind (home exit) + (connection-run connection + (strcat "echo ~" + (connection-connattr connection :remote-user)) + nil) + (if (or (string= "" home) (plusp exit)) + (failed-change "Failed to determine remote home directory.") + (ensure-directory-pathname (stripln home))))) + ;;;; Functions to access the slots of the current connection @@ -242,26 +304,19 @@ the resolution of relative pathnames passed as the first argument of READFILE and WRITEFILE. For Lisp-type connections, it additionally temporarily sets the working directory of the Lisp process using UIOP:WITH-CURRENT-DIRECTORY." (with-gensyms (previous new) - `(let ((,previous (slot-value *connection* 'current-directory)) + `(let ((,previous (get-connattr 'current-directory)) (,new (ensure-pathname ,dir :defaults (pwd) :ensure-absolute t :ensure-directory t))) - (setf (slot-value *connection* 'current-directory) ,new) + (setf (get-connattr 'current-directory) ,new) (unwind-protect (if (lisp-connection-p) (with-current-directory (,new) ,@forms) (progn ,@forms)) - (setf (slot-value *connection* 'current-directory) ,previous))))) + (setf (get-connattr 'current-directory) ,previous))))) (defun pwd () - (or (slot-value *connection* 'current-directory) - (slot-value *connection* 'remote-home) - (setf (slot-value *connection* 'remote-home) - (let ((home - (stripln (connection-run *connection* "echo $HOME" nil)))) - (if (string-equal "" home) - (error "Failed to determine remote home directory.") - (ensure-directory-pathname home)))))) + (or (get-connattr 'current-directory) (get-connattr :remote-home))) (defmacro %process-run-args (&body forms) `(let (cmd input may-fail for-exit env inform) @@ -298,8 +353,18 @@ the working directory of the Lisp process using UIOP:WITH-CURRENT-DIRECTORY." ;; to start a fresh 'sh -c' for each command run, but that's ;; desirable to ensure any variables set by CMD are reset. (setq cmd (format nil "~{export ~A;~^ ~} ~A" accum cmd)))) - (setq cmd (format nil "cd ~A; ~A" - (escape-sh-token (unix-namestring (pwd))) cmd)) + ;; Set HOME (in a way which ENV can override) because with certain + ;; connection types the value sh(1) sets or inherits is wrong. E.g. with + ;; :CHROOT.SHELL we get the value from /etc/passwd outside the chroot. + ;; Do this unconditionally up here rather than down in the + ;; implementations of connection types which actually require it for + ;; simplicity, particularly to avoid having to check whether the connattr + ;; is set yet, because setting it requires working CONNECTION-RUN. + (setq cmd (format nil "export HOME=~A; cd ~A; ~A" + (escape-sh-token (unix-namestring + (get-connattr :remote-home))) + (escape-sh-token (unix-namestring (pwd))) + cmd)) ,@forms)) (defun run (&rest args) @@ -452,33 +517,12 @@ PATH may be any kind of file, including directories." (mrun :may-fail #?"chown ${uid}:${gid} ${namestring}"))))) (connection-writefile *connection* namestring content mode))) - -;;;; Connection attributes - -(defgeneric propagate-connattr (type connattr connection) - (:documentation - "Possibly propagate CONNATTR, a connattr identified by TYPE, through to the -newly-established CONNECTION. Implementations should specialise on TYPE and -CONNECTION, not modify any of their arguments, and either return the new -connattr, or nil if nothing should be propagated.") - (:method (type connattr connection) - "Default implementation: don't propagate." - nil)) - -(defmethod initialize-instance :after ((connection connection) &key) - "Propagate connattrs which should be propagated." - (with-slots (parent) connection - (when (and parent (slot-boundp parent 'connattrs)) - (doplist (k v (slot-value parent 'connattrs)) - (when-let ((new (propagate-connattr k v connection))) - (setf (getf (slot-value connection 'connattrs) k) new)))))) - -(defun get-connattr (k &optional (connection *connection*)) +(defun get-connattr (k) "Get the connattr identified by K for the current connection." - (getf (slot-value connection 'connattrs) k)) + (connection-connattr *connection* k)) -(defun (setf get-connattr) (v k &optional (connection *connection*)) - (setf (getf (slot-value connection 'connattrs) k) v)) +(defun (setf get-connattr) (v k) + (setf (connection-connattr *connection* k) v)) (defmacro with-connattrs ((&rest connattrs) &body forms) "Execute FORMS with connattrs replaced as specified by CONNATTRS, a plist." diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp index bfbaab5..2d8b242 100644 --- a/src/connection/chroot.lisp +++ b/src/connection/chroot.lisp @@ -94,6 +94,14 @@ should be the mount point, without the chroot's root prefixed.") copy) else collect volume))) +(defmethod propagate-connattr + ((type (eql :remote-uid)) connattr (connection chroot-connection)) + connattr) + +(defmethod propagate-connattr + ((type (eql :remote-gid)) connattr (connection chroot-connection)) + connattr) + ;;;; :CHROOT.FORK @@ -109,27 +117,34 @@ should be the mount point, without the chroot's root prefixed.") (error "~&Forking into a chroot requires a Lisp image running as root")) (informat 1 "~&Forking into chroot at ~A" into) (let* ((into* (ensure-directory-pathname into)) - (datadir-inside - (stripln - (mrun - (format - nil - "chroot ~A echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/" - (escape-sh-token (unix-namestring into)))))) - (datadir (ensure-pathname - (subseq datadir-inside 1) - :defaults into* :ensure-absolute t :ensure-directory t))) - (let ((connection (make-instance 'chroot.fork-connection - :into into :datadir datadir))) + (connection (make-instance 'shell-chroot-connection :into into*))) + ;; This has the side effect of populating the CONSFIGURATOR::ID and + ;; :REMOTE-HOME connattrs correctly, so that they don't get bogus values + ;; when this connection object is used in UPLOAD-ALL-PREREQUISITE-DATA. + (multiple-value-bind (datadir-inside exit) + (connection-run + connection + (format nil "echo ${XDG_CACHE_HOME:-~A/.cache}/consfigurator/data/" + (connection-connattr connection :remote-home)) + nil) + (unless (zerop exit) + (error "Failed to determine datadir inside chroot.")) + (setq connection (change-class connection 'chroot.fork-connection)) + (setf (slot-value connection 'datadir) + (ensure-pathname + (subseq datadir-inside 1) + :defaults into* :ensure-absolute t :ensure-directory t)) (unwind-protect-in-parent (continue-connection connection remaining) (connection-teardown connection))))) (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 "/")) + (let ((home (connection-connattr connection :remote-home))) + (setf (uiop:getenv "HOME") (unix-namestring home)) + ;; chdir, else our current working directory is a pointer to something + ;; outside the chroot + (uiop:chdir home))) ;;;; :CHROOT.SHELL diff --git a/src/connection/setuid.lisp b/src/connection/setuid.lisp index 51685f2..72d1ca8 100644 --- a/src/connection/setuid.lisp +++ b/src/connection/setuid.lisp @@ -26,39 +26,46 @@ #+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))) +(defclass setuid-connection (rehome-connection fork-connection) ()) (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)) - (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)))) + (multiple-value-bind (match groups) + (re:scan-to-strings #?/uid=([0-9]+).+gid=([0-9]+)/ (run "id" to)) + (unless match + (error "Could not determine UID and GID of ~A" to)) + (let* ((uid (parse-integer (elt groups 0))) + (gid (parse-integer (elt groups 1))) + (home + ;; tilde expansion is POSIX + (ensure-directory-pathname (stripln (run (strcat "echo ~" to))))) + (datadir + (ensure-directory-pathname + (stripln + (mrun + "su" to "-c" + "echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/"))))) + (continue-connection (make-instance 'setuid-connection + :datadir datadir + :connattrs `(:remote-uid ,uid + :remote-gid ,gid + :remote-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 + (let ((uid (connection-connattr connection :remote-uid)) + (gid (connection-connattr connection :remote-gid)) + (home (connection-connattr connection :remote-home))) (run-program (list "chown" "-R" (format nil "~A:~A" uid gid) - (unix-namestring datadir))) + (unix-namestring (slot-value connection 'datadir)))) (unless (zerop (setgid gid)) (error "setgid(2) failed!")) (unless (zerop (setuid uid)) (error "setuid(2) failed!")) - (setf (getenv "HOME") home) + (setf (getenv "HOME") (unix-namestring home)) (uiop:chdir home))) diff --git a/src/connection/ssh.lisp b/src/connection/ssh.lisp index eb132f3..38fd2ae 100644 --- a/src/connection/ssh.lisp +++ b/src/connection/ssh.lisp @@ -32,6 +32,7 @@ ((hostname :initarg :hostname :documentation "Hostname to SSH to.") + ;; This is deliberately distinct from the :REMOTE-USER connattr. (user :initarg :user :documentation "User to log in as.")) diff --git a/src/connection/sudo.lisp b/src/connection/sudo.lisp index 5ff326d..7896761 100644 --- a/src/connection/sudo.lisp +++ b/src/connection/sudo.lisp @@ -43,7 +43,7 @@ (declare (ignore remaining)) (informat 1 "~&Establishing sudo connection to ~A" user) (make-instance 'sudo-connection - :user user + :connattrs `(:remote-user ,user) ;; we'll send the password followed by ^M, then the real ;; stdin. use CODE-CHAR in this way so that we can be sure ;; ASCII ^M is what will get emitted. @@ -53,10 +53,7 @@ (string (code-char 13))))))) (defclass sudo-connection (shell-wrap-connection) - ((user - :initarg :user) - (password - :initarg :password))) + ((password :initarg :password))) (defmethod get-sudo-password ((connection sudo-connection)) (let ((value (slot-value connection 'password))) @@ -66,7 +63,7 @@ ;; wrap in sh -c so that it is more likely we are either asked for a ;; password for all our commands or not asked for one for any (format nil "sudo -HkS --prompt=\"\" --user=~A sh -c ~A" - (slot-value connection 'user) (escape-sh-token cmd))) + (connection-connattr connection :remote-user) (escape-sh-token cmd))) (defmethod connection-run ((c sudo-connection) cmd (input null)) (call-next-method c cmd (get-sudo-password c))) diff --git a/src/data.lisp b/src/data.lisp index 25d0338..de54665 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -326,6 +326,10 @@ new versions of data, to avoid them piling up.")) (dir (ensure-directory-pathname (remote-data-pathname iden1 iden2)))) (delete-remote-trees dir))) +(defmethod connection-connattr + ((connection connection) (k (eql 'cached-data))) + (make-hash-table :test #'equal)) + (defun upload-all-prerequisite-data (&key (upload-string-data t) (connection *connection*)) "Upload all prerequisite data required by the current deployment to the remote @@ -339,9 +343,6 @@ 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*. - (unless (get-connattr 'cached-data connection) - (setf (get-connattr 'cached-data connection) - (make-hash-table :test #'equal))) (flet ((record-cached-data (iden1 iden2 version) (let ((*connection* connection)) (setf (gethash (cons iden1 iden2) (get-connattr 'cached-data)) diff --git a/src/package.lisp b/src/package.lisp index 4afd998..4d71382 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -108,6 +108,8 @@ #:connection-readfile #:connection-writefile #:connection-teardown + #:connection-connattr + #:propagate-connattr #:run #:mrun @@ -121,8 +123,6 @@ #:delete-remote-trees #:readfile #:writefile - - #:propagate-connattr #:get-connattr #:with-connattrs @@ -151,7 +151,6 @@ #:require-data #:failed-change #:assert-euid-root - #:get-user #:assert-connection-supports #:maybe-writefile-string #:call-with-os diff --git a/src/property.lisp b/src/property.lisp index cf213b8..5f2227c 100644 --- a/src/property.lisp +++ b/src/property.lisp @@ -503,23 +503,8 @@ PATH already has the specified CONTENT and MODE." (defun assert-euid-root () "Assert that the remote user has uid 0 (root)" - (if-let ((uid (slot-value *connection* 'remote-uid))) - (unless (zerop uid) - (failed-change "Property requires root to apply")) - (multiple-value-bind (out err exit) - (run :may-fail "id" "-u") - (unless (zerop exit) - (failed-change #?"Failed to run id(1) on remote system: ${err}")) - (let ((new-uid (parse-integer out))) - (unless (zerop new-uid) - (failed-change "Property requires root to apply")) - (setf (slot-value *connection* 'remote-uid) new-uid))))) - -(defun get-user () - "Get the remote username." - (or (slot-value *connection* 'remote-user) - (setf (slot-value *connection* 'remote-user) - (parse-username-from-id (mrun "id"))))) + (unless (zerop (get-connattr :remote-uid)) + (failed-change "Property requires root to apply"))) (defun assert-connection-supports (type) (unless (or (eq type :posix) (lisp-connection-p)) diff --git a/src/property/ssh.lisp b/src/property/ssh.lisp index 08b7b32..15169cd 100644 --- a/src/property/ssh.lisp +++ b/src/property/ssh.lisp @@ -21,7 +21,7 @@ (defprop authorized-keys :posix (&rest keys) "Permits using KEYS to SSH in as the current user." (:desc (declare (ignore keys)) - (strcat (get-user) " has authorized_keys")) + (strcat (get-connattr :remote-user) " has authorized_keys")) (:apply (file:directory-exists ".ssh") (apply #'file:contains-lines ".ssh/authorized_keys" keys)) -- cgit v1.2.3