implement installing GRUB

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

5 files changed, 132 insertions, 7 deletions

diff --git a/consfigurator.asd b/consfigurator.asd
index f61220d..85c8dd0 100644
--- a/consfigurator.asd
+++ b/consfigurator.asd
@@ -45,6 +45,7 @@
                (:file "src/property/sshd")
                (:file "src/property/locale")
                (:file "src/property/installer")
+               (:file "src/property/grub")
                (:file "src/connection/shell-wrap")
 	       (:file "src/connection/fork")
                (:file "src/connection/rehome")
diff --git a/src/package.lisp b/src/package.lisp
index 88cea7a..97312e8 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -375,10 +375,12 @@
            #:volume-label
            #:volume-contents
            #:volume-size
+           #:volume-bootloader
            #:subvolumes-of-type
            #:all-subvolumes
            #:copy-volume-and-contents
            #:require-volumes-data
+           #:opened-volume
            #:device-file
 
            #:physical-disk
@@ -479,7 +481,19 @@
                     (#:chroot    #:consfigurator.property.chroot)
                     (#:fstab     #:consfigurator.property.fstab)
                     (#:crypttab  #:consfigurator.property.crypttab))
-  (:export #:chroot-installed-to-volumes))
+  (:export #:install-bootloader
+           #:install-bootloader-binaries
+           #:chroot-installed-to-volumes
+           #:bootloader-binaries-installed))
+
+(defpackage :consfigurator.property.grub
+  (:use #:cl #:alexandria #:consfigurator
+        #:consfigurator.property.disk
+        #:consfigurator.property.installer)
+  (:local-nicknames (#:os        #:consfigurator.property.os)
+                    (#:file      #:consfigurator.property.file)
+                    (#:apt       #:consfigurator.property.apt))
+  (:export #:grub))
 
 (defpackage :consfigurator.connection.local
   (:use #:cl #:consfigurator #:alexandria)
diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index 7a9654a..077fb1d 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -49,7 +49,17 @@ The special value :REMAINING means all remaining free space in the volume
 containing this one.
 
 If a larger size is required to accommodate the VOLUME-CONTENTS of the volume
-plus any metadata (e.g. partition tables), this value will be ignored."))
+plus any metadata (e.g. partition tables), this value will be ignored.")
+   (volume-bootloader
+    :type list :initarg :boots-with :accessor volume-bootloader
+    :documentation
+    "List specifying a bootloader to be installed to this volume.  The first
+element is a symbol identifying the type of bootloader, and the remaining
+elements are a plist of keyword arguments to be passed to the implementation
+of INSTALLER:INSTALL-BOOTLOADER for that bootloader type.
+
+Typically only the top level PHYSICAL-DISK of a host's volumes will have this
+slot bound."))
   (:documentation
    "Something which contains filesystems and/or other volumes."))
 
@@ -788,6 +798,16 @@ filesystems stored on other physical disks would normally be mounted.
 
 OPTIONS will be passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see.
 
+In most cases you will need to ensure that HOST has properties which do at
+least the following:
+
+  - declare the host's OS
+
+  - install a kernel
+
+  - install the binaries/packages needed to install the host's bootloader to
+    its volumes (usually with INSTALLER:BOOTLOADER-BINARIES-INSTALLED).
+
 Unless REBUILD, the image will not be repartitioned even if the specification
 of the host's volumes changes, although the contents of the image's
 filesystems will be incrementally updated when other properties change."
diff --git a/src/property/grub.lisp b/src/property/grub.lisp
new file mode 100644
index 0000000..45b19cd
--- /dev/null
+++ b/src/property/grub.lisp
@@ -0,0 +1,46 @@
+;;; 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.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
+    ((type (eql 'grub)) volume &key (target "i386-pc") &allow-other-keys)
+  `(os:etypecase
+       (debianlike
+        (apt:installed
+         "initramfs-tools"
+         ,(eswitch (target :test #'string=)
+            ("i386-pc" "grub-pc")
+            ("x86_64-efi" "grub-efi-amd64"))))))
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)))))