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 <spwhitton@spwhitton.name>

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