From 8fa130526050c4d3bdfa5465e06180f813a71f3c Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 7 May 2021 18:38:58 -0700 Subject: 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 --- src/deployment.lisp | 18 ++++++++ src/package.lisp | 11 +++-- src/property.lisp | 9 +--- src/property/grub.lisp | 43 ++++++++++-------- src/property/installer.lisp | 105 ++++++++++++++++++++++++++++---------------- src/property/u-boot.lisp | 29 ++++++++---- 6 files changed, 137 insertions(+), 78 deletions(-) (limited to 'src') 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)))) -- cgit v1.2.3