rework bootloader installation so can use property-defining macros

It is better to have the code which installs bootloaders to volumes in
property definitions rather than in plain functions, as then we can specify
that it's :POSIX or :LISP, specify the OS required for it to run, and similar.

This commit enables that by replacing INSTALL-BOOTLOADER with a different
generic which returns propspecs.

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

6 files changed, 137 insertions, 78 deletions

diff --git a/src/deployment.lisp b/src/deployment.lisp
index 2ac6697..18c9ff0 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -53,6 +53,24 @@ preprocessed."
         (t
          (connect '((:local))))))))
 
+(defun consfigure (propspec-expression)
+  "Immediately preprocess and apply PROPSPEC-EXPRESSION in the context of the
+current target host and connection.  This function is provided for use by
+specialised property combinators.  It should not be used in property
+definitions nor in consfigs.
+
+The :HOSTATTRS subroutines of properties applied by PROPSPEC-EXPRESSION will
+be executed, but any new hostattrs they push will be discarded.  Thus either
+PROPSPEC-EXPRESSION should not apply any properties whose :HOSTATTRS
+subroutines push new hostattrs, or the caller should seperately arrange for
+those subroutines to be executed in a context in which newly pushed hostattrs
+will not be discarded."
+  (%consfigure
+   nil (make-host
+        :hostattrs (hostattrs *host*)
+        :propspec (with-*host*-*consfig*
+                    (make-propspec :propspec propspec-expression)))))
+
 (defun deploy* (connections host &optional additional-properties)
   "Execute the deployment which is defined by the pair (CONNECTIONS . HOST),
 except possibly with the property application specification
diff --git a/src/package.lisp b/src/package.lisp
index 356ab1e..bc4a146 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -185,6 +185,7 @@
            #:with-replace-hostattrs
 
            ;; deployment.lisp
+           #:consfigure
            #:defdeploy
            #:defdeploy-these
            #:deploy
@@ -482,8 +483,8 @@
                     (#:chroot    #:consfigurator.property.chroot)
                     (#:fstab     #:consfigurator.property.fstab)
                     (#:crypttab  #:consfigurator.property.crypttab))
-  (:export #:install-bootloader
-           #:install-bootloader-binaries
+  (:export #:install-bootloader-propspec
+           #:install-bootloader-binaries-propspec
            #:chroot-installed-to-volumes
            #:bootloader-binaries-installed))
 
@@ -494,7 +495,8 @@
   (:local-nicknames (#:os        #:consfigurator.property.os)
                     (#:file      #:consfigurator.property.file)
                     (#:apt       #:consfigurator.property.apt))
-  (:export #:grub))
+  (:export #:grub
+           #:grub-installed))
 
 (defpackage :consfigurator.property.u-boot
   (:use #:cl #:alexandria #:consfigurator
@@ -502,7 +504,8 @@
         #:consfigurator.property.installer)
   (:local-nicknames (#:os        #:consfigurator.property.os)
                     (#:apt       #:consfigurator.property.apt))
-  (:export #:u-boot-install-rockchip))
+  (:export #:u-boot-install-rockchip
+           #:u-boot-installed-rockchip))
 
 (defpackage :consfigurator.connection.local
   (:use #:cl #:consfigurator #:alexandria)
diff --git a/src/property.lisp b/src/property.lisp
index 497b2f1..49e1a6a 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -279,14 +279,7 @@ parsing FORMSV and pushing SETPROP keyword argument pairs to plist SLOTSV."
                          ;; in this way, so issue a warning.
                          ,@(and (getf ,slotsv :hostattrs)
                                 '((programmatic-apply-hostattrs)))
-                         (%consfigure
-                          nil
-                          (make-host
-			   :hostattrs (hostattrs *host*)
-                           :propspec
-                           (with-*host*-*consfig*
-                             (make-propspec
-                              :propspec (cons ',,name args))))))))))))))))
+                         (consfigure (cons ',,name args)))))))))))))
 
 (define-condition programmatic-apply-hostattrs (simple-warning) ())
 
diff --git a/src/property/grub.lisp b/src/property/grub.lisp
index 45b19cd..9ef4761 100644
--- a/src/property/grub.lisp
+++ b/src/property/grub.lisp
@@ -18,24 +18,12 @@
 (in-package :consfigurator.property.grub)
 (named-readtables:in-readtable :consfigurator)
 
-(defmethod install-bootloader
-    ((type (eql 'grub)) (volume opened-volume) running-on-target
-     &key (target "i386-pc") force-extra-removable)
-  (mrun :inform "update-initramfs" "-u")
-  (let ((os-prober (and (not running-on-target)
-                        (remote-exists-p "/etc/grub.d/30_os-prober"))))
-    ;; work around Debian bug #802717
-    (when os-prober (file:has-mode "/etc/grub.d/30_os-prober" #o644))
-    (mrun :inform "update-grub")
-    (when os-prober (file:has-mode "/etc/grub.d/30_os-prober" #o755)))
-  (mrun :inform "grub-install" (strcat "--target=" target)
-        (and (string-suffix-p target "-efi") (not running-on-target)
-             "--no-nvram")
-        (and force-extra-removable "--force-extra-removable")
-        (device-file volume))
-  (mrun "sync"))
-
-(defmethod install-bootloader-binaries
+(defmethod install-bootloader-propspec
+    ((type (eql 'grub)) volume running-on-target
+     &rest args &key &allow-other-keys)
+  `(grub-installed ,volume ,running-on-target ,@args))
+
+(defmethod install-bootloader-binaries-propspec
     ((type (eql 'grub)) volume &key (target "i386-pc") &allow-other-keys)
   `(os:etypecase
        (debianlike
@@ -44,3 +32,22 @@
          ,(eswitch (target :test #'string=)
             ("i386-pc" "grub-pc")
             ("x86_64-efi" "grub-efi-amd64"))))))
+
+(defprop grub-installed :posix
+    (volume running-on-target &key (target "i386-pc") force-extra-removable)
+  "Use grub-install(8) to install grub to VOLUME."
+  (:desc "GRUB installed")
+  (:apply
+   (assert-euid-root)
+   (mrun :inform "update-initramfs" "-u")
+   (let ((os-prober (and (not running-on-target)
+                         (remote-exists-p "/etc/grub.d/30_os-prober"))))
+     ;; work around Debian bug #802717
+     (when os-prober (file:has-mode "/etc/grub.d/30_os-prober" #o644))
+     (mrun :inform "update-grub")
+     (when os-prober (file:has-mode "/etc/grub.d/30_os-prober" #o755)))
+   (mrun :inform "grub-install" (strcat "--target=" target)
+         (and (string-suffix-p target "-efi") (not running-on-target)
+              "--no-nvram")
+         (and force-extra-removable "--force-extra-removable")
+         (device-file volume))))
diff --git a/src/property/installer.lisp b/src/property/installer.lisp
index ed36631..c270bdf 100644
--- a/src/property/installer.lisp
+++ b/src/property/installer.lisp
@@ -20,21 +20,49 @@
 
 ;;;; Bootloaders
 
-(defgeneric install-bootloader (bootloader-type volume running-on-target &key)
-  (:documentation "Install bootloader of type BOOTLOADER-TYPE to VOLUME.
+(defgeneric install-bootloader-propspec
+    (bootloader-type volume running-on-target &key)
+  (:documentation
+   "Return a propspec expression which installs bootloader of type
+BOOTLOADER-TYPE to VOLUME.
+The propapp yielded by the propspec may be of type :POSIX or of type :LISP.
 
 RUNNING-ON-TARGET indicates whether the host to which we are connected is the
 host the bootloader will boot.  For example, it is NIL when building disk
 images, and T when installing a host from a live environment.  Bootloader
 installation might behave differently when RUNNING-ON-TARGET is NIL, or error
-out.
-
-Only :LISP property :APPLY subroutines will call this function."))
+out."))
 
-(defgeneric install-bootloader-binaries (bootloader-type volume &key)
+(defgeneric install-bootloader-binaries-propspec (bootloader-type volume &key)
   (:documentation
-   "Return a :POSIX propapp which fetches/installs whatever binaries/packages
-need to be available to install BOOTLOADER-TYPE to VOLUME."))
+   "Return a propspec expression evaluating to a :POSIX propapp which
+fetches/installs whatever binaries/packages need to be available to install
+BOOTLOADER-TYPE to VOLUME."))
+
+(defun get-propspecs (volumes running-on-target)
+  (loop for volume in (mapcan #'all-subvolumes volumes)
+        when (slot-boundp volume 'volume-bootloader)
+          collect (destructuring-bind (type . args) (volume-bootloader volume)
+                    (apply #'install-bootloader-propspec
+                           type volume running-on-target args))))
+
+;; At :HOSTATTRS time we don't have the OPENED-VOLUME values required by the
+;; :APPLY subroutines which actually install the bootloaders.  So we call
+;; GET-PROPSPECS twice: (in CHROOT-INSTALLED-TO-VOLUMES) at :HOSTATTRS time to
+;; generate propspecs for the sake of running :HOSTATTRS subroutines, and then
+;; at :APPLY time where we can get at the OPENED-VOLUME values, we ignore the
+;; previously generated propspecs and call GET-PROPSPECS again.  This approach
+;; should work for any sensible VOLUME<->OPENED-VOLUME pairs.
+(define-function-property-combinator
+    %install-bootloaders (running-on-target &rest propapps)
+  (:retprop
+   :type :lisp
+   :hostattrs (lambda () (mapc #'propappattrs propapps))
+   :apply
+   (lambda ()
+     (mapc #'consfigure
+           (get-propspecs (get-connattr :opened-volumes) running-on-target))
+     (mrun "sync"))))
 
 
 ;;;; Properties
@@ -52,15 +80,6 @@ need to be available to install BOOTLOADER-TYPE to VOLUME."))
         (strcat (unix-namestring chroot) "/")
         (strcat (unix-namestring target) "/"))))
 
-(defprop %install-bootloaders :lisp (running-on-target)
-  (:desc #?"Installed host bootloaders")
-  (:apply
-   (assert-euid-root)
-   (dolist (volume (mapcan #'all-subvolumes (get-connattr :opened-volumes)))
-    (when (slot-boundp volume 'volume-bootloader)
-      (destructuring-bind (type . args) (volume-bootloader volume)
-        (apply #'install-bootloader type volume running-on-target args))))))
-
 (defpropspec chroot-installed-to-volumes :lisp
     (host chroot volumes &key running-on-target)
   "Where CHROOT contains the root filesystem of HOST and VOLUMES is a list of
@@ -75,33 +94,41 @@ Also update the fstab and crypttab, and try to install bootloader(s)."
             ".target"))))
     `(with-these-open-volumes (,volumes :mount-below ,target)
        (%update-target-from-chroot ,chroot ,target)
-       ,(propapp
-         (chroot:deploys-these. target host
-           (os:etypecase
-               (debianlike
-                (file:lacks-lines "/etc/fstab"
-                                  "# UNCONFIGURED FSTAB FOR BASE SYSTEM")
-                ;; These will overwrite any custom mount options, etc., with
-                ;; values from VOLUMES.  Possibly it would be better to use
-                ;; properties which only update the fs-spec/source fields.
-                ;; However, given that VOLUMES ultimately comes from the
-                ;; volumes the user has declared for the host, it is unlikely
-                ;; there are other properties setting mount options etc. which
-                ;; are in conflict with VOLUMES.
-                (fstab:entries-for-opened-volumes)
-                (crypttab:entries-for-opened-volumes)))
-           (%install-bootloaders running-on-target))))))
+       (chroot:deploys-these
+        ,target ,host
+        ,(make-propspec
+          :propspec
+          `(eseqprops
+            ,(propapp
+              (os:etypecase
+                  (debianlike
+                   (file:lacks-lines
+                    "/etc/fstab" "# UNCONFIGURED FSTAB FOR BASE SYSTEM")
+                   ;; These will overwrite any custom mount options, etc.,
+                   ;; with values from VOLUMES.  Possibly it would be better
+                   ;; to use properties which only update the fs-spec/source
+                   ;; fields.  However, given that VOLUMES ultimately comes
+                   ;; from the volumes the user has declared for the host, it
+                   ;; is unlikely there are other properties setting mount
+                   ;; options etc. which are in conflict with VOLUMES.
+                   (fstab:entries-for-opened-volumes)
+                   (crypttab:entries-for-opened-volumes))))
+            (%install-bootloaders
+             ,running-on-target
+             ,@(get-propspecs (get-hostattrs :volumes) running-on-target))))))))
 
 (defpropspec bootloader-binaries-installed :posix ()
   "Install whatever binaries/packages need to be available to install the host's
-bootloaders to its volumes from within that host."
-  (:desc #?"Bootloader binaries installed")
+bootloaders to its volumes from within that host.  For example, this might
+install a package providing /usr/sbin/grub-install, but it won't execute it."
+  (:desc "Bootloader binaries installed")
   (loop
     for volume in (mapcan #'all-subvolumes (get-hostattrs :volumes))
     when (slot-boundp volume 'volume-bootloader)
       collect (destructuring-bind (type . args) (volume-bootloader volume)
-                (apply #'install-bootloader-binaries type volume args))
-        into propapps
+                (apply #'install-bootloader-binaries-propspec type volume args))
+        into propspecs
     finally
-       (setq propapps (delete-duplicates propapps :test #'tree-equal))
-       (return (if (cdr propapps) (cons 'eseqprops propapps) (car propapps)))))
+       (setq propspecs (delete-duplicates propspecs :test #'tree-equal))
+       (return
+         (if (cdr propspecs) (cons 'eseqprops propspecs) (car propspecs)))))
diff --git a/src/property/u-boot.lisp b/src/property/u-boot.lisp
index 9d8f7f0..4e45527 100644
--- a/src/property/u-boot.lisp
+++ b/src/property/u-boot.lisp
@@ -18,14 +18,25 @@
 (in-package :consfigurator.property.u-boot)
 (named-readtables:in-readtable :consfigurator)
 
-(defmethod install-bootloader ((type (eql 'u-boot-install-rockchip))
-                               (volume opened-volume)
-                               running-on-target &key)
-  (mrun "u-boot-install-rockchip" (device-file volume))
-  (mrun "sync"))
-
-(defmethod install-bootloader-binaries
-    ((type (eql 'u-boot-install-rockchip)) volume &key)
-  `(os:etypecase
+;; Currently we have a distinct property for each (Debian-specific)
+;; installation script.  Perhaps there is some sensible parameterisation of
+;; these available instead.
+
+(defmethod install-bootloader-propspec
+    ((type (eql 'u-boot-install-rockchip)) volume running-on-target
+     &key &allow-other-keys)
+  `(u-boot-installed-rockchip ,volume ,running-on-target))
+
+(defmethod install-bootloader-binaries-propspec
+    ((type (eql 'u-boot-install-rockchip)) volume &key &allow-other-keys)
+  '(os:etypecase
        (debianlike
         (apt:installed "u-boot-rockchip"))))
+
+(defprop u-boot-installed-rockchip :posix (volume running-on-target)
+  (:desc "Installed U-Boot using Debian scripts")
+  (:hostattrs
+   (os:required 'os:debianlike))
+  (:apply
+   (declare (ignore running-on-target))
+   (mrun "u-boot-install-rockchip" (device-file volume))))