aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-11-16 09:25:56 +0100
committerLudovic Courtès <ludo@gnu.org>2018-11-18 23:37:45 +0100
commit52ee4479ef26826a53b9929cd00ca7738be687b1 (patch)
tree64644e2f6f231d6a175219a0e8b979447839b44c
parent6e47628d4c9173633d0ac2a0ddaeb50a8257d725 (diff)
downloadguix-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.scm65
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))