summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorMathieu Othacehe <m.othacehe@gmail.com>2017-04-02 09:34:01 +0200
committerMathieu Othacehe <m.othacehe@gmail.com>2017-05-16 14:41:01 +0200
commit3042c5d8bb54a74163c9b3acf90781d96d3374aa (patch)
tree58e7cf71ac153dda62e98710871fb3d3836945f4 /guix/scripts
parentbcaf67c44f4556b4a632310013a06318811aa0f0 (diff)
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.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/system.scm129
1 files changed, 77 insertions, 52 deletions
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 5fd0d7600c..d41cd926d8 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -147,27 +147,34 @@ TARGET, and register them."
(map (cut copy-item <> target #:log-port log-port)
to-copy))))
-(define (install-grub* grub.cfg device target)
- "This is a variant of 'install-grub' with error handling, lifted in
-%STORE-MONAD"
- (let* ((gc-root (string-append target %gc-roots-directory
- "/grub.cfg"))
- (temp-gc-root (string-append gc-root ".new"))
- (delete-file (lift1 delete-file %store-monad))
- (make-symlink (lift2 switch-symlinks %store-monad))
- (rename (lift2 rename-file %store-monad)))
- (mbegin %store-monad
- ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when
- ;; 'install-grub' completes (being a bit paranoid.)
- (make-symlink temp-gc-root grub.cfg)
-
- (munless (false-if-exception (install-grub grub.cfg device target))
+(define* (install-bootloader installer-drv
+ #:key
+ bootcfg bootcfg-file
+ device target)
+ "Call INSTALLER-DRV with error handling, in %STORE-MONAD."
+ (with-monad %store-monad
+ (let* ((gc-root (string-append target %gc-roots-directory
+ "/bootcfg"))
+ (temp-gc-root (string-append gc-root ".new"))
+ (install (and installer-drv
+ (derivation->output-path installer-drv)))
+ (bootcfg (derivation->output-path bootcfg)))
+ ;; 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)
+
+ (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)
- (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
- ;; image, font, etc.) are not reclaimed.
- (rename temp-gc-root gc-root))))
+ ;; Register bootloader config file as a GC root so that its dependencies
+ ;; (background image, font, etc.) are not reclaimed.
+ (rename-file temp-gc-root gc-root)
+ (return #t))))
(define* (install os-drv target
#: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_ "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
#:key bootloader? dry-run? derivations-only?
use-substitutes? device target
image-size full-boot?
(mappings '())
(gc-root #f))
- "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is
-the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
-is the size of the image to be built, for the 'vm-image' and 'disk-image'
-actions. FULL-BOOT? is used for the 'vm' action; it determines whether to
-boot directly to the kernel or to the bootloader.
+ "Perform ACTION for OS. BOOTLOADER? specifies whether to install
+bootloader; DEVICE is the target devices for bootloader; TARGET is the target
+root directory; IMAGE-SIZE is the size of the image to be built, for the
+'vm-image' and 'disk-image' actions. FULL-BOOT? is used for the 'vm' action;
+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
building anything.
@@ -598,26 +616,37 @@ output when building a system derivation, such as a disk image."
#:image-size image-size
#:full-boot? full-boot?
#:mappings mappings))
- (bootloader (let ((bootloader (bootloader-package
- (bootloader-configuration-bootloader
- (operating-system-bootloader os)))))
- (if bootloader
- (package->derivation bootloader)
- (return #f))))
- (grub.cfg (if (eq? 'container action)
- (return #f)
- (operating-system-bootcfg os
- (if (eq? 'init action)
- '()
- (profile-boot-parameters)))))
-
- ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if
- ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC
- ;; root. See <http://bugs.gnu.org/21068>.
+ (bootloader -> (bootloader-configuration-bootloader
+ (operating-system-bootloader os)))
+ (bootloader-package
+ (let ((package (bootloader-package bootloader)))
+ (if package
+ (package->derivation package)
+ (return #f))))
+ (bootcfg (if (eq? 'container action)
+ (return #f)
+ (operating-system-bootcfg
+ os
+ (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 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 (and bootloader? bootloader)
- (list sys grub.cfg bootloader)
- (list sys grub.cfg))
+ (if (and bootloader? bootloader-package)
+ (list sys bootcfg
+ bootloader-package
+ bootloader-installer)
+ (list sys bootcfg))
(list sys)))
(% (if derivations-only?
(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)
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
((reconfigure)
(mbegin %store-monad
(switch-to-system os)
(mwhen bootloader?
- (install-grub* (derivation->output-path grub.cfg)
- device "/"))))
+ (install-bootloader bootloader-installer
+ #:bootcfg bootcfg
+ #:bootcfg-file bootcfg-file
+ #:device device
+ #:target "/"))))
((init)
(newline)
(format #t (G_ "initializing operating system under '~a'...~%")