gnu: grub: Add support for building configuration files.

* gnu/packages/grub.scm (<menu-entry>): New record type.
  (grub-configuration-file): New procedure.
* gnu/system/vm.scm (qemu-image): Remove parameters 'linux',
  'linux-arguments', and 'initrd'.  Add 'grub-configuration' parameter.
  Honor them, and remove grub.cfg generation code accordingly.
  (example2): Use `grub-configuration-file', and adjust accordingly.
master
Ludovic Courtès 2013-09-07 17:23:23 +02:00
parent 2df74ac117
commit 0e2ddecd8e
2 changed files with 80 additions and 34 deletions

View File

@ -19,6 +19,9 @@
(define-module (gnu packages grub)
#:use-module (guix download)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module ((guix licenses) #:select (gpl3+))
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
@ -30,7 +33,11 @@
#:use-module (gnu packages qemu)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages cdrom)
#:use-module (srfi srfi-1))
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (menu-entry
menu-entry?
grub-configuration-file))
(define qemu-for-tests
;; Newer QEMU versions, such as 1.5.1, no longer support the 'shutdown'
@ -110,3 +117,56 @@ computer starts. It is responsible for loading and transferring control to
the operating system kernel software (such as the Hurd or the Linux). The
kernel, in turn, initializes the rest of the operating system (e.g., GNU).")
(license gpl3+)))
;;;
;;; Configuration.
;;;
(define-record-type* <menu-entry>
menu-entry make-menu-entry
menu-entry?
(label menu-entry-label)
(linux menu-entry-linux)
(linux-arguments menu-entry-linux-arguments
(default '()))
(initrd menu-entry-initrd))
(define* (grub-configuration-file store entries
#:key (default-entry 1) (timeout 5)
(system (%current-system)))
"Return the GRUB configuration file in STORE for ENTRIES, a list of
<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
(define prologue
(format #f "
set default=~a
set timeout=~a
search.file ~a~%"
default-entry timeout
(any (match-lambda
(($ <menu-entry> _ linux)
(let* ((drv (package-derivation store linux system))
(out (derivation-path->output-path drv)))
(string-append out "/bzImage"))))
entries)))
(define entry->text
(match-lambda
(($ <menu-entry> label linux arguments initrd)
(let ((linux-drv (package-derivation store linux system))
(initrd-drv (package-derivation store initrd system)))
;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
(format #f "menuentry ~s {
linux ~a/bzImage ~a
initrd ~a/initrd
}~%"
label
(derivation-path->output-path linux-drv)
(string-join arguments)
(derivation-path->output-path initrd-drv))))))
(add-text-to-store store "grub.cfg"
(string-append prologue
(string-concatenate
(map entry->text entries)))
'()))

View File

@ -180,15 +180,13 @@ made available under the /xchg CIFS share."
(name "qemu-image")
(system (%current-system))
(disk-image-size (* 100 (expt 2 20)))
(linux linux-libre)
(linux-arguments '())
(initrd qemu-initrd)
grub-configuration
(populate #f)
(inputs '())
(inputs-to-copy '()))
"Return a bootable, stand-alone QEMU image. The returned image is a full
disk image, with a GRUB installation whose default entry boots LINUX, with the
arguments LINUX-ARGUMENTS, and using INITRD as its initial RAM disk.
disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
configuration file.
INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
into the image being built.
@ -224,10 +222,7 @@ It can be used to provide additional files, such as /etc files."
"/sbin/grub-install"))
(umount (string-append (assoc-ref %build-inputs "util-linux")
"/bin/umount")) ; XXX: add to Guile
(initrd (string-append (assoc-ref %build-inputs "initrd")
"/initrd"))
(linux (string-append (assoc-ref %build-inputs "linux")
"/bzImage")))
(grub.cfg (assoc-ref %build-inputs "grub.cfg")))
(define (read-reference-graph port)
;; Return a list of store paths from the reference graph at PORT.
@ -280,8 +275,7 @@ It can be used to provide additional files, such as /etc files."
(mkdir "/fs")
(mount "/dev/vda1" "/fs" "ext3")
(mkdir-p "/fs/boot/grub")
(copy-file linux "/fs/boot/bzImage")
(copy-file initrd "/fs/boot/initrd")
(symlink grub.cfg "/fs/boot/grub/grub.cfg")
;; Populate the image's store.
(mkdir-p (string-append "/fs" ,%store-directory))
@ -289,7 +283,7 @@ It can be used to provide additional files, such as /etc files."
(copy-recursively thing
(string-append "/fs"
thing)))
(things-to-copy))
(cons grub.cfg (things-to-copy)))
;; Populate /dev.
(make-essential-device-nodes #:root "/fs")
@ -300,32 +294,17 @@ It can be used to provide additional files, such as /etc files."
(primitive-load populate)
(chdir "/")))
;; TODO: Move to a GRUB menu builder.
(call-with-output-file "/fs/boot/grub/grub.cfg"
(lambda (p)
(format p "
set default=1
set timeout=5
search.file /boot/bzImage
menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
linux /boot/bzImage ~a
initrd /boot/initrd
}"
,(string-join linux-arguments))))
(and (zero?
(system* grub "--no-floppy"
"--boot-directory" "/fs/boot"
"/dev/vda"))
(zero?
(system* umount "/fs"))
(zero? (system* umount "/fs"))
(reboot))))))))
#:system system
#:inputs `(("parted" ,parted)
("grub" ,grub)
("e2fsprogs" ,e2fsprogs)
("linux" ,linux-libre)
("initrd" ,initrd)
("grub.cfg" ,grub-configuration)
;; For shell scripts.
("sed" ,(car (assoc-ref %final-inputs "sed")))
@ -420,14 +399,21 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
;; Directly into mingetty.
(execl ,getty "mingetty"
"--noclear" "tty1")))
(list out))))
(list out)))
(entries (list (menu-entry
(label "Boot-to-Guile! (GNU System technology preview)")
(linux linux-libre)
(linux-arguments `("--root=/dev/vda1"
,(string-append "--load=" boot)))
(initrd gnu-system-initrd))))
(grub.cfg (grub-configuration-file store entries)))
(qemu-image store
#:grub-configuration grub.cfg
#:populate populate
#:initrd gnu-system-initrd
#:linux-arguments `("--root=/dev/vda1"
,(string-append "--load=" boot))
#:disk-image-size (* 400 (expt 2 20))
#:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre)
("initrd" ,gnu-system-initrd)
("coreutils" ,coreutils)
("bash" ,bash)
("guile" ,guile-2.0)