rework fork(2) connections

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

6 files changed, 167 insertions, 64 deletions

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