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

scripts: system: Adapt "reconfigure" to new bootloader API. 

* guix/scripts/system.scm (install-grub*): Rename to install-bootloader.  Use
keys to pass arguments.  Pass a new argument, "installer-drv" which is a script
in store dealing with bootloader-specific install actions.  Also call
"install-boot-config" to install the bootloader config file.

(install-bootloader-derivation): New procedure.  It returns a derivation that
builds a file containing "install-procedure" gexp.

(perform-action): Build install-proc derivation and call install-bootloader
with the resulting file.  Stop adding GRUB to PATH as bootloaders are called in
install-proc with direct store paths.
This commit is contained in:
Mathieu Othacehe 2017-04-02 09:34:01 +02:00
parent bcaf67c44f
commit 3042c5d8bb
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
1 changed files with 75 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
guix/scripts/system.scm
View File

@ -147,27 +147,34 @@ TARGET, and register them."
(map (cut copy-item <> target #:log-port log-port) (map (cut copy-item <> target #:log-port log-port)
to-copy)))) to-copy))))
(define (install-grub* grub.cfg device target) (define* (install-bootloader installer-drv
"This is a variant of 'install-grub' with error handling, lifted in #:key
%STORE-MONAD" bootcfg bootcfg-file
(let* ((gc-root (string-append target %gc-roots-directory device target)
"/grub.cfg")) "Call INSTALLER-DRV with error handling, in %STORE-MONAD."
(temp-gc-root (string-append gc-root ".new")) (with-monad %store-monad
(delete-file (lift1 delete-file %store-monad)) (let* ((gc-root (string-append target %gc-roots-directory
(make-symlink (lift2 switch-symlinks %store-monad)) "/bootcfg"))
(rename (lift2 rename-file %store-monad))) (temp-gc-root (string-append gc-root ".new"))
(mbegin %store-monad (install (and installer-drv
;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when (derivation->output-path installer-drv)))
;; 'install-grub' completes (being a bit paranoid.) (bootcfg (derivation->output-path bootcfg)))
(make-symlink temp-gc-root grub.cfg) ;; Prepare the symlink to bootloader config file to make sure that it's
;; a GC root when 'installer-drv' completes (being a bit paranoid.)
(switch-symlinks temp-gc-root bootcfg)
(munless (false-if-exception (install-grub grub.cfg device target)) (unless (false-if-exception
(begin
(install-boot-config bootcfg bootcfg-file target)
(when install
(save-load-path-excursion (primitive-load install)))))
(delete-file temp-gc-root) (delete-file temp-gc-root)
(leave (G_ "failed to install GRUB on device '~a'~%") device)) (leave (G_ "failed to install bootloader on device ~a '~a'~%") install device))
;; Register GRUB.CFG as a GC root so that its dependencies (background ;; Register bootloader config file as a GC root so that its dependencies
;; image, font, etc.) are not reclaimed. ;; (background image, font, etc.) are not reclaimed.
(rename temp-gc-root gc-root)))) (rename-file temp-gc-root gc-root)
(return #t))))
(define* (install os-drv target (define* (install os-drv target
#:key (log-port (current-output-port)) #:key (log-port (current-output-port))
@ -570,17 +577,28 @@ PATTERN, a string. When PATTERN is #f, display all the system generations."
(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
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 '((guix build utils))
#~(begin
(use-modules (guix build utils))
(#$installer #$bootloader #$device #$target))))))
(define* (perform-action action os (define* (perform-action action os
#:key bootloader? dry-run? derivations-only? #:key bootloader? dry-run? derivations-only?
use-substitutes? device target use-substitutes? device target
image-size full-boot? image-size full-boot?
(mappings '()) (mappings '())
(gc-root #f)) (gc-root #f))
"Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is "Perform ACTION for OS. BOOTLOADER? specifies whether to install
the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE bootloader; DEVICE is the target devices for bootloader; TARGET is the target
is the size of the image to be built, for the 'vm-image' and 'disk-image' root directory; IMAGE-SIZE is the size of the image to be built, for the
actions. FULL-BOOT? is used for the 'vm' action; it determines whether to 'vm-image' and 'disk-image' actions. FULL-BOOT? is used for the 'vm' action;
boot directly to the kernel or to the bootloader. it determines whether to boot directly to the kernel or to the bootloader.
When DERIVATIONS-ONLY? is true, print the derivation file name(s) without When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
building anything. building anything.
@ -598,26 +616,37 @@ output when building a system derivation, such as a disk image."
#:image-size image-size #:image-size image-size
#:full-boot? full-boot? #:full-boot? full-boot?
#:mappings mappings)) #:mappings mappings))
(bootloader (let ((bootloader (bootloader-package (bootloader -> (bootloader-configuration-bootloader
(bootloader-configuration-bootloader (operating-system-bootloader os)))
(operating-system-bootloader os))))) (bootloader-package
(if bootloader (let ((package (bootloader-package bootloader)))
(package->derivation bootloader) (if package
(return #f)))) (package->derivation package)
(grub.cfg (if (eq? 'container action) (return #f))))
(return #f) (bootcfg (if (eq? 'container action)
(operating-system-bootcfg os (return #f)
(if (eq? 'init action) (operating-system-bootcfg
'() os
(profile-boot-parameters))))) (if (eq? 'init action)
'()
(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
device target)))
;; For 'init' and 'reconfigure', always build GRUB.CFG, even if ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
;; --no-grub is passed, because GRUB.CFG because we then use it as a GC ;; --no-bootloader is passed, because we then use it as a GC root.
;; root. See <http://bugs.gnu.org/21068>. ;; See <http://bugs.gnu.org/21068>.
(drvs -> (if (memq action '(init reconfigure)) (drvs -> (if (memq action '(init reconfigure))
(if (and bootloader? bootloader) (if (and bootloader? bootloader-package)
(list sys grub.cfg bootloader) (list sys bootcfg
(list sys grub.cfg)) bootloader-package
bootloader-installer)
(list sys bootcfg))
(list sys))) (list sys)))
(% (if derivations-only? (% (if derivations-only?
(return (for-each (compose println derivation-file-name) (return (for-each (compose println derivation-file-name)
@ -631,20 +660,16 @@ output when building a system derivation, such as a disk image."
(for-each (compose println derivation->output-path) (for-each (compose println derivation->output-path)
drvs) drvs)
;; Make sure GRUB is accessible.
(when (and bootloader? bootloader)
(let ((prefix (derivation->output-path bootloader)))
(setenv "PATH"
(string-append prefix "/bin:" prefix "/sbin:"
(getenv "PATH")))))
(case action (case action
((reconfigure) ((reconfigure)
(mbegin %store-monad (mbegin %store-monad
(switch-to-system os) (switch-to-system os)
(mwhen bootloader? (mwhen bootloader?
(install-grub* (derivation->output-path grub.cfg) (install-bootloader bootloader-installer
device "/")))) #:bootcfg bootcfg
#:bootcfg-file bootcfg-file
#:device device
#:target "/"))))
((init) ((init)
(newline) (newline)
(format #t (G_ "initializing operating system under '~a'...~%") (format #t (G_ "initializing operating system under '~a'...~%")