implement installing GRUB

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

1 files changed, 49 insertions, 5 deletions

diff --git a/src/property/installer.lisp b/src/property/installer.lisp
index 04bccfb..ed36631 100644
--- a/src/property/installer.lisp
+++ b/src/property/installer.lisp
@@ -18,6 +18,27 @@
 (in-package :consfigurator.property.installer)
 (named-readtables:in-readtable :consfigurator)
 
+;;;; Bootloaders
+
+(defgeneric install-bootloader (bootloader-type volume running-on-target &key)
+  (:documentation "Install bootloader of type BOOTLOADER-TYPE to VOLUME.
+
+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."))
+
+(defgeneric install-bootloader-binaries (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."))
+
+
+;;;; Properties
+
 (defprop %update-target-from-chroot :posix (chroot target)
   (:desc #?"Updated ${target} from ${chroot}")
   (:apply
@@ -31,10 +52,20 @@
         (strcat (unix-namestring chroot) "/")
         (strcat (unix-namestring target) "/"))))
 
-(defpropspec chroot-installed-to-volumes :lisp (host chroot volumes)
+(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
 volumes, recursively open the volumes and rsync in the contents of CHROOT.
-Also update the fstab and crypttab, and try to install a bootloader."
+Also update the fstab and crypttab, and try to install bootloader(s)."
   (:desc #?"${chroot} installed to volumes")
   (let ((target
           (ensure-directory-pathname
@@ -58,6 +89,19 @@ Also update the fstab and crypttab, and try to install a bootloader."
                 ;; there are other properties setting mount options etc. which
                 ;; are in conflict with VOLUMES.
                 (fstab:entries-for-opened-volumes)
-                (crypttab:entries-for-opened-volumes)))))
-       ;; TODO Install bootloader
-       )))
+                (crypttab:entries-for-opened-volumes)))
+           (%install-bootloaders 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")
+  (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
+    finally
+       (setq propapps (delete-duplicates propapps :test #'tree-equal))
+       (return (if (cdr propapps) (cons 'eseqprops propapps) (car propapps)))))