add :CHROOT-FORK connection type

Thanks to Mark Wooding for help with handling the streams, dealing with the
debugger in the child, and the FORMAT rune for the child status.

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

5 files changed, 106 insertions, 1 deletions

diff --git a/consfigurator.asd b/consfigurator.asd
index f651cc9..de0ecaf 100644
--- a/consfigurator.asd
+++ b/consfigurator.asd
@@ -23,6 +23,7 @@
 	       (:file "src/connection/ssh")
 	       (:file "src/connection/sudo")
 	       (:file "src/connection/debian-sbcl")
+	       (:file "src/connection/chroot/fork")
 	       (:file "src/property/cmd")
 	       (:file "src/property/file")
 	       (:file "src/data/asdf")
diff --git a/doc/connections.rst b/doc/connections.rst
index b3e5e1d..88674c9 100644
--- a/doc/connections.rst
+++ b/doc/connections.rst
@@ -8,4 +8,30 @@ The code which establishes connections (i.e., implementations of the
 ``ESTABLISH-CONNECTION`` generic) is like code in ``:posix`` properties -- it
 should restrict its I/O to ``RUN``, ``RUNLINES``, ``READFILE`` and
 ``WRITEFILE``, functions which access the currently active connection.  This
-is in order to permit the arbitrary nesting of connections.
+is in order to permit the arbitrary nesting of connections.  If establishing a
+connection really does require more I/O, such as in the case of
+``:CHROOT.FORK`` connections, code can call ``LISP-CONNECTION-P``, and either
+signal an error, or fall back to another connection type.
+
+Notes on particular connection types
+------------------------------------
+
+``:CHROOT.FORK``
+~~~~~~~~~~~~~~~~
+
+Since forking is typically only possible when it is not the case that multiple
+threads are running, it is better to avoid using this connection type as the
+first hop, i.e., directly out of the root Lisp (this is not much of a
+restriction, since typically the root Lisp is running under a uid which cannot
+use the ``chroot(2)`` system call anyway).  More generally, you should avoid
+using this connection type within a Lisp image which might try to execute
+other deployments in parallel.  Typical usage would be something like::
+
+  (deploy (:sudo :debian-sbcl (:chroot.fork :into "...")) ...)
+
+In some situations you might want to have a connection chain which effectively
+uses a connection type like ``:DEBIAN-SBCL`` twice in a row, so that the first
+Lisp image can execute deployments in parallel while the second forks into the
+chroot (typically by having a ``DEPLOYS`` property with connection type
+``:DEBIAN-SBCL`` as one of the properties applied by a deployment whose
+connection chain itself ends with ``:DEBIAN-SBCL``).
diff --git a/src/connection.lisp b/src/connection.lisp
index 3a09bac..4e0863f 100644
--- a/src/connection.lisp
+++ b/src/connection.lisp
@@ -61,6 +61,9 @@ For an example of usage, see the :SUDO connection type."))
 
 (defclass posix-connection (connection) ())
 
+(defun lisp-connection-p ()
+  (subtypep (type-of *connection*) 'lisp-connection))
+
 ;;; generic functions to operate on subclasses of CONNECTION
 
 (defgeneric connection-run (connection cmd input)
diff --git a/src/connection/chroot/fork.lisp b/src/connection/chroot/fork.lisp
new file mode 100644
index 0000000..48b46d1
--- /dev/null
+++ b/src/connection/chroot/fork.lisp
@@ -0,0 +1,71 @@
+;;; 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)
+#+sbcl (require "sb-posix")
+
+;; use only implementation-specific fork and waitpid calls to avoid thread
+;; woes.  chroot(2), however, should be okay.
+
+(defun fork ()
+  #+sbcl (sb-posix:fork))
+
+(defun waitpid (pid options)
+  ;; normalise any other implementations such that we always return
+  ;; (values PID EXIT-STATUS), as SB-POSIX:WAITPID does
+  #+sbcl (sb-posix:waitpid pid options))
+
+(defun chroot (path)
+  #+sbcl      (sb-posix:chroot path)
+  #-(or sbcl) (foreign-funcall "chroot" :string path :int))
+
+(defmethod establish-connection ((type (eql :chroot.fork)) remaining &key into)
+  (unless (lisp-connection-p)
+    (error "Forking into a chroot requires a Lisp-type connection"))
+  #-(or sbcl) (error "Don't know how to safely fork() in this Lisp")
+  (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() failed"))
+      (0
+       (handler-case
+	   (progn
+	     (mapc #'clear-input
+		   (list *standard-input* *debug-io* *terminal-io*))
+	     (unless (zerop (chroot into))
+	       (error "chroot(2) failed; are you root?"))
+	     ;; note that we can't just
+	     ;; (return-from establish-connection (establish-connection :local)
+	     ;; because we need to kill off the child afterwards, rather than
+	     ;; returning to the child's REPL or whatever else
+	     ;; TODO public interface to DEPLOY* or similar needed here
+	     (consfigurator::deploy* (or remaining :local) consfigurator::*host*)
+	     (uiop:quit 0))
+	 (serious-condition (c)
+	   (format *error-output* ":CHROOT.FORK child failed: ~A~%" c)
+	   (uiop:quit 2))))
+      (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 ":CHROOT.FORK child failed, status #x~(~4,'0X~)" status)))
+       nil))))
diff --git a/src/package.lisp b/src/package.lisp
index d3bd27f..f4fcbce 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -62,6 +62,7 @@
 	   #:connection
 	   #:lisp-connection
 	   #:posix-connection
+	   #:lisp-connection-p
 	   #:connection-run
 	   #:connection-readfile
 	   #:connection-writefile
@@ -151,6 +152,9 @@
 (defpackage :consfigurator.connection.debian-sbcl
   (:use #:cl #:consfigurator))
 
+(defpackage :consfigurator.connection.chroot.fork
+  (:use #:cl #:consfigurator #:cffi))
+
 (defpackage :consfigurator.property.cmd
   (:use #:cl #:consfigurator)
   (:export #:single))