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.
This commit is contained in:
Ludovic Courtès
parent
2df74ac117
commit
0e2ddecd8e
@ -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)))
|
||||
'()))
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user