diff options
author | Ludovic Courtès <ludo@gnu.org> | 2018-11-16 09:25:56 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2018-11-18 23:37:45 +0100 |
commit | 52ee4479ef26826a53b9929cd00ca7738be687b1 (patch) | |
tree | 64644e2f6f231d6a175219a0e8b979447839b44c | |
parent | 6e47628d4c9173633d0ac2a0ddaeb50a8257d725 (diff) | |
download | guix-52ee4479ef26826a53b9929cd00ca7738be687b1.tar guix-52ee4479ef26826a53b9929cd00ca7738be687b1.tar.gz |
guix system: De-monadify bootloader installation script.
* guix/scripts/system.scm (bootloader-installer-derivation): Rename
to...
(bootloader-installer-script): ... this. Use 'scheme-file' instead of
'gexp->file'.
(perform-action): Adjust accordingly. Move 'lower-object' call to the
point where DRVS is computed.
-rw-r--r-- | guix/scripts/system.scm | 65 |
1 files changed, 34 insertions, 31 deletions
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 14488107b8..6f00f12509 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -175,12 +175,16 @@ TARGET, and register them." (return *unspecified*))) -(define* (install-bootloader installer-drv +(define* (install-bootloader installer #:key bootcfg bootcfg-file target) - "Call INSTALLER-DRV with error handling, in %STORE-MONAD." - (with-monad %store-monad + "Run INSTALLER, a bootloader installation script, with error handling, in +%STORE-MONAD." + (mlet %store-monad ((installer-drv (if installer + (lower-object installer) + (return #f))) + (bootcfg (lower-object bootcfg))) (let* ((gc-root (string-append target %gc-roots-directory "/bootcfg")) (temp-gc-root (string-append gc-root ".new")) @@ -790,19 +794,18 @@ checking this by themselves in their 'check' procedure." (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) (warning (G_ "Failing to do that may downgrade your system!~%")))) -(define (bootloader-installer-derivation installer - bootloader device target) +(define (bootloader-installer-script installer + bootloader device target) "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE and TARGET arguments." - (with-monad %store-monad - (gexp->file "bootloader-installer" - (with-imported-modules '((gnu build bootloader) - (guix build utils)) - #~(begin - (use-modules (gnu build bootloader) - (guix build utils) - (ice-9 binary-ports)) - (#$installer #$bootloader #$device #$target)))))) + (scheme-file "bootloader-installer" + (with-imported-modules '((gnu build bootloader) + (guix build utils)) + #~(begin + (use-modules (gnu build bootloader) + (guix build utils) + (ice-9 binary-ports)) + (#$installer #$bootloader #$device #$target))))) (define* (perform-action action os #:key skip-safety-checks? @@ -851,31 +854,31 @@ static checks." #:mappings mappings)) (bootloader -> (bootloader-configuration-bootloader (operating-system-bootloader os))) - (bootcfg (if (eq? 'container action) - (return #f) - (lower-object - (operating-system-bootcfg - os - (if (eq? 'init action) - '() - (map boot-parameters->menu-entry - (profile-boot-parameters))))))) + (bootcfg -> (and (not (eq? 'container action)) + (operating-system-bootcfg + os + (if (eq? 'init action) + '() + (map boot-parameters->menu-entry + (profile-boot-parameters)))))) (bootcfg-file -> (bootloader-configuration-file bootloader)) (bootloader-installer + -> (let ((installer (bootloader-installer bootloader)) (target (or target "/"))) - (bootloader-installer-derivation installer - (bootloader-package bootloader) - bootloader-target target))) + (bootloader-installer-script installer + (bootloader-package bootloader) + bootloader-target target))) ;; For 'init' and 'reconfigure', always build BOOTCFG, even if ;; --no-bootloader is passed, because we then use it as a GC root. ;; See <http://bugs.gnu.org/21068>. - (drvs -> (if (memq action '(init reconfigure)) - (if install-bootloader? - (list sys bootcfg bootloader-installer) - (list sys bootcfg)) - (list sys))) + (drvs (mapm %store-monad lower-object + (if (memq action '(init reconfigure)) + (if install-bootloader? + (list sys bootcfg bootloader-installer) + (list sys bootcfg)) + (list sys)))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) drvs)) |