bootloader: Adapt vm to new bootloader API.
* gnu/build/install.scm (install-boot-config): New procedure. (install-grub): Move to (gnu bootloader grub). * gnu/build/vm.scm (register-bootcfg-root): Rename register-grub.cfg-root and adjust accordingly. (initialize-hard-disk): Takes a bootloader-package, bootcfg, bootcfg-location and bootloader-installer procedure. Adjust accordingly. * gnu/system/vm.scm (qemu-image): Adjust to initialize-hard-disk. (system-disk-image, system-qemu-image, system-qemu-image/shared-store): Adjust to qemu-image.
This commit is contained in:
Mathieu Othacehe
parent
b09a8da4a2
commit
9121ce553d
|
|
@ -22,8 +22,7 @@
|
|||
#:use-module (guix build store-copy)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (install-grub
|
||||
install-grub-config
|
||||
#:export (install-boot-config
|
||||
evaluate-populate-directive
|
||||
populate-root-file-system
|
||||
reset-timestamps
|
||||
|
|
@ -39,36 +38,17 @@
|
|||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define (install-grub grub.cfg device mount-point)
|
||||
"Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
|
||||
MOUNT-POINT.
|
||||
|
||||
Note that the caller must make sure that GRUB.CFG is registered as a GC root
|
||||
so that the fonts, background images, etc. referred to by GRUB.CFG are not
|
||||
GC'd."
|
||||
(install-grub-config grub.cfg mount-point)
|
||||
|
||||
;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or root
|
||||
;; partition.
|
||||
(setenv "GRUB_ENABLE_CRYPTODISK" "y")
|
||||
|
||||
(unless (zero? (system* "grub-install" "--no-floppy"
|
||||
"--boot-directory"
|
||||
(string-append mount-point "/boot")
|
||||
device))
|
||||
(error "failed to install GRUB")))
|
||||
|
||||
(define (install-grub-config grub.cfg mount-point)
|
||||
"Atomically copy GRUB.CFG into boot/grub/grub.cfg on the MOUNT-POINT. Note
|
||||
that the caller must make sure that GRUB.CFG is registered as a GC root so
|
||||
that the fonts, background images, etc. referred to by GRUB.CFG are not GC'd."
|
||||
(let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
|
||||
(define (install-boot-config bootcfg bootcfg-location mount-point)
|
||||
"Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note
|
||||
that the caller must make sure that BOOTCFG is registered as a GC root so
|
||||
that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
|
||||
(let* ((target (string-append mount-point bootcfg-location))
|
||||
(pivot (string-append target ".new")))
|
||||
(mkdir-p (dirname target))
|
||||
|
||||
;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
|
||||
;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
|
||||
;; work when /boot is on a separate partition. Do that atomically.
|
||||
(copy-file grub.cfg pivot)
|
||||
(copy-file bootcfg pivot)
|
||||
(rename-file pivot target)))
|
||||
|
||||
(define (evaluate-populate-directive directive target)
|
||||
|
|
|
|||
|
|
@ -285,15 +285,18 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
|
|||
(unless register-closures?
|
||||
(reset-timestamps target))))
|
||||
|
||||
(define (register-grub.cfg-root target bootcfg)
|
||||
(define (register-bootcfg-root target bootcfg)
|
||||
"On file system TARGET, register BOOTCFG as a GC root."
|
||||
(let ((directory (string-append target "/var/guix/gcroots")))
|
||||
(mkdir-p directory)
|
||||
(symlink bootcfg (string-append directory "/grub.cfg"))))
|
||||
(symlink bootcfg (string-append directory "/bootcfg"))))
|
||||
|
||||
(define* (initialize-hard-disk device
|
||||
#:key
|
||||
grub.cfg
|
||||
bootloader-package
|
||||
bootcfg
|
||||
bootcfg-location
|
||||
bootloader-installer
|
||||
(partitions '()))
|
||||
"Initialize DEVICE as a disk containing all the <partition> objects listed
|
||||
in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
|
||||
|
|
@ -311,10 +314,12 @@ 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)
|
||||
(install-boot-config bootcfg bootcfg-location target)
|
||||
(when bootloader-installer
|
||||
(bootloader-installer bootloader-package device target))
|
||||
|
||||
;; Register GRUB.CFG as a GC root.
|
||||
(register-grub.cfg-root target grub.cfg)
|
||||
;; Register BOOTCFG as a GC root.
|
||||
(register-bootcfg-root target bootcfg)
|
||||
|
||||
(umount target)))
|
||||
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@
|
|||
#:select (%guile-static-stripped))
|
||||
#:use-module (gnu packages admin)
|
||||
|
||||
#:use-module (gnu bootloader)
|
||||
#:use-module (gnu system shadow)
|
||||
#:use-module (gnu system pam)
|
||||
#:use-module (gnu system linux-initrd)
|
||||
|
|
@ -176,8 +177,9 @@ made available under the /xchg CIFS share."
|
|||
(disk-image-format "qcow2")
|
||||
(file-system-type "ext4")
|
||||
file-system-label
|
||||
os-derivation
|
||||
grub-configuration
|
||||
os-drv
|
||||
bootcfg-drv
|
||||
bootloader
|
||||
(register-closures? #t)
|
||||
(inputs '())
|
||||
copy-inputs?)
|
||||
|
|
@ -201,7 +203,7 @@ the image."
|
|||
(guix build utils))
|
||||
|
||||
(let ((inputs
|
||||
'#$(append (list qemu parted grub e2fsprogs)
|
||||
'#$(append (list qemu parted e2fsprogs)
|
||||
(map canonical-package
|
||||
(list sed grep coreutils findutils gawk))
|
||||
(if register-closures? (list guix) '())))
|
||||
|
|
@ -223,7 +225,7 @@ the image."
|
|||
#:closures graphs
|
||||
#:copy-closures? #$copy-inputs?
|
||||
#:register-closures? #$register-closures?
|
||||
#:system-directory #$os-derivation))
|
||||
#:system-directory #$os-drv))
|
||||
(partitions (list (partition
|
||||
(size #$(- disk-image-size
|
||||
(* 10 (expt 2 20))))
|
||||
|
|
@ -233,7 +235,13 @@ the image."
|
|||
(initializer initialize)))))
|
||||
(initialize-hard-disk "/dev/vda"
|
||||
#:partitions partitions
|
||||
#:grub.cfg #$grub-configuration)
|
||||
#:bootloader-package
|
||||
#$(bootloader-package bootloader)
|
||||
#:bootcfg #$bootcfg-drv
|
||||
#:bootcfg-location
|
||||
#$(bootloader-configuration-file bootloader)
|
||||
#:bootloader-installer
|
||||
#$(bootloader-installer bootloader))
|
||||
(reboot)))))
|
||||
#:system system
|
||||
#:make-disk-image? #t
|
||||
|
|
@ -287,8 +295,10 @@ to USB sticks meant to be read-only."
|
|||
(mlet* %store-monad ((os-drv (operating-system-derivation os))
|
||||
(bootcfg (operating-system-bootcfg os)))
|
||||
(qemu-image #:name name
|
||||
#:os-derivation os-drv
|
||||
#:grub-configuration bootcfg
|
||||
#:os-drv os-drv
|
||||
#:bootcfg-drv bootcfg
|
||||
#:bootloader (bootloader-configuration-bootloader
|
||||
(operating-system-bootloader os))
|
||||
#:disk-image-size disk-image-size
|
||||
#:disk-image-format "raw"
|
||||
#:file-system-type file-system-type
|
||||
|
|
@ -330,8 +340,10 @@ of the GNU system as described by OS."
|
|||
(mlet* %store-monad
|
||||
((os-drv (operating-system-derivation os))
|
||||
(bootcfg (operating-system-bootcfg os)))
|
||||
(qemu-image #:os-derivation os-drv
|
||||
#:grub-configuration bootcfg
|
||||
(qemu-image #:os-drv os-drv
|
||||
#:bootcfg-drv bootcfg
|
||||
#:bootloader (bootloader-configuration-bootloader
|
||||
(operating-system-bootloader os))
|
||||
#:disk-image-size disk-image-size
|
||||
#:file-system-type file-system-type
|
||||
#:inputs `(("system" ,os-drv)
|
||||
|
|
@ -429,8 +441,10 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc."
|
|||
;; BOOTCFG and all its dependencies, including the output of OS-DRV.
|
||||
;; This is more than needed (we only need the kernel, initrd, GRUB for its
|
||||
;; font, and the background image), but it's hard to filter that.
|
||||
(qemu-image #:os-derivation os-drv
|
||||
#:grub-configuration bootcfg
|
||||
(qemu-image #:os-drv os-drv
|
||||
#:bootcfg-drv bootcfg
|
||||
#:bootloader (bootloader-configuration-bootloader
|
||||
(operating-system-bootloader os))
|
||||
#:disk-image-size disk-image-size
|
||||
#:inputs (if full-boot?
|
||||
`(("bootcfg" ,bootcfg))
|
||||
|
|
|
|||
Loading…
Reference in New Issue