Rather than passing around GRUB flags when building a VM or configuring a system, a new function is added named 'prepare-install-grub'. It takes a grub.cfg, a object and a mount point then returns an unevaluated function call to install-grub which is incorporated in to a VM builder script or evaluated when building a system on the host machine. * gnu/system/grub.scm (prepare-install-grub): Add new function. This function is intended to be used to generate build-side code as well as be evaluated on the host, and handle errors through false-if-exception. * gnu/system/vm.scm (qemu-image): Use prepare-install-grub to call install-grub. (qemu-image): Pass a new function 'do-install-grub' to initialize-hard-disk. * guix/scripts/system.scm (install-grub*): Use keys for receiving parameters. (install-grub*): Call prepare-install-grub instead. (install): No longer take a grub? parameter or call install-grub. (perform-action): No longer take a device parameter, and use install-grub* to install and set GC roots for both init and reconfigure actions. * gnu/build/install.scm (register-grub.cfg-root): Move from gnu/build/vm.scm. * gnu/build/vm.scm (register-grub.cfg-root): Move to gnu/build/install.scm. (initialize-hard-disk): Add install-boot parameter, remove grub.cfg parameter. (initialize-hard-disk): Use install-boot function to install grub. (initialize-hard-disk): Don't register the GC root as install-grub* does. --- gnu/build/install.scm | 7 ++++++ gnu/build/vm.scm | 18 ++++++-------- gnu/system/grub.scm | 15 +++++++++++- gnu/system/vm.scm | 15 ++++++++++-- guix/scripts/system.scm | 63 ++++++++++++++++++++++++++----------------------- 5 files changed, 74 insertions(+), 44 deletions(-) diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 9785b6d..e4f087f 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -22,6 +22,7 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (install-grub + register-grub.cfg-root populate-root-file-system reset-timestamps register-closure @@ -58,6 +59,12 @@ GC'd." device)) (error "failed to install GRUB")))) +(define (register-grub.cfg-root target grub.cfg) + "On file system TARGET, register GRUB.CFG as a GC root." + (let ((directory (string-append target "/var/guix/gcroots"))) + (mkdir-p directory) + (symlink grub.cfg (string-append directory "/grub.cfg")))) + (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET." diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 48e701a..faee32a 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2016 Christopher Allan Webber ;;; Copyright © 2016 Leo Famulari +;;; Copyright © 2016 Jookia <166291@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -287,18 +288,12 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (unless register-closures? (reset-timestamps target)))) -(define (register-grub.cfg-root target grub.cfg) - "On file system TARGET, register GRUB.CFG as a GC root." - (let ((directory (string-append target "/var/guix/gcroots"))) - (mkdir-p directory) - (symlink grub.cfg (string-append directory "/grub.cfg")))) - (define* (initialize-hard-disk device #:key - grub.cfg + install-boot (partitions '())) "Initialize DEVICE as a disk containing all the objects listed -in PARTITIONS, and using GRUB.CFG as its bootloader configuration file. +in PARTITIONS, then run INSTALL-BOOT with the DEVICE and TARGET keys set. Each partition is initialized by calling its 'initializer' procedure, passing it a directory name where it is mounted." @@ -313,10 +308,11 @@ passing it a directory name where it is mounted." (display "mounting root partition...\n") (mkdir-p target) (mount (partition-device root) target (partition-file-system root)) - (install-grub grub.cfg device target) - ;; Register GRUB.CFG as a GC root. - (register-grub.cfg-root target grub.cfg) + (unless (install-boot + #:device device + #:target target) + (error "unable to install bootloader")) (umount target))) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 45b46ca..c9d4359 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 Jookia <166291@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (guix download) #:use-module (gnu artwork) #:use-module (gnu system file-systems) + #:use-module (gnu build install) #:autoload (gnu packages grub) (grub) #:autoload (gnu packages inkscape) (inkscape) #:autoload (gnu packages imagemagick) (imagemagick) @@ -54,7 +56,8 @@ menu-entry menu-entry? - grub-configuration-file)) + grub-configuration-file + prepare-install-grub)) ;;; Commentary: ;;; @@ -287,4 +290,14 @@ submenu \"GNU system, old configurations...\" {~%") (gexp->derivation "grub.cfg" builder))) +(define* (prepare-install-grub #:key grub.cfg config mount-point) + "Prepares a call to install-grub with arguments set using the GRUB.CFG, the + CONFIG object and the MOUNT-POINT the system root is on." + `(begin + (use-modules ((gnu build install))) + (false-if-exception + (install-grub ,grub.cfg + ,(grub-configuration-device config) + ,mount-point)))) + ;;; grub.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f4bf045..35c573d 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -214,6 +214,7 @@ register INPUTS in the store database of the image so that Guix can be used in the image." (mlet* %store-monad ((os-drv (operating-system-derivation os-configuration)) (grub.cfg (operating-system-grub.cfg os-configuration)) + (drive -> "/dev/vda") (inputs -> (append (if (member 'grub.cfg base-inputs) `(("grub.cfg" ,grub.cfg)) '()) @@ -226,6 +227,16 @@ the image." (use-modules (gnu build vm) (guix build utils)) + (define* (do-install-grub #:key device target) + (and #$(prepare-install-grub + #:mount-point 'target + #:grub.cfg grub.cfg + #:config + (grub-configuration + (inherit (operating-system-bootloader os-configuration)) + (device drive))) + (register-grub.cfg-root target #$grub.cfg))) + (let ((inputs '#$(append (list qemu parted grub e2fsprogs) (map canonical-package @@ -257,9 +268,9 @@ the image." (file-system #$file-system-type) (bootable? #t) (initializer initialize))))) - (initialize-hard-disk "/dev/vda" + (initialize-hard-disk #$drive #:partitions partitions - #:grub.cfg #$grub.cfg) + #:install-boot do-install-grub) (reboot)))) #:system system #:make-disk-image? #t diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7279be0..4374a10 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2016 Alex Kost +;;; Copyright © 2016 Jookia <166291@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -124,7 +125,7 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) -(define (install-grub* grub.cfg device target) +(define* (install-grub* #:key grub.cfg config target) "This is a variant of 'install-grub' with error handling, lifted in %STORE-MONAD" (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) @@ -137,22 +138,24 @@ TARGET, and register them." ;; 'install-grub' completes (being a bit paranoid.) (make-symlink temp-gc-root grub.cfg) - (munless (false-if-exception (install-grub grub.cfg device target)) + (munless (eval (prepare-install-grub + #:grub.cfg grub.cfg + #:config config + #:mount-point target) + (current-module)) (delete-file temp-gc-root) - (leave (_ "failed to install GRUB on device '~a'~%") device)) + (leave (_ "failed to install GRUB on device '~a'~%") + (grub-configuration-device config))) ;; Register GRUB.CFG as a GC root so that its dependencies (background ;; image, font, etc.) are not reclaimed. (rename temp-gc-root gc-root)))) -(define* (install os-drv target - #:key (log-port (current-output-port)) - grub? grub.cfg device) +(define* (install os-drv target grub.cfg + #:key (log-port (current-output-port))) "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to directory TARGET. TARGET must be an absolute directory name since that's what -'guix-register' expects. - -When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." +'guix-register' expects." (define (maybe-copy to-copy) (with-monad %store-monad (if (string=? target "/") @@ -187,10 +190,7 @@ the ownership of '~a' may be incorrect!~%") ;; Create a bunch of additional files. (format log-port "populating '~a'...~%" target) - (populate os-dir target) - - (mwhen grub? - (install-grub* grub.cfg device target))))) + (populate os-dir target)))) ;;; @@ -461,14 +461,14 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (define* (perform-action action os #:key grub? dry-run? derivations-only? - use-substitutes? device target + use-substitutes? target image-size full-boot? (mappings '())) - "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. GRUB? specifies whether to install 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. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without building anything." @@ -520,16 +520,22 @@ building anything." (mbegin %store-monad (switch-to-system os) (mwhen grub? - (install-grub* (derivation->output-path grub.cfg) - device "/")))) + (install-grub* + #:grub.cfg (derivation->output-path grub.cfg) + #:config (operating-system-bootloader os) + #:target "/")))) ((init) (newline) (format #t (_ "initializing operating system under '~a'...~%") target) - (install sys (canonicalize-path target) - #:grub? grub? - #:grub.cfg (derivation->output-path grub.cfg) - #:device device)) + (mbegin %store-monad + (install sys (canonicalize-path target) + (derivation->output-path grub.cfg)) + (mwhen grub? + (install-grub* + #:grub.cfg (derivation->output-path grub.cfg) + #:config (operating-system-bootloader os) + #:target target)))) (else ;; All we had to do was to build SYS. (return (derivation->output-path sys)))))))) @@ -693,10 +699,7 @@ resulting from command-line parsing." (grub? (assoc-ref opts 'install-grub?)) (target (match args ((first second) second) - (_ #f))) - (device (and grub? - (grub-configuration-device - (operating-system-bootloader os))))) + (_ #f)))) (with-store store (set-build-options-from-command-line store opts) @@ -723,7 +726,7 @@ resulting from command-line parsing." (_ #f)) opts) #:grub? grub? - #:target target #:device device)))) + #:target target)))) #:system system)))) (define (process-command command args opts) -- 2.7.0