one package for :CHROOT, :CHROOT.FORK and :CHROOT.SHELL

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

3 files changed, 55 insertions, 83 deletions

diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp
index f518acf..9867e30 100644
--- a/src/connection/chroot.lisp
+++ b/src/connection/chroot.lisp
@@ -31,3 +31,58 @@
                             :chroot.shell)
                         remaining
                         :into into))
+
+
+;;;; Chroot connections superclass
+
+(defclass chroot-connection ()
+  ((into :type :string :initarg :into)))
+
+
+;;;; :CHROOT.FORK
+
+(defun chroot (path)
+  #+sbcl      (sb-posix:chroot path)
+  #-(or sbcl) (foreign-funcall "chroot" :string path :int))
+
+(defclass chroot.fork-connection
+    (rehome-connection chroot-connection fork-connection) ())
+
+(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)
+  (let* ((into* (ensure-directory-pathname into))
+         (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 "/"))
+
+
+;;;; :CHROOT.SHELL
+
+(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))
+
+(defclass shell-chroot-connection (chroot-connection shell-wrap-connection) ())
+
+(defmethod connection-shell-wrap ((connection shell-chroot-connection) cmd)
+  (format nil "chroot ~A sh -c ~A"
+          (escape-sh-token (unix-namestring (slot-value connection 'into)))
+          (escape-sh-token cmd)))
diff --git a/src/connection/chroot/fork.lisp b/src/connection/chroot/fork.lisp
deleted file mode 100644
index 84adcf7..0000000
--- a/src/connection/chroot/fork.lisp
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; 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.chroot.fork)
-(named-readtables:in-readtable :consfigurator)
-
-(defun chroot (path)
-  #+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)
-  (let* ((into* (ensure-pathname into))
-         (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/chroot/shell.lisp b/src/connection/chroot/shell.lisp
deleted file mode 100644
index b2db64f..0000000
--- a/src/connection/chroot/shell.lisp
+++ /dev/null
@@ -1,33 +0,0 @@
-;;; 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.chroot.shell)
-(named-readtables:in-readtable :consfigurator)
-
-(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 :root into))
-
-(defclass shell-chroot-connection (shell-wrap-connection)
-  ((root
-    :initarg :root)))
-
-(defmethod connection-shell-wrap ((connection shell-chroot-connection) cmd)
-  (format nil "chroot ~A sh -c ~A"
-          (escape-sh-token (unix-namestring (slot-value connection 'root)))
-          (escape-sh-token cmd)))