;;; 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>
+;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
;;;
;;; This file is part of GNU Guix.
;;;
;;;
;;; Code:
-(define* (normalize-file file mount-point btrfs-subvolume-file-name)
- "Strip MOUNT-POINT and prepend BTRFS-SUBVOLUME-FILE-NAME to FILE, a
+(define* (normalize-file file mount-point store-directory-prefix)
+ "Strip MOUNT-POINT and prepend STORE-DIRECTORY-PREFIX, if any, to FILE, a
G-expression or other lowerable object denoting a file name."
(define (strip-mount-point mount-point file)
file)))
file))
- (define (prepend-btrfs-subvolume-file-name btrfs-subvolume-file-name file)
- (if btrfs-subvolume-file-name
- #~(string-append #$btrfs-subvolume-file-name #$file)
+ (define (prepend-store-directory-prefix store-directory-prefix file)
+ (if store-directory-prefix
+ #~(string-append #$store-directory-prefix #$file)
file))
- (prepend-btrfs-subvolume-file-name btrfs-subvolume-file-name
- (strip-mount-point mount-point file)))
+ (prepend-store-directory-prefix store-directory-prefix
+ (strip-mount-point mount-point file)))
(_ #f)))))
(define* (eye-candy config store-device store-mount-point
- #:key btrfs-store-subvolume-file-name system port)
+ #:key store-directory-prefix port)
"Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
concerned with graphics mode, background images, colors, and all that.
STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POINT is
its mount point; these are used to determine where the background image and
-fonts must be searched for. SYSTEM must be the target system string---e.g.,
-\"x86_64-linux\". BTRFS-STORE-SUBVOLUME-FILE-NAME is the file name of the
-Btrfs subvolume, to be prepended to any store path, if any."
- (define setup-gfxterm-body
- (let ((gfxmode
- (or (and-let* ((theme (bootloader-configuration-theme config))
- (gfxmode (grub-theme-gfxmode theme)))
- (string-join gfxmode ";"))
- "auto")))
-
- ;; Intel and EFI systems need to be switched into graphics mode, whereas
- ;; most other modern architectures have no other mode and therefore
- ;; don't need to be switched.
-
- ;; XXX: Do we really need to restrict to x86 systems? We could imitate
- ;; what the GRUB default configuration does and decide based on whether
- ;; a user provided 'gfxterm' in the terminal-outputs field of their
- ;; bootloader-configuration record.
- (if (string-match "^(x86_64|i[3-6]86)-" system)
- (format #f "
- set gfxmode=~a
- insmod all_video
- insmod gfxterm~%" gfxmode)
- "")))
-
+fonts must be searched for. STORE-DIRECTORY-PREFIX is a directory prefix to
+prepend to any store file name."
(define (setup-gfxterm config font-file)
(if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
- #~(format #f "if loadfont ~a; then
- setup_gfxterm
-fi~%" #+font-file)
+ #~(format #f "
+if loadfont ~a; then
+ set gfxmode=~a
+ insmod all_video
+ insmod gfxterm
+fi~%"
+ #+font-file
+ #$(string-join
+ (grub-theme-gfxmode (bootloader-theme config))
+ ";"))
""))
(define (theme-colors type)
(define font-file
(normalize-file (file-append grub "/share/grub/unicode.pf2")
store-mount-point
- btrfs-store-subvolume-file-name))
+ store-directory-prefix))
(define image
(normalize-file (grub-background-image config)
store-mount-point
- btrfs-store-subvolume-file-name))
+ store-directory-prefix))
(and image
#~(format #$port "
-function setup_gfxterm {~a}
-
# Set 'root' to the partition that contains /gnu/store.
~a
set menu_color_normal=cyan/blue
set menu_color_highlight=white/blue
fi~%"
- #$setup-gfxterm-body
#$(grub-root-search store-device font-file)
#$(setup-gfxterm config font-file)
#$(grub-setup-io config)
#:key
(system (%current-system))
(old-entries '())
- btrfs-subvolume-file-name)
+ store-directory-prefix)
"Return the GRUB configuration file corresponding to CONFIG, a
<bootloader-configuration> object, and where the store is available at
-STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list
-of menu entries corresponding to old generations of the system.
-BTRFS-SUBVOLUME-FILE-NAME may be used to specify on which subvolume a
-Btrfs root file system resides."
+STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu
+entries corresponding to old generations of the system.
+STORE-DIRECTORY-PREFIX may be used to specify a store prefix, as is required
+when booting a root file system on a Btrfs subvolume."
(define all-entries
(append entries (bootloader-configuration-menu-entries config)))
(define (menu-entry->gexp entry)
- (let* ((device (menu-entry-device entry))
- (device-mount-point (menu-entry-device-mount-point entry))
- (label (menu-entry-label entry))
- (arguments (menu-entry-linux-arguments entry))
- (kernel (normalize-file (menu-entry-linux entry)
- device-mount-point
- btrfs-subvolume-file-name))
- (initrd (normalize-file (menu-entry-initrd entry)
- device-mount-point
- btrfs-subvolume-file-name)))
- ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
- ;; Use the right file names for KERNEL and INITRD in case
- ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
- ;; separate partition.
-
- ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the kernel and
- ;; initrd paths, to allow booting from a Btrfs subvolume.
- #~(format port "menuentry ~s {
+ (let ((label (menu-entry-label entry))
+ (linux (menu-entry-linux entry))
+ (device (menu-entry-device entry))
+ (device-mount-point (menu-entry-device-mount-point entry)))
+ (if linux
+ (let ((arguments (menu-entry-linux-arguments entry))
+ (linux (normalize-file linux
+ device-mount-point
+ store-directory-prefix))
+ (initrd (normalize-file (menu-entry-initrd entry)
+ device-mount-point
+ store-directory-prefix)))
+ ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
+ ;; Use the right file names for LINUX and INITRD in case
+ ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
+ ;; separate partition.
+
+ ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
+ ;; initrd paths, to allow booting from a Btrfs subvolume.
+ #~(format port "menuentry ~s {
~a
linux ~a ~a
initrd ~a
}~%"
- #$label
- #$(grub-root-search device kernel)
- #$kernel (string-join (list #$@arguments))
- #$initrd)))
- (define sugar
- (eye-candy config
- (menu-entry-device (first all-entries))
- (menu-entry-device-mount-point (first all-entries))
- #:btrfs-store-subvolume-file-name btrfs-subvolume-file-name
- #:system system
- #:port #~port))
+ #$label
+ #$(grub-root-search device linux)
+ #$linux (string-join (list #$@arguments))
+ #$initrd))
+ (let ((kernel (menu-entry-multiboot-kernel entry))
+ (arguments (menu-entry-multiboot-arguments entry))
+ (modules (menu-entry-multiboot-modules entry))
+ (root-index 1)) ; XXX EFI will need root-index 2
+ #~(format port "
+menuentry ~s {
+ multiboot ~a root=device:hd0s~a~a~a
+}~%"
+ #$label
+ #$kernel
+ #$root-index (string-join (list #$@arguments) " " 'prefix)
+ (string-join (map string-join '#$modules)
+ "\n module " 'prefix))))))
+
+ (define (sugar)
+ (let* ((entry (first all-entries))
+ (device (menu-entry-device entry))
+ (mount-point (menu-entry-device-mount-point entry)))
+ (eye-candy config
+ device
+ mount-point
+ #:store-directory-prefix store-directory-prefix
+ #:port #~port)))
(define keyboard-layout-config
(let* ((layout (bootloader-configuration-keyboard-layout config))
(keymap* (and layout
(keyboard-layout-file layout #:grub grub)))
(keymap (and keymap*
- (if btrfs-subvolume-file-name
- #~(string-append #$btrfs-subvolume-file-name
+ (if store-directory-prefix
+ #~(string-append #$store-directory-prefix
#$keymap*)
keymap*))))
#~(when #$keymap
"# This file was generated from your Guix configuration. Any changes
# will be lost upon reconfiguration.
")
- #$sugar
+ #$(sugar)
#$keyboard-layout-config
(format port "
set default=~a
(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")
-
- ;; Hide potentially confusing messages from the user, such as
- ;; "Installing for i386-pc platform."
- (invoke/quiet grub "--no-floppy" "--target=i386-pc"
- "--boot-directory" install-dir
- device))))
+ ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. If DEVICE
+ ;; is #f, then we populate the disk-image rooted at MOUNT-POINT.
+ (if device
+ (begin
+ ;; Tell 'grub-install' that there might be a LUKS-encrypted
+ ;; /boot or root partition.
+ (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+
+ ;; Hide potentially confusing messages from the user, such as
+ ;; "Installing for i386-pc platform."
+ (invoke/quiet grub "--no-floppy" "--target=i386-pc"
+ "--boot-directory" install-dir
+ device))
+ ;; When creating a disk-image, only install GRUB modules.
+ (copy-recursively (string-append bootloader "/lib/")
+ install-dir)))))
(define install-grub-disk-image
#~(lambda (bootloader root-index image)
(configuration-file "/boot/grub/grub.cfg")
(configuration-file-generator grub-configuration-file)))
-(define grub-minimal-bootloader
+(define* grub-minimal-bootloader
(bootloader
- (name 'grub)
- (package grub-minimal)
- (installer install-grub)
- (configuration-file "/boot/grub/grub.cfg")
- (configuration-file-generator grub-configuration-file)))
+ (inherit grub-bootloader)
+ (package grub-minimal)))
(define* grub-efi-bootloader
(bootloader
HCoop / jackhill / guix / guix.git / blobdiff