From e8df647b13c130cc038eef76acf02caabe346b7e Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Apr 2021 15:52:44 -0700 Subject: one package for :CHROOT, :CHROOT.FORK and :CHROOT.SHELL Signed-off-by: Sean Whitton --- src/connection/chroot.lisp | 55 ++++++++++++++++++++++++++++++++++++++++ src/connection/chroot/fork.lisp | 50 ------------------------------------ src/connection/chroot/shell.lisp | 33 ------------------------ 3 files changed, 55 insertions(+), 83 deletions(-) delete mode 100644 src/connection/chroot/fork.lisp delete mode 100644 src/connection/chroot/shell.lisp (limited to 'src/connection') 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 - -;;; 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 . - -(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 - -;;; 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 . - -(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))) -- cgit v1.2.3