:CHROOT.FORK: unshare mount namespace before making temporary mounts

This avoids some cases of interference between the deployment of the chroot
and other system activity.  For example, before this change, the
:ALWAYS-DEPLOYS option to LIBVIRT:KVM-BOOTS-CHROOT{,-FOR} could interact with
Virtiofs in such a way as to break the running VM.

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

5 files changed, 43 insertions, 19 deletions

diff --git a/consfigurator.asd b/consfigurator.asd
index 0b54349..e071285 100644
--- a/consfigurator.asd
+++ b/consfigurator.asd
@@ -21,6 +21,7 @@
                #:trivial-backtrace)
   :components ((:file "src/package")
                (:file "src/reader")
+               (:cffi-grovel-file "src/libc")
                (:cffi-grovel-file "src/libacl")
                (:file "src/util")
                (:file "src/util/posix1e")
diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp
index 5ea3c7a..eb7d533 100644
--- a/src/connection/chroot.lisp
+++ b/src/connection/chroot.lisp
@@ -52,16 +52,8 @@ should be the mount point, without the chroot's root prefixed.")
         (apply #'mrun "mount" mount-args)
         (push dest (chroot-mounts connection))))))
 
-(defmethod connection-teardown :before ((connection chroot-connection))
-  (dolist (mount (chroot-mounts connection))
-    ;; There shouldn't be any processes left running in the chroot after we've
-    ;; finished deploying it, but it's quite easy to end up with things like
-    ;; gpg-agent holding on to /dev/null, for example, so for simplicity, do a
-    ;; lazy unmount.
-    (mrun "umount" "-l" mount)))
-
-(defmethod initialize-instance :after ((connection chroot-connection) &key)
-  (when (string= "Linux" (stripln (run "uname")))
+(defgeneric linux-chroot-mounts (connection)
+  (:method ((connection chroot-connection))
     (with-slots (into) connection
       ;; Ensure the chroot itself is a mountpoint so that findmnt(8) works
       ;; correctly within the chroot.
@@ -116,16 +108,21 @@ should be the mount point, without the chroot's root prefixed.")
             (slot-value connection 'datadir)
             (merge-pathnames
              "consfigurator/data/" (chroot-pathname xdg-cache-home into))))
-    (unwind-protect (continue-connection connection remaining)
-      (connection-teardown connection))))
+    (continue-connection connection remaining)))
 
 (defmethod post-fork ((connection chroot.fork-connection))
-  (chroot (unix-namestring (slot-value connection 'into)))
-  (let ((home (connection-connattr connection :remote-home)))
-    (setf (getenv "HOME") (unix-namestring home))
-    ;; chdir, else our current working directory is a pointer to something
-    ;; outside the chroot
-    (uiop:chdir home)))
+  (with-slots (into) connection
+    #+linux
+    (progn (unshare +CLONE_NEWNS+)
+           (mrun "mount" "--make-rslave"
+                 (stripln (run "findmnt" "-nro" "TARGET" "-T" into)))
+           (linux-chroot-mounts connection))
+    (chroot (unix-namestring into))
+    (let ((home (connection-connattr connection :remote-home)))
+      (setf (getenv "HOME") (unix-namestring home))
+      ;; chdir, else our current working directory is a pointer to something
+      ;; outside the chroot
+      (uiop:chdir home))))
 
 
 ;;;; :CHROOT.SHELL
@@ -133,7 +130,9 @@ should be the mount point, without the chroot's root prefixed.")
 (defmethod establish-connection ((type (eql :chroot.shell)) remaining &key into)
   (declare (ignore remaining))
   (informat 1 "~&Shelling into chroot at ~A" into)
-  (make-instance 'shell-chroot-connection :into into))
+  (aprog1 (make-instance 'shell-chroot-connection :into into)
+    (when (string= "Linux" (stripln (run "uname")))
+      (linux-chroot-mounts it))))
 
 (defclass shell-chroot-connection (chroot-connection shell-wrap-connection) ())
 
@@ -141,3 +140,11 @@ should be the mount point, without the chroot's root prefixed.")
   (format nil "chroot ~A sh -c ~A"
           (escape-sh-token (unix-namestring (slot-value connection 'into)))
           (escape-sh-token cmd)))
+
+(defmethod connection-teardown :before ((connection shell-chroot-connection))
+  (dolist (mount (chroot-mounts connection))
+    ;; There shouldn't be any processes left running in the chroot after we've
+    ;; finished deploying it, but it's quite easy to end up with things like
+    ;; gpg-agent holding on to /dev/null, for example, so for simplicity, do a
+    ;; lazy unmount.
+    (mrun "umount" "-l" mount)))
diff --git a/src/libc.lisp b/src/libc.lisp
new file mode 100644
index 0000000..d2a3f90
--- /dev/null
+++ b/src/libc.lisp
@@ -0,0 +1,10 @@
+(in-package :consfigurator)
+
+#+linux
+(progn
+  (define "_GNU_SOURCE")
+  (include "linux/sched.h"))
+
+#+linux
+(progn
+  (constant (+CLONE_NEWNS+ "CLONE_NEWNS")))
diff --git a/src/package.lisp b/src/package.lisp
index dba79ec..111b25a 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -82,6 +82,9 @@
            #:compile-file*
            #:compile-file-pathname*
 
+           ;; libc.lisp
+           #:+CLONE_NEWNS+
+
            ;; util.lisp
            #:multiple-value-mapcan
            #:lines
@@ -129,6 +132,7 @@
            #:define-error-retval-cfun
 
            #:chroot
+           #:unshare
 
            ;; connection.lisp
            #:establish-connection
diff --git a/src/util.lisp b/src/util.lisp
index 11bd496..cb3eace 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -638,6 +638,8 @@ Does not currently establish a PAM session."
 
 (define-error-retval-cfun () "chroot" :int (path :string))
 
+(define-error-retval-cfun () "unshare" :int (flags :int))
+
 
 ;;;; Lisp data files