nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2018-11-16 09:25:56 +01:00
parent 6e47628d4c
commit 52ee4479ef
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 34 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
guix/scripts/system.scm
View File

@ -175,12 +175,16 @@ TARGET, and register them."
(return *unspecified*))) (return *unspecified*)))
(define* (install-bootloader installer-drv (define* (install-bootloader installer
#:key #:key
bootcfg bootcfg-file bootcfg bootcfg-file
target) target)
"Call INSTALLER-DRV with error handling, in %STORE-MONAD." "Run INSTALLER, a bootloader installation script, with error handling, in
(with-monad %store-monad %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 (let* ((gc-root (string-append target %gc-roots-directory
"/bootcfg")) "/bootcfg"))
(temp-gc-root (string-append gc-root ".new")) (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_ "Consider running 'guix pull' before 'reconfigure'.~%"))
(warning (G_ "Failing to do that may downgrade your system!~%")))) (warning (G_ "Failing to do that may downgrade your system!~%"))))
(define (bootloader-installer-derivation installer (define (bootloader-installer-script installer
bootloader device target) bootloader device target)
"Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE
and TARGET arguments." and TARGET arguments."
(with-monad %store-monad (scheme-file "bootloader-installer"
(gexp->file "bootloader-installer" (with-imported-modules '((gnu build bootloader)
(with-imported-modules '((gnu build bootloader) (guix build utils))
(guix build utils)) #~(begin
#~(begin (use-modules (gnu build bootloader)
(use-modules (gnu build bootloader) (guix build utils)
(guix build utils) (ice-9 binary-ports))
(ice-9 binary-ports)) (#$installer #$bootloader #$device #$target)))))
(#$installer #$bootloader #$device #$target))))))
(define* (perform-action action os (define* (perform-action action os
#:key skip-safety-checks? #:key skip-safety-checks?
@ -851,31 +854,31 @@ static checks."
#:mappings mappings)) #:mappings mappings))
(bootloader -> (bootloader-configuration-bootloader (bootloader -> (bootloader-configuration-bootloader
(operating-system-bootloader os))) (operating-system-bootloader os)))
(bootcfg (if (eq? 'container action) (bootcfg -> (and (not (eq? 'container action))
(return #f) (operating-system-bootcfg
(lower-object os
(operating-system-bootcfg (if (eq? 'init action)
os '()
(if (eq? 'init action) (map boot-parameters->menu-entry
'() (profile-boot-parameters))))))
(map boot-parameters->menu-entry
(profile-boot-parameters)))))))
(bootcfg-file -> (bootloader-configuration-file bootloader)) (bootcfg-file -> (bootloader-configuration-file bootloader))
(bootloader-installer (bootloader-installer
->
(let ((installer (bootloader-installer bootloader)) (let ((installer (bootloader-installer bootloader))
(target (or target "/"))) (target (or target "/")))
(bootloader-installer-derivation installer (bootloader-installer-script installer
(bootloader-package bootloader) (bootloader-package bootloader)
bootloader-target target))) bootloader-target target)))
;; For 'init' and 'reconfigure', always build BOOTCFG, even if ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
;; --no-bootloader is passed, because we then use it as a GC root. ;; --no-bootloader is passed, because we then use it as a GC root.
;; See <http://bugs.gnu.org/21068>. ;; See <http://bugs.gnu.org/21068>.
(drvs -> (if (memq action '(init reconfigure)) (drvs (mapm %store-monad lower-object
(if install-bootloader? (if (memq action '(init reconfigure))
(list sys bootcfg bootloader-installer) (if install-bootloader?
(list sys bootcfg)) (list sys bootcfg bootloader-installer)
(list sys))) (list sys bootcfg))
(list sys))))
(% (if derivations-only? (% (if derivations-only?
(return (for-each (compose println derivation-file-name) (return (for-each (compose println derivation-file-name)
drvs)) drvs))