ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

bootloader: Add 'disk-image-installer'.

Browse source 
* gnu/bootloader.scm (<bootloader>)[disk-image-installer]: New field,
(bootloader-disk-image-installer): export it.
* gnu/bootloader/grub.scm (install-grub-disk-image): New procedure ...
(grub-bootloader): ... used as "disk-image-installer" here.
(grub-efi-bootloader): set "disk-image-installer" to #f.
* gnu/system/image.scm (root-partition?, find-root-partition): Move to
"Helpers" section.
(root-partition-index): New procedure.
(system-disk-image): Honor disk-image-installer, and
use it to install the bootloader directly on the disk-image, if supported.
This commit is contained in:
Mathieu Othacehe 2020-05-23 19:09:14 +02:00
parent 7c5c21fd46
commit 7feefb3b82
No known key found for this signature in database
GPG key ID: 8354763531769CA6
3 changed files with 70 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
gnu/bootloader.scm
View file

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
@ -42,6 +42,7 @@ (define-module (gnu bootloader)
bootloader-name
bootloader-package
bootloader-installer
bootloader-disk-image-installer
bootloader-configuration-file
bootloader-configuration-file-generator
@ -125,6 +126,8 @@ (define-record-type* <bootloader>
(name bootloader-name)
(package bootloader-package)
(installer bootloader-installer)
(disk-image-installer bootloader-disk-image-installer
(default #f))
(configuration-file bootloader-configuration-file)
(configuration-file-generator bootloader-configuration-file-generator))

45
gnu/bootloader/grub.scm
View file

@ -2,7 +2,7 @@
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
@ -436,6 +436,47 @@ (define install-grub
"--boot-directory" install-dir
device))))
(define install-grub-disk-image
#~(lambda (bootloader root-index image)
;; Install GRUB on the given IMAGE. The root partition index is
;; ROOT-INDEX.
(let ((grub-mkimage
(string-append bootloader "/bin/grub-mkimage"))
(modules '("biosdisk" "part_msdos" "fat" "ext2"))
(grub-bios-setup
(string-append bootloader "/sbin/grub-bios-setup"))
(root-device (format #f "hd0,msdos~a" root-index))
(boot-img (string-append bootloader "/lib/grub/i386-pc/boot.img"))
(device-map "device.map"))
;; Create a minimal, standalone GRUB image that will be written
;; directly in the MBR-GAP (space between the end of the MBR and the
;; first partition).
(apply invoke grub-mkimage
"-O" "i386-pc"
"-o" "core.img"
"-p" (format #f "(~a)/boot/grub" root-device)
modules)
;; Create a device mapping file.
(call-with-output-file device-map
(lambda (port)
(format port "(hd0) ~a~%" image)))
;; Copy the default boot.img, that will be written on the MBR sector
;; by GRUB-BIOS-SETUP.
(copy-file boot-img "boot.img")
;; Install both the "boot.img" and the "core.img" files on the given
;; IMAGE. On boot, the MBR sector will execute the minimal GRUB
;; written in the MBR-GAP. GRUB configuration and missing modules will
;; be read from ROOT-DEVICE.
(invoke grub-bios-setup
"-m" device-map
"-r" root-device
"-d" "."
image))))
(define install-grub-efi
#~(lambda (bootloader efi-dir mount-point)
;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
@ -465,6 +506,7 @@ (define grub-bootloader
(name 'grub)
(package grub)
(installer install-grub)
(disk-image-installer install-grub-disk-image)
(configuration-file "/boot/grub/grub.cfg")
(configuration-file-generator grub-configuration-file)))
@ -480,6 +522,7 @@ (define* grub-efi-bootloader
(bootloader
(inherit grub-bootloader)
(installer install-grub-efi)
(disk-image-installer #f)
(name 'grub-efi)
(package grub-efi)))

32
gnu/system/image.scm
View file

@ -147,6 +147,18 @@ (define-syntax-rule (with-imported-modules* gexp* ...)
(guix build utils))
gexp* ...))))
(define (root-partition? partition)
"Return true if PARTITION is the root partition, false otherwise."
(member 'boot (partition-flags partition)))
(define (find-root-partition image)
"Return the root partition of the given IMAGE."
(srfi-1:find root-partition? (image-partitions image)))
(define (root-partition-index image)
"Return the index of the root partition of the given IMAGE."
(1+ (srfi-1:list-index root-partition? (image-partitions image))))
;;
;; Disk image.
@ -276,9 +288,17 @@ (define (partition->config partition)
(let* ((substitutable? (image-substitutable? image))
(builder
(with-imported-modules*
(let ((inputs '#+(list genimage coreutils findutils)))
(let ((inputs '#+(list genimage coreutils findutils))
(bootloader-installer
#+(bootloader-disk-image-installer bootloader)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(genimage #$(image->genimage-cfg image) #$output))))
(genimage #$(image->genimage-cfg image) #$output)
;; Install the bootloader directly on the disk-image.
(when bootloader-installer
(bootloader-installer
#+(bootloader-package bootloader)
#$(root-partition-index image)
(string-append #$output "/" #$genimage-name))))))
(image-dir (computed-file "image-dir" builder)))
(computed-file name
#~(symlink
@ -371,14 +391,6 @@ (define root-uuid
;; Image creation.
;;
(define (root-partition? partition)
"Return true if PARTITION is the root partition, false otherwise."
(member 'boot (partition-flags partition)))
(define (find-root-partition image)
"Return the root partition of the given IMAGE."
(srfi-1:find root-partition? (image-partitions image)))
(define (image->root-file-system image)
"Return the IMAGE root partition file-system type."
(let ((format (image-format image)))