From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:39341) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d71rO-0005Ab-GU for guix-patches@gnu.org; Sat, 06 May 2017 11:43:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d71rL-0000F8-CL for guix-patches@gnu.org; Sat, 06 May 2017 11:43:06 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:60207) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d71rL-0000Ey-6o for guix-patches@gnu.org; Sat, 06 May 2017 11:43:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d71rL-0002cm-1H for guix-patches@gnu.org; Sat, 06 May 2017 11:43:03 -0400 Subject: bug#26339: [PATCH v3 2/9] bootloader: Add install procedures and use them. Resent-Message-ID: From: Mathieu Othacehe Date: Sat, 6 May 2017 17:41:47 +0200 Message-Id: <20170506154154.17836-3-m.othacehe@gmail.com> In-Reply-To: <20170506154154.17836-1-m.othacehe@gmail.com> References: <20170506154154.17836-1-m.othacehe@gmail.com> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26339@debbugs.gnu.org Cc: David Craven From: David Craven * gnu/system/bootloader.scm (dd, install-grub, install-syslinux): New procedures. * gnu/build/install.scm (install-boot-config): New procedure. (install-grub): Move to (gnu system bootloader). * gnu/build/vm.scm (register-bootcfg-root): Rename register-grub.cfg-root and adjust accordingly. (initialize-hard-disk): Takes a bootloader, 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. --- gnu/build/install.scm | 36 ++++++++--------------------------- gnu/build/vm.scm | 17 +++++++++++------ gnu/system/bootloader.scm | 48 ++++++++++++++++++++++++++++++++++++++++++++++- gnu/system/vm.scm | 37 ++++++++++++++++++++++++------------ 4 files changed, 91 insertions(+), 47 deletions(-) diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 5cb6055a0..9e30c0d23 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -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) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 1eb9a4c45..440596a40 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -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 + bootcfg + bootcfg-location + bootloader-installer (partitions '())) "Initialize DEVICE as a disk containing all the 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 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))) diff --git a/gnu/system/bootloader.scm b/gnu/system/bootloader.scm index ea067bf73..fddf038b8 100644 --- a/gnu/system/bootloader.scm +++ b/gnu/system/bootloader.scm @@ -38,7 +38,10 @@ extlinux-configuration grub-configuration grub-efi-configuration - syslinux-configuration)) + syslinux-configuration + + install-grub + install-syslinux)) ;;; Commentary: ;;; @@ -158,4 +161,47 @@ TIMEOUT ~a~%" (bootloader (@ (gnu packages bootloaders) syslinux)) (installer install-syslinux))) + + +;;; +;;; Bootloader install procedures. +;;; + +(define dd + #~(lambda (bs count if of) + (zero? (system* "dd" + (string-append "bs=" (number->string bs)) + (string-append "count=" (number->string count)) + (string-append "if=" if) + (string-append "of=" of))))) + +(define install-grub + #~(lambda (bootloader device mount-point) + ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. + (let ((grub (string-append bootloader "/sbin/grub-install")) + (install-dir (string-append mount-point "/boot"))) + ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or + ;; root partition. + (setenv "GRUB_ENABLE_CRYPTODISK" "y") + + (unless (zero? (system* grub "--no-floppy" + "--boot-directory" install-dir + device)) + (error "failed to install GRUB"))))) + +(define install-syslinux + #~(lambda (bootloader device mount-point) + (let ((extlinux (string-append bootloader "/sbin/extlinux")) + (install-dir (string-append mount-point "/boot/extlinux")) + (syslinux-dir (string-append bootloader "/share/syslinux"))) + (mkdir-p install-dir) + (for-each (lambda (file) + (copy-file file + (string-append install-dir "/" (basename file)))) + (find-files syslinux-dir "\\.c32$")) + + (unless (and (zero? (system* extlinux "--install" install-dir)) + (#$dd 440 1 (string-append syslinux-dir "/mbr.bin") device)) + (error "failed to install SYSLINUX"))))) + ;;; bootloader.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2c8b954c8..cc13abe2a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -46,10 +46,10 @@ #:select (%guile-static-stripped)) #:use-module (gnu packages admin) + #:use-module (gnu system bootloader) #:use-module (gnu system shadow) #:use-module (gnu system pam) #:use-module (gnu system linux-initrd) - #:use-module (gnu system grub) #:use-module (gnu system file-systems) #:use-module (gnu system) #:use-module (gnu services) @@ -176,8 +176,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-configuration (register-closures? #t) (inputs '()) copy-inputs?) @@ -201,7 +202,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 +224,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 +234,16 @@ the image." (initializer initialize))))) (initialize-hard-disk "/dev/vda" #:partitions partitions - #:grub.cfg #$grub-configuration) + #:bootloader + #$(bootloader-configuration-bootloader + bootloader-configuration) + #:bootcfg #$bootcfg.drv + #:bootcfg-location + #$(bootloader-configuration-file-name + bootloader-configuration) + #:bootloader-installer + #$(bootloader-configuration-installer + bootloader-configuration)) (reboot))))) #:system system #:make-disk-image? #t @@ -287,8 +297,9 @@ 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-configuration (operating-system-bootloader os) #:disk-image-size disk-image-size #:disk-image-format "raw" #:file-system-type file-system-type @@ -330,8 +341,9 @@ 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-configuration (operating-system-bootloader os) #:disk-image-size disk-image-size #:file-system-type file-system-type #:inputs `(("system" ,os-drv) @@ -429,8 +441,9 @@ 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-configuration (operating-system-bootloader os) #:disk-image-size disk-image-size #:inputs (if full-boot? `(("bootcfg" ,bootcfg)) -- 2.12.2