* [RFC 2/4] grub: Add and use prepare-install-grub function.
@ 2016-02-21 7:38 Jookia
0 siblings, 0 replies; only message in thread
From: Jookia @ 2016-02-21 7:38 UTC (permalink / raw)
To: guix-devel
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain, Size: 14001 bytes --]
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 <grub-configuration> 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 <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
+;;; 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 <partition> 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 <ludo@gnu.org>
+;;; 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
+<grub-configuration> 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 <ludo@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; 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))))
\f
;;;
@@ -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
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2016-03-03 2:51 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2016-02-21 7:38 [RFC 2/4] grub: Add and use prepare-install-grub function Jookia
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.