move chroot->volumes operation into a new properties package

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

2 files changed, 83 insertions, 41 deletions

diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index 3c9b647..22a98dc 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -532,7 +532,7 @@ FILESYSTEM volumes.  During the application of PROPAPPS, all :OPENED-VOLUMES
 connattrs are replaced with a list of the volumes that were opened; this list
 must not be modified."
   `(with-these-open-volumes*
-     ,volumes
+     ',volumes
      ,(if (cdr propapps) `(eseqprops ,@propapps) (car propapps))
      ,@(and mount-below-supplied-p `(:mount-below ,mount-below))))
 
@@ -661,14 +661,6 @@ the LVM physical volumes corresponding to those volume groups."
      ;; Finally, create the volumes.
      (mapc (rcurry #'create-volume-and-contents nil) volumes))))
 
-(defprop %update-image-from-chroot :posix (chroot opened-image)
-  (:desc #?"Updated ${opened-image} from ${chroot}")
-  (:apply
-   (assert-euid-root)
-   (mrun "rsync" "-Pav" "--delete"
-         (strcat (unix-namestring chroot) "/")
-         (strcat (unix-namestring opened-image) "/"))))
-
 (defpropspec raw-image-built-for :lisp
     (options host image-pathname &key rebuild)
   "Build a raw disk image for HOST at IMAGE-PATHNAME.
@@ -686,39 +678,37 @@ filesystems will be incrementally updated when other properties change."
   (:desc (declare (ignore options rebuild))
          (let ((hostname (car (getf (hostattrs host) :hostname))))
            #?"Built image for ${hostname} @ ${image-pathname}"))
-  (let* ((chroot (ensure-directory-pathname
-                  (strcat (unix-namestring image-pathname) ".chroot")))
-         (opened (ensure-directory-pathname
-                  (strcat (unix-namestring image-pathname) ".opened")))
-         (volumes
-           (loop
-             with found
-             for volume in (getf (hostattrs (preprocess-host host)) :volumes)
-             for physical-disk-p = (subtypep (type-of volume) 'physical-disk)
-             if (and physical-disk-p (not found)
-                     (slot-boundp volume 'volume-contents))
-               do (setq found t)
-               and collect
-                   (let ((new (make-instance
-                               'raw-disk-image
-                               :image-file image-pathname
-                               :volume-contents (volume-contents volume))))
-                     (when (slot-boundp volume 'volume-size)
-                       (setf (volume-size new) (volume-size volume)))
-                     new)
-             else unless physical-disk-p
-                    collect volume
-             finally
-                (unless found
-                  (inapplicable-property
-                   "Volumes list for host has no DISK:PHYSICAL-DISK with contents.")))))
-    `(on-change (chroot:os-bootstrapped-for ,options ,chroot ,host
-                  ,(make-propspec :systems nil :propspec '(caches-cleaned)))
+  (let ((chroot (ensure-directory-pathname
+                 (strcat (unix-namestring image-pathname) ".chroot")))
+        (volumes
+          (loop
+            with found
+            for volume in (getf (hostattrs (preprocess-host host)) :volumes)
+            for physical-disk-p = (subtypep (type-of volume) 'physical-disk)
+            if (and physical-disk-p (not found)
+                    (slot-boundp volume 'volume-contents))
+              do (setq found t)
+              and collect
+                  (let ((new (make-instance
+                              'raw-disk-image
+                              :image-file image-pathname
+                              :volume-contents (volume-contents volume))))
+                    (when (slot-boundp volume 'volume-size)
+                      (setf (volume-size new) (volume-size volume)))
+                    new)
+            else unless physical-disk-p
+                   collect volume
+            finally
+               (unless found
+                 (inapplicable-property
+                  "Volumes list for host has no DISK:PHYSICAL-DISK with contents.")))))
+    `(on-change (chroot:os-bootstrapped-for
+                 ,options ,chroot ,host
+                 ,(make-propspec :systems nil
+                                 :propspec '(caches-cleaned)))
        (%raw-image-created ,volumes :chroot ,chroot :rebuild ,rebuild)
-       (with-these-open-volumes (',volumes :mount-below ,opened)
-         ;; TODO update /etc/fstab & /etc/crypttab from the opened volumes
-         ;; TODO install bootloader
-         (%update-image-from-chroot ,chroot ,opened)))))
+       (consfigurator.property.installer:chroot-installed-to-volumes
+        ,host ,chroot ,volumes))))
 
 (defprop host-volumes-created :lisp ()
   "Recursively create the volumes as specified by DISK:HAS-VOLUMES.
diff --git a/src/property/installer.lisp b/src/property/installer.lisp
new file mode 100644
index 0000000..c4877d3
--- /dev/null
+++ b/src/property/installer.lisp
@@ -0,0 +1,52 @@
+;;; 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.property.installer)
+(named-readtables:in-readtable :consfigurator)
+
+(defprop %update-target-from-chroot :posix (chroot target)
+  (:desc #?"Updated ${target} from ${chroot}")
+  (:apply
+   (assert-euid-root)
+   (run "rsync" "-PSav" "--delete"
+        (loop for volume
+                in (mapcan (curry #'subvolumes-of-type 'mounted-filesystem)
+                           (get-connattr :opened-volumes))
+              collect (strcat "--exclude="
+                              (unix-namestring (mount-point volume))))
+        (strcat (unix-namestring chroot) "/")
+        (strcat (unix-namestring target) "/"))))
+
+(defpropspec chroot-installed-to-volumes :posix (host chroot volumes)
+  "Where CHROOT contains the root filesystem of HOST and VOLUMES is a list of
+volumes, recursively open the volumes and rsync in the contents of CHROOT.
+Also update the fstab and crypttab, and try to install a bootloader."
+  (:desc #?"${chroot} installed to volumes")
+  (let ((target (ensure-directory-pathname
+                 (strcat (unix-namestring chroot) ".target"))))
+    `(with-these-open-volumes (,volumes :mount-below ,target)
+       (chroot:deploys-these
+        ,chroot ,host
+        ,(make-propspec
+          :systems nil
+          :propspec
+          '(eseqprops
+            ;; TODO (fstab:entries-for-opened-volumes)
+            (file:lacks-lines "/etc/fstab" "# UNCONFIGURED FSTAB FOR BASE SYSTEM"))))
+       ;; TODO Update /etc/crypttab
+       ;; TODO Install bootloader
+       (%update-target-from-chroot ,chroot ,target))))