me/guix
Archived
1
0
Fork 0
Code Activity

bootloader: Adapt vm to new bootloader API.

Browse source 
* 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 2017-05-09 10:52:02 +02:00
parent b09a8da4a2
commit 9121ce553d
No known key found for this signature in database
GPG key ID: 8354763531769CA6
3 changed files with 44 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
gnu/build/install.scm
View file

@ -22,8 +22,7 @@
#:use-module (guix build store-copy) #:use-module (guix build store-copy)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (install-grub #:export (install-boot-config
install-grub-config
evaluate-populate-directive evaluate-populate-directive
populate-root-file-system populate-root-file-system
reset-timestamps reset-timestamps
@ -39,36 +38,17 @@
;;; ;;;
;;; Code: ;;; Code:
(define (install-grub grub.cfg device mount-point) (define (install-boot-config bootcfg bootcfg-location mount-point)
"Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note
MOUNT-POINT. 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."
Note that the caller must make sure that GRUB.CFG is registered as a GC root (let* ((target (string-append mount-point bootcfg-location))
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"))
(pivot (string-append target ".new"))) (pivot (string-append target ".new")))
(mkdir-p (dirname target)) (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. ;; work when /boot is on a separate partition. Do that atomically.
(copy-file grub.cfg pivot) (copy-file bootcfg pivot)
(rename-file pivot target))) (rename-file pivot target)))
(define (evaluate-populate-directive directive target) (define (evaluate-populate-directive directive target)

17
gnu/build/vm.scm
View file

@ -285,15 +285,18 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(unless register-closures? (unless register-closures?
(reset-timestamps target)))) (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." "On file system TARGET, register BOOTCFG as a GC root."
(let ((directory (string-append target "/var/guix/gcroots"))) (let ((directory (string-append target "/var/guix/gcroots")))
(mkdir-p directory) (mkdir-p directory)
(symlink bootcfg (string-append directory "/grub.cfg")))) (symlink bootcfg (string-append directory "/bootcfg"))))
(define* (initialize-hard-disk device (define* (initialize-hard-disk device
#:key #:key
grub.cfg bootloader-package
bootcfg
bootcfg-location
bootloader-installer
(partitions '())) (partitions '()))
"Initialize DEVICE as a disk containing all the <partition> objects listed "Initialize DEVICE as a disk containing all the <partition> objects listed
in PARTITIONS, and using BOOTCFG as its bootloader configuration file. 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") (display "mounting root partition...\n")
(mkdir-p target) (mkdir-p target)
(mount (partition-device root) target (partition-file-system root)) (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 BOOTCFG as a GC root.
(register-grub.cfg-root target grub.cfg) (register-bootcfg-root target bootcfg)
(umount target))) (umount target)))

36
gnu/system/vm.scm
View file

@ -46,6 +46,7 @@
#:select (%guile-static-stripped)) #:select (%guile-static-stripped))
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu bootloader)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu system pam) #:use-module (gnu system pam)
#:use-module (gnu system linux-initrd) #:use-module (gnu system linux-initrd)
@ -176,8 +177,9 @@ made available under the /xchg CIFS share."
(disk-image-format "qcow2") (disk-image-format "qcow2")
(file-system-type "ext4") (file-system-type "ext4")
file-system-label file-system-label
os-derivation os-drv
grub-configuration bootcfg-drv
bootloader
(register-closures? #t) (register-closures? #t)
(inputs '()) (inputs '())
copy-inputs?) copy-inputs?)
@ -201,7 +203,7 @@ the image."
(guix build utils)) (guix build utils))
(let ((inputs (let ((inputs
'#$(append (list qemu parted grub e2fsprogs) '#$(append (list qemu parted e2fsprogs)
(map canonical-package (map canonical-package
(list sed grep coreutils findutils gawk)) (list sed grep coreutils findutils gawk))
(if register-closures? (list guix) '()))) (if register-closures? (list guix) '())))
@ -223,7 +225,7 @@ the image."
#:closures graphs #:closures graphs
#:copy-closures? #$copy-inputs? #:copy-closures? #$copy-inputs?
#:register-closures? #$register-closures? #:register-closures? #$register-closures?
#:system-directory #$os-derivation)) #:system-directory #$os-drv))
(partitions (list (partition (partitions (list (partition
(size #$(- disk-image-size (size #$(- disk-image-size
(* 10 (expt 2 20)))) (* 10 (expt 2 20))))
@ -233,7 +235,13 @@ the image."
(initializer initialize))))) (initializer initialize)))))
(initialize-hard-disk "/dev/vda" (initialize-hard-disk "/dev/vda"
#:partitions partitions #: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))))) (reboot)))))
#:system system #:system system
#:make-disk-image? #t #: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)) (mlet* %store-monad ((os-drv (operating-system-derivation os))
(bootcfg (operating-system-bootcfg os))) (bootcfg (operating-system-bootcfg os)))
(qemu-image #:name name (qemu-image #:name name
#:os-derivation os-drv #:os-drv os-drv
#:grub-configuration bootcfg #:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
#:disk-image-format "raw" #:disk-image-format "raw"
#:file-system-type file-system-type #:file-system-type file-system-type
@ -330,8 +340,10 @@ of the GNU system as described by OS."
(mlet* %store-monad (mlet* %store-monad
((os-drv (operating-system-derivation os)) ((os-drv (operating-system-derivation os))
(bootcfg (operating-system-bootcfg os))) (bootcfg (operating-system-bootcfg os)))
(qemu-image #:os-derivation os-drv (qemu-image #:os-drv os-drv
#:grub-configuration bootcfg #:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
#:file-system-type file-system-type #:file-system-type file-system-type
#:inputs `(("system" ,os-drv) #: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. ;; 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 ;; 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. ;; font, and the background image), but it's hard to filter that.
(qemu-image #:os-derivation os-drv (qemu-image #:os-drv os-drv
#:grub-configuration bootcfg #:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
#:inputs (if full-boot? #:inputs (if full-boot?
`(("bootcfg" ,bootcfg)) `(("bootcfg" ,bootcfg))