@@ -42592,19 +42592,20 @@ Bootloader Configuration
is provided, some bootloaders might use a default theme, that's true
for GRUB.
-@item @code{terminal-outputs} (default: @code{'(gfxterm)})
+@item @code{terminal-outputs} (default: @var{#f})
The output terminals used for the bootloader boot menu, as a list of
-symbols. GRUB accepts the values: @code{console}, @code{serial},
-@code{serial_@{0-3@}}, @code{gfxterm}, @code{vga_text},
-@code{mda_text}, @code{morse}, and @code{pkmodem}. This field
-corresponds to the GRUB variable @code{GRUB_TERMINAL_OUTPUT} (@pxref{Simple
-configuration,,, grub,GNU GRUB manual}).
-
-@item @code{terminal-inputs} (default: @code{'()})
+symbols. When @var{#f}, the default is used. For GRUB this is @code{gfxterm}.
+GRUB accepts the values: @code{console}, @code{serial}, @code{serial_@{0-3@}},
+@code{gfxterm}, @code{vga_text}, @code{mda_text}, @code{morse}, and
+@code{pkmodem}. This field corresponds to the GRUB variable
+@code{GRUB_TERMINAL_OUTPUT}
+(@pxref{Simple configuration,,, grub,GNU GRUB manual}).
+
+@item @code{terminal-inputs} (default: @code{#f})
The input terminals used for the bootloader boot menu, as a list of
-symbols. For GRUB, the default is the native platform terminal as
-determined at run-time. GRUB accepts the values: @code{console},
-@code{serial}, @code{serial_@{0-3@}}, @code{at_keyboard}, and
+symbols, or @code{#f} to use the default. For GRUB, this is the native
+platform terminal as determined at run-time. GRUB accepts the values:
+@code{console}, @code{serial}, @code{serial_@{0-3@}}, @code{at_keyboard}, and
@code{usb_keyboard}. This field corresponds to the GRUB variable
@code{GRUB_TERMINAL_INPUT} (@pxref{Simple configuration,,, grub,GNU GRUB
manual}).
@@ -495,7 +495,7 @@ (define-record-type* <bootloader-configuration>
bootloader-configuration?
(bootloader
bootloader-configuration-bootloader) ;<bootloader>
- (targets %bootloader-configuration-targets
+ (targets bootloader-configuration-targets
(default #f)) ;list of strings
(menu-entries bootloader-configuration-menu-entries
(default '())) ;list of <menu-entry>
@@ -512,9 +512,9 @@ (define-record-type* <bootloader-configuration>
(theme bootloader-configuration-theme
(default #f)) ;bootloader-specific theme
(terminal-outputs bootloader-configuration-terminal-outputs
- (default '(gfxterm))) ;list of symbols
+ (default #f)) ;list of symbols | #f (default outs)
(terminal-inputs bootloader-configuration-terminal-inputs
- (default '())) ;list of symbols
+ (default #f)) ;list of symbols | #f (default ins)
(serial-unit bootloader-configuration-serial-unit
(default #f)) ;integer | #f
(serial-speed bootloader-configuration-serial-speed
@@ -524,14 +524,6 @@ (define-record-type* <bootloader-configuration>
(extra-initrd bootloader-configuration-extra-initrd
(default #f))) ;string | #f
-
-(define (bootloader-configuration-targets config)
- (or (%bootloader-configuration-targets config)
- ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
- ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
- ;; hence the default value of '(#f) rather than '().
- (list #f)))
-
;;;
;;; Bootloader installation paths.
@@ -10,6 +10,8 @@
;;; Copyright © 2022 Karl Hallsby <karl@hallsby.com>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
+;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,24 +29,26 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu bootloader grub)
- #:use-module (guix build union)
- #:use-module (guix records)
- #:use-module (guix store)
- #:use-module (guix utils)
- #:use-module (guix gexp)
#:use-module (gnu artwork)
#:use-module (gnu bootloader)
- #:use-module (gnu system uuid)
- #:use-module (gnu system file-systems)
- #:use-module (gnu system keyboard)
- #:use-module (gnu system locale)
#:use-module (gnu packages bootloaders)
#:autoload (gnu packages gtk) (guile-cairo guile-rsvg)
#:autoload (gnu packages xorg) (xkeyboard-config)
+ #:use-module (gnu system boot)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system keyboard)
+ #:use-module (gnu system locale)
+ #:use-module (gnu system uuid)
+ #:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:use-module (guix gexp)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (guix utils)
#:use-module (ice-9 match)
- #:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
#:export (grub-theme
grub-theme?
grub-theme-image
@@ -53,54 +57,93 @@ (define-module (gnu bootloader grub)
grub-theme-color-highlight
grub-theme-gfxmode
- install-grub-efi-removable
- make-grub-efi-netboot-installer
-
+ grub.dir ; for (gnu build image) iso9660 images
grub-bootloader
+ grub-minimal-bootloader
grub-efi-bootloader
+ ;; deprecated
grub-efi-removable-bootloader
grub-efi32-bootloader
grub-efi-netboot-bootloader
- grub-efi-netboot-removable-bootloader
- grub-mkrescue-bootloader
- grub-minimal-bootloader
-
- grub-configuration))
+ grub-efi-netboot-removable-bootloader))
-;;; Commentary:
+
;;;
-;;; Configuration of GNU GRUB.
+;;; General utils.
;;;
-;;; Code:
-
-(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)
- (if mount-point
- (if (string=? mount-point "/")
- file
- #~(let ((file #$file))
- (if (string-prefix? #$mount-point file)
- (substring #$file #$(string-length mount-point))
- file)))
- file))
-
- (define (prepend-store-directory-prefix store-directory-prefix file)
- (if store-directory-prefix
- #~(string-append #$store-directory-prefix #$file)
- file))
-
- (prepend-store-directory-prefix store-directory-prefix
- (strip-mount-point mount-point file)))
+(define (sanitize str)
+ "In-G-exp procedure to sanitize a value for use in a GRUB script."
+ #~(let ((glycerin (lambda (l r)
+ (if (pair? l) (append l r) (cons l r))))
+ ;; In lieu of escaped-string from (guix read-print).
+ (isopropyl (lambda (c)
+ (case c ((#\\ #\$ #\") '(#\\ ,c)) (else c)))))
+ (use-modules (srfi srfi-1))
+ (list->string (fold-right glycerin '()
+ (map isopropyl (string->list #$str))))))
+
+(define* (search/target type targets var #:optional (port #f))
+ "Returns a gexp of a GRUB search command for target TYPE, storing the
+result in VAR. Optionally outputs to the gexp PORT instead of returning
+a string."
+ (define (form name val)
+ #~(format #$port "search.~a \"~a\" ~a~%" #$name #$val #$var))
+ (with-targets targets
+ ((type => (path :devpath) (device :device) (fs :fs)
+ (label :label) (uuid :uuid))
+ (cond ((member fs '("tftp" "nfs")) #~(format #$port "set ~a=tftp~%" #$var))
+ (uuid (form "fs_uuid" (uuid->string uuid)))
+ (label (form "fs_label" label))
+ (else (form "file" (sanitize path)))))))
+
+(define* (search/menu-entry device file var #:optional (port #f))
+ "Return the GRUB 'search' command to look for DEVICE, which contains
+FILE, a gexp. The result is a gexp that can be inserted in the
+grub.cfg-generation code to set the variable VAR. This procedure is
+able to handle DEVICEs unmounted at evaltime."
+ (match device
+ ;; Preferably refer to DEVICE by its UUID or label. This is more
+ ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
+ ((? uuid? idfk) ; calling idfk uuid here errors for some reason
+ #~(format #$port "search.fs_uuid ~a ~a~%" #$(uuid->string device) #$var))
+ ((? file-system-label? label)
+ #~(format #$port "search.fs_label \"~a\" ~a~%"
+ #$(sanitize (file-system-label->string label)) #$var))
+ ((? (lambda (device)
+ (and (string? device) (string-contains device ":/"))) nfs-uri)
+ ;; If the device is an NFS share, then we assume that the expected
+ ;; file on that device (e.g. the GRUB background image or the kernel)
+ ;; has to be loaded over the network. Otherwise we would need an
+ ;; additional device information for some local disk to look for that
+ ;; file, which we do not have.
+ ;;
+ ;; TFTP is preferred to HTTP because it is used more widely and
+ ;; specified in standards more widely--especially BOOTP/DHCPv4
+ ;; defines a TFTP server for DHCP option 66, but not HTTP.
+ ;;
+ ;; Note: DHCPv6 specifies option 59 to contain a boot-file-url,
+ ;; which can contain a HTTP or TFTP URL.
+ ;;
+ ;; Note: It is assumed that the file paths are of a similar
+ ;; setup on both the TFTP server and the NFS server (it is
+ ;; not possible to search for files on TFTP).
+ ;;
+ ;; TODO: Allow HTTP.
+ #~(format #$port "set ~a=tftp~%" #$var))
+ ((or #f (? string?))
+ #~(format #$port "search.file \"~a\" ~a~%" #$(sanitize file) #$var))))
+
+(define (when-list . xs) (filter identity xs))
+
+;;;
+;;; Theming.
+;;;
(define-record-type* <grub-theme>
;; Default theme contributed by Felipe López.
- grub-theme make-grub-theme
- grub-theme?
+ grub-theme make-grub-theme grub-theme?
(image grub-theme-image
(default (file-append %artwork-repository
"/grub/GuixSD-fully-black-4-3.svg")))
@@ -113,800 +156,495 @@ (define-record-type* <grub-theme>
(gfxmode grub-theme-gfxmode
(default '("auto")))) ;list of string
+(define (grub-theme-png theme)
+ "Return the GRUB background image defined in THEME. If the suffix of
+the image file is \".svg\", then it is converted into a PNG file with
+the resolution provided in CONFIG. Returns #f if no file is provided."
+ (match-record theme <grub-theme> (image resolution)
+ (match resolution
+ (((? number? width) . (? number? height))
+ (computed-file "grub-image.png"
+ (with-imported-modules '((gnu build svg) (guix build utils))
+ (with-extensions (list guile-rsvg guile-cairo)
+ #~(begin (use-modules (gnu build svg) (guix build utils))
+ (if (png-file? #$image) (copy-file #$image #$output)
+ (svg->png #$image #$output
+ #:width #$width
+ #:height #$height)))))))
+ (_ image))))
+
+
+;;;
+;;; Core config.
+;;; GRUB architecture works by having a bootstage load up a core.img,
+;;; which then sets the root and prefix variables, allowing grub to load
+;;; its main config and modules, and then enter normal mode. On i386-pc
+;;; systems a boot.img is flashed which loads the core.img from the MBR
+;;; gap, but on efi systems the core.img is just a PE executable, able
+;;; to be booted directly. We set up a minimal core.img capable of
+;;; finding the user-configured 'install target to load its config from
+;;; there.
+;;;
+
+(define (core.cfg targets store-crypto-devices)
+ "Returns a filelike object for a core configuration file good enough to
+decrypt STORE-CRYPTO-DEVICES and boot to normal."
+ (define (crypto-device->cryptomount dev)
+ (and (uuid? dev) ; ignore non-uuids - warning given by os
+ #~(format port "cryptomount -u ~a~%"
+ ;; cryptomount only accepts UUID without the hyphen.
+ #$(string-delete #\- (uuid->string dev)))))
+
+ (and=>
+ (with-targets targets
+ (('install => (path :devpath))
+ #~(call-with-output-file #$output
+ (lambda (port)
+ #$@(filter ->bool
+ (map crypto-device->cryptomount store-crypto-devices))
+ #$(search/target 'install targets "root" #~port)
+ (format port "set \"prefix=($root)~a\"~%" #$(sanitize path))))))
+ (cut computed-file "core.cfg" <>)))
+
+;; XXX: Would a FORMAT symbol instead of string be better?
+(define (core.cfg->core.img grub format bootloader-config
+ store-crypto-devices cfg fs)
+ "Return a G-exp for a GRUB core image configured with CFG, built for
+FORMAT and the file system FS."
+ (let* ((tftp? (or (string=? fs "tftp") (string=? fs "nfs")))
+ (bios? (string-prefix? format "pc"))
+ (efi? (string=? format "efi"))
+ (32? (bootloader-configuration-32bit? bootloader-config))
+ (grub-format
+ (cond ((string-prefix? "pc" format) "i386")
+ ((target-x86-32?) "i386")
+ ((target-x86-64?) (if 32? "i386" "x86_64"))
+ ((target-arm32?) "arm")
+ ((target-aarch64?) (if 32? "arm" "arm64"))
+ ((target-powerpc?) "powerpc")
+ ((target-riscv64?) "riscv64")
+ (else (raise (formatted-message
+ (G_ "unrecognized target arch '~a'!")
+ (or (%current-target-system)
+ (%current-system)))))))
+ (format (string-append grub-format "-" format
+ (if (and bios? tftp?) "-pxe" ""))))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils) (ice-9 textual-ports)
+ (srfi srfi-1))
+ (apply invoke #$(file-append grub "/bin/grub-mkimage")
+ "--output" #$output
+ "--config" #$cfg
+ "--prefix" "none" ; we override this in cfg
+ ;; bios pxe uses pxeboot instead of diskboot - diff format
+ "--format" #$format
+ "--compression" "auto"
+ ;; modules
+ "minicmd"
+ (append
+ ;; disk drivers
+ '#$(if bios? '("biosdisk") '())
+ ;; partmaps
+ ;; TODO: detect which to use.
+ '#$(if tftp? '() '("part_msdos" "part_gpt"))
+ ;; file systems
+ '#$(cond ((member fs '("ext2" "ext3" "ext4")) '("ext2"))
+ ((member fs '("vfat" "fat32")) '("fat"))
+ ((and tftp? efi?) '("efinet"))
+ ((and tftp? bios?) '("pxe"))
+ (else (list fs)))
+ ;; store crypto devs
+ '#$(if (any uuid? store-crypto-devices)
+ '("luks" "luks2" "cryptomount") '())
+ ;; search module that cfg uses
+ (call-with-input-file #$cfg
+ (lambda (port)
+ (let* ((str (get-string-all port))
+ (use (lambda (s) (string-contains str s))))
+ (cond ((use "search.fs_uuid") '("search_fs_uuid"))
+ ((use "search.fs_label") '("search_label"))
+ ((use "search.file") '("search_fs_file"))
+ (else '())))))))))))
+
+;; XXX: Do we need LVM support here?
+(define* (core.img grub format #:key bootloader-config store-crypto-devices
+ #:allow-other-keys)
+ "The core image for GRUB, built for FORMAT."
+ (let* ((targets (bootloader-configuration-targets bootloader-config))
+ (cfg (core.cfg targets store-crypto-devices)))
+ (and=>
+ (and cfg
+ (with-targets targets
+ (('install => (fs :fs))
+ (core.cfg->core.img grub format bootloader-config
+ store-crypto-devices cfg fs))))
+ (cut computed-file "core.img" <>
+ #:options '(#:local-build? #t #:substitutable? #f)))))
+
;;;
-;;; Background image & themes.
+;;; Main config.
+;;; This is what does the heavy lifting after core.img finds it.
;;;
-(define (bootloader-theme config)
- "Return user defined theme in CONFIG if defined or a default theme
-otherwise."
- (or (bootloader-configuration-theme config) (grub-theme)))
-
-(define* (image->png image #:key width height)
- "Build a PNG of HEIGHT x WIDTH from IMAGE if its file suffix is \".svg\".
-Otherwise the picture in IMAGE is just copied."
- (computed-file "grub-image.png"
- (with-imported-modules '((gnu build svg))
- (with-extensions (list guile-rsvg guile-cairo)
- #~(if (string-suffix? ".svg" #+image)
- (begin
- (use-modules (gnu build svg))
- (svg->png #+image #$output
- #:width #$width
- #:height #$height))
- (copy-file #+image #$output))))))
-
-(define* (grub-background-image config)
- "Return the GRUB background image defined in CONFIG or #f if none was found.
-If the suffix of the image file is \".svg\", then it is converted into a PNG
-file with the resolution provided in CONFIG."
- (let* ((theme (bootloader-theme config))
- (image (grub-theme-image theme)))
- (and image
- (match (grub-theme-resolution theme)
- (((? number? width) . (? number? height))
- (image->png image #:width width #:height height))
- (_ #f)))))
-
-(define (grub-locale-directory grub)
- "Generate a directory with the locales from GRUB."
- (define builder
- #~(begin
- (use-modules (ice-9 ftw))
- (let ((locale (string-append #$grub "/share/locale"))
- (out #$output))
- (mkdir out)
- (chdir out)
- (for-each (lambda (lang)
- (let ((file (string-append locale "/" lang
- "/LC_MESSAGES/grub.mo"))
- (dest (string-append lang ".mo")))
- (when (file-exists? file)
- (copy-file file dest))))
- (scandir locale)))))
- (computed-file "grub-locales" builder))
-
-(define* (eye-candy config store-device store-mount-point
- #: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. STORE-DIRECTORY-PREFIX is a directory prefix to
-prepend to any store file name."
- (define (setup-gfxterm config)
- (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
- #~(format #f "
+;; TODO: use define-configuration.
+(define (menu-entry->gexp entry extra-initrd port)
+ (match-menu-entry
+ entry
+ (label device linux linux-arguments initrd multiboot-kernel
+ multiboot-arguments multiboot-modules chain-loader)
+ (let ((normalize-file
+ (compose sanitize (cut normalize-file entry <>))))
+ #~(begin
+ (format #$port "menuentry ~s {~% " #$label)
+ #$(search/menu-entry
+ device (or linux multiboot-kernel chain-loader) "boot" port)
+ #$@(cond
+ (linux
+ (list #~(format
+ #$port " linux \"($boot)~a\" ~a~%"
+ #$(normalize-file linux)
+ ;; GRUB passes rest of the line _verbatim_.
+ (string-join (list #$@linux-arguments)))
+ #~(format #$port " initrd ~a \"($boot)~a\"~%"
+ (if #$extra-initrd
+ (string-append "($boot)\""
+ (normalize-file
+ #$extra-initrd)
+ "\"")
+ "")
+ #$(normalize-file initrd))))
+ ;; Previously, this provided a (wrong) root= argument.
+ ;; Just don't bother anymore; better less info than
+ ;; wrong info.
+ (multiboot-kernel
+ (cons
+ #~(format #$port " multiboot \"($boot)~a\" ~a~%"
+ #$(normalize-file multiboot-kernel)
+ (string-join (list #$@multiboot-arguments)))
+ (map (lambda (mod)
+ #~(format port " module \"($boot)~a\"~%"
+ #$(normalize-file mod)))
+ multiboot-modules)))
+ (chain-loader
+ (list #~(format #$port " chainloader \"~a\"~%"
+ #$(normalize-file chain-loader)))))
+ (format #$port "}~%")))))
+
+;; TODO: use define-configuration.
+(define (make-grub.cfg bootloader-config locale install menu-entries
+ old-entries terms->str outputs inputs theme)
+ (define (colors->str c)
+ (format #f "~a/~a" (assoc-ref c 'fg) (assoc-ref c 'bg)))
+
+ (match-bootloader-configuration
+ bootloader-config
+ ;; XXX: Separate these fields into another record?
+ (default-entry timeout serial-unit serial-speed)
+ #~(call-with-output-file #$output
+ (lambda (port)
+ ;; preamble
+ (format port "\
+# This file was generated from your Guix configuration. Any changes
+# will be lost upon reconfiguration~%")
+ #$@(when-list
+ ;; menu settings
+ (and default-entry
+ #~(format port "set default=~a~%" #$default-entry))
+ (and timeout
+ #~(format port "set timeout=~a~%" #$timeout))
+ ;; gfxterm setup
+ (and (memq 'gfxterm outputs)
+ #~(format
+ port "\
if loadfont unicode; then
set gfxmode=~a
insmod all_video
insmod gfxterm
fi~%"
- #$(string-join
- (grub-theme-gfxmode (bootloader-theme config))
- ";"))
- ""))
-
- (define (theme-colors type)
- (let* ((theme (bootloader-theme config))
- (colors (type theme)))
- (string-append (symbol->string (assoc-ref colors 'fg)) "/"
- (symbol->string (assoc-ref colors 'bg)))))
-
- (define image
- (normalize-file (grub-background-image config)
- store-mount-point
- store-directory-prefix))
-
- (and image
- #~(format #$port "
-# Set 'root' to the partition that contains /gnu/store.
-~a
-
-~a
-~a
-
+ #$(string-join (grub-theme-gfxmode theme) ";")))
+ ;; io
+ (and (or serial-unit serial-speed)
+ #~(format
+ port "serial --unit=~a --speed=~a~%"
+ ;; Documented defaults are unit 0 at 9600 baud.
+ #$(number->string (or serial-unit 0))
+ #$(number->string (or serial-speed 9600))))
+ (and (pair? outputs)
+ #~(format port "terminal_output ~a~%"
+ #$(terms->str outputs)))
+ (and (pair? inputs)
+ #~(format port "terminal_input ~a~%"
+ #$(terms->str inputs)))
+ ;; locale
+ (and locale
+ #~(format port "\
+set \"locale_dir=($root)~a/locales\"
+set lang=~a~%"
+ #$(sanitize install)
+ #$(locale-definition-source
+ (locale-name->definition locale))))
+ ;; keyboard layout
+ (and (bootloader-configuration-keyboard-layout
+ bootloader-config)
+ #~(format port "\
+insmod keylayouts
+keymap \"($root)~a/keymap~%\""
+ #$(sanitize install)))
+ ;; theme
+ (match-record theme <grub-theme>
+ (image color-normal color-highlight)
+ (and image
+ #~(format port "\
insmod png
-if background_image ~a; then
+if background_image \"($root)~a/image.png\"; then
set color_normal=~a
set color_highlight=~a
else
set menu_color_normal=cyan/blue
set menu_color_highlight=white/blue
-fi~%"
- #$(grub-root-search store-device image)
- #$(setup-gfxterm config)
- #$(grub-setup-io config)
-
- #$image
- #$(theme-colors grub-theme-color-normal)
- #$(theme-colors grub-theme-color-highlight))))
-
-
-;;;
-;;; Configuration file.
-;;;
-
-(define* (keyboard-layout-file layout
- #:key
- (grub grub))
- "Process the X keyboard layout description LAYOUT, a <keyboard-layout> record,
-and return a file in the format for GRUB keymaps. LAYOUT must be present in
-the 'share/X11/xkb/symbols/' directory of 'xkeyboard-config'."
- (define builder
+fi~%" #$(sanitize install)
+ #$(colors->str color-normal)
+ #$(colors->str color-highlight)))))
+ ;; menu entries
+ #$@menu-entries
+ #$@(if (pair? old-entries)
+ (append (list #~(format
+ port "submenu ~s {~%"
+ "GNU system, old configurations..."))
+ old-entries
+ (list #~(format port "}~%")))
+ '())
+ (format port "\
+if [ \"${grub_platform}\" == efi ]; then
+ menuentry \"Firmware setup\" {
+ fwsetup
+ }
+fi~%")))))
+
+(define* (grub.cfg #:key bootloader-config
+ current-boot-alternative
+ old-boot-alternatives
+ locale
+ store-directory-prefix
+ #:allow-other-keys)
+ "Returns a valid GRUB config given installer inputs. Keymap and theme
+image are taken from BOOTLOADER-CONFIG, LOCALE is provided explicitly."
+ (match-bootloader-configuration
+ bootloader-config
+ ;; Can't match keyboard-layout here, because it's bound to its struct.
+ (menu-entries targets extra-initrd theme terminal-outputs
+ terminal-inputs)
+ (define (entries->gexp entries)
+ (map (cut menu-entry->gexp <> extra-initrd #~port)
+ entries))
+
+ (let* ((current-entry (boot-alternative->menu-entry
+ current-boot-alternative))
+ (entries (entries->gexp (cons current-entry menu-entries)))
+ (old-entries (entries->gexp (map boot-alternative->menu-entry
+ old-boot-alternatives)))
+ (terms->str (compose string-join (cut map symbol->string <>)))
+ ;; Use the values provided, or the defaults otherwise.
+ (outputs (or terminal-outputs '(gfxterm)))
+ (inputs (or terminal-inputs '()))
+ (theme (or theme (grub-theme))))
+ (and=>
+ (with-targets targets
+ (('install => (install :devpath))
+ (make-grub.cfg bootloader-config locale install entries
+ old-entries terms->str outputs inputs theme)))
+ (cut computed-file "grub.cfg" <>
+ ;; Since this file is rather unique, there's no point in
+ ;; trying to substitute it.
+ #:options '(#:local-build? #t #:substitutable? #f))))))
+
+(define (keyboard-layout-file layout grub)
+ "Process the X keyboard layout description LAYOUT, a <keyboard-layout>
+record, and return a file in the format for GRUB keymaps. LAYOUT must be
+present in the 'share/X11/xkb/symbols/' directory of 'xkeyboard-config'."
+ (computed-file
+ (string-append "grub-keymap."
+ (string-map (match-lambda (#\, #\-) (chr chr))
+ (keyboard-layout-name layout)))
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
-
;; 'grub-kbdcomp' passes all its arguments but '-o' to 'ckbcomp'
;; (from the 'console-setup' package).
(invoke #+(file-append grub "/bin/grub-mklayout")
"-i" #+(keyboard-layout->console-keymap layout)
- "-o" #$output))))
-
- (computed-file (string-append "grub-keymap."
- (string-map (match-lambda
- (#\, #\-)
- (chr chr))
- (keyboard-layout-name layout)))
- builder))
-
-(define (grub-setup-io config)
- "Return GRUB commands to configure the input / output interfaces. The result
-is a string that can be inserted in grub.cfg."
- (let* ((symbols->string (lambda (list)
- (string-join (map symbol->string list) " ")))
- (outputs (bootloader-configuration-terminal-outputs config))
- (inputs (bootloader-configuration-terminal-inputs config))
- (unit (bootloader-configuration-serial-unit config))
- (speed (bootloader-configuration-serial-speed config))
-
- ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT,
- ;; as documented in GRUB manual section "Simple Configuration
- ;; Handling".
- (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3
- gfxterm vga_text mda_text morse spkmodem))
- (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3
- at_keyboard usb_keyboard))
-
- (io (string-append
- ;; UNIT and SPEED are arguments to the same GRUB command
- ;; ("serial"), so we process them together.
- (if (or unit speed)
- (string-append
- "serial"
- (if unit
- ;; COM ports 1 through 4
- (if (and (exact-integer? unit) (<= unit 3) (>= unit 0))
- (string-append " --unit=" (number->string unit))
- #f)
- "")
- (if speed
- (if (exact-integer? speed)
- (string-append " --speed=" (number->string speed))
- #f)
- "")
- "\n")
- "")
- (if (null? inputs)
- ""
- (string-append
- "terminal_input "
- (symbols->string
- (map
- (lambda (input)
- (if (memq input valid-inputs) input #f)) inputs))
- "\n"))
- "terminal_output "
- (symbols->string
- (map
- (lambda (output)
- (if (memq output valid-outputs) output #f)) outputs)))))
- (format #f "~a" io)))
-
-(define (grub-root-search device file)
- "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
-a gexp. The result is a gexp that can be inserted in the grub.cfg-generation
-code."
- ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
- ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of
- ;; custom menu entries. In the latter case, don't emit a 'search' command.
- (if (and (string? file) (not (string-prefix? "/" file)))
- ""
- (match device
- ;; Preferably refer to DEVICE by its UUID or label. This is more
- ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
- ((? uuid? uuid)
- (format #f "search --fs-uuid --set ~a"
- (uuid->string device)))
- ((? file-system-label? label)
- (format #f "search --label --set ~a"
- (file-system-label->string label)))
- ((? (lambda (device)
- (and (string? device) (string-contains device ":/"))) nfs-uri)
- ;; If the device is an NFS share, then we assume that the expected
- ;; file on that device (e.g. the GRUB background image or the kernel)
- ;; has to be loaded over the network. Otherwise we would need an
- ;; additional device information for some local disk to look for that
- ;; file, which we do not have.
- ;;
- ;; We explicitly set "root=(tftp)" here even though if grub.cfg
- ;; had been loaded via TFTP, Grub would have set "root=(tftp)"
- ;; automatically anyway. The reason is if you have a system that
- ;; used to be on NFS but now is local, root would be set to local
- ;; disk. If you then selected an older system generation that is
- ;; supposed to boot from network in the Grub boot menu, Grub still
- ;; wouldn't load those files from network otherwise.
- ;;
- ;; TFTP is preferred to HTTP because it is used more widely and
- ;; specified in standards more widely--especially BOOTP/DHCPv4
- ;; defines a TFTP server for DHCP option 66, but not HTTP.
- ;;
- ;; Note: DHCPv6 specifies option 59 to contain a boot-file-url,
- ;; which can contain a HTTP or TFTP URL.
- ;;
- ;; Note: It is assumed that the file paths are of a similar
- ;; setup on both the TFTP server and the NFS server (it is
- ;; not possible to search for files on TFTP).
- ;;
- ;; TODO: Allow HTTP.
- "set root=(tftp)")
- ((or #f (? string?))
- #~(format #f "search --file --set ~a" #$file)))))
-
-(define* (make-grub-configuration grub config entries
- #:key
- (locale #f)
- (system (%current-system))
- (old-entries '())
- (store-crypto-devices '())
- 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.
-STORE-CRYPTO-DEVICES contain the UUIDs of the encrypted units that must
-be unlocked to access the store contents.
-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 ((label (menu-entry-label entry))
- (linux (menu-entry-linux entry))
- (device (menu-entry-device entry))
- (device-mount-point (menu-entry-device-mount-point entry))
- (multiboot-kernel (menu-entry-multiboot-kernel entry))
- (chain-loader (menu-entry-chain-loader entry)))
- (cond
- (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))
- (extra-initrd (bootloader-configuration-extra-initrd config)))
- ;; 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 STORE-DIRECTORY-PREFIX 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 ~a
-}~%"
- #$label
- #$(grub-root-search device linux)
- #$linux (string-join (list #$@arguments))
- (or #$extra-initrd "")
- #$initrd)))
- (multiboot-kernel
- (let* ((kernel (menu-entry-multiboot-kernel entry))
- (arguments (menu-entry-multiboot-arguments entry))
- ;; Choose between device names as understood by Mach's built-in
- ;; IDE driver ("hdX") and those understood by rumpdisk ("wdX"
- ;; in the "noide" case).
- (disk (if (member "noide" arguments) "w" "h"))
- (modules (menu-entry-multiboot-modules entry))
- (root-index 1)) ; XXX EFI will need root-index 2
- #~(format port "
-menuentry ~s {
- multiboot ~a root=part:~a:device:~ad0~a~a
-}~%"
- #$label
- #$kernel
- #$root-index
- #$disk
- (string-join (list #$@arguments) " " 'prefix)
- (string-join (map string-join '#$modules)
- "\n module " 'prefix))))
- (chain-loader
- #~(format port "
-menuentry ~s {
- ~a
- chainloader ~a
-}~%"
- #$label
- #$(grub-root-search device chain-loader)
- #$chain-loader)))))
-
- (define (crypto-devices)
- (define (crypto-device->cryptomount dev)
- (if (uuid? dev)
- #~(format port "cryptomount -u ~a~%"
- ;; cryptomount only accepts UUID without the hypen.
- #$(string-delete #\- (uuid->string dev)))
- ;; Other type of devices aren't implemented.
- #~()))
- (let ((devices (map crypto-device->cryptomount store-crypto-devices))
- (modules #~(format port "insmod luks~%insmod luks2~%")))
- (if (null? devices)
- devices
- (cons modules devices))))
-
- (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 locale-config
- (let* ((entry (first all-entries))
- (device (menu-entry-device entry))
- (mount-point (menu-entry-device-mount-point entry)))
- #~(let ((locale #$(and locale
- (locale-definition-source
- (locale-name->definition locale))))
- (locales #$(and locale
- (normalize-file (grub-locale-directory grub)
- mount-point
- store-directory-prefix))))
- (when locale
- (format port "\
-# Localization configuration.
-~asearch --file --set ~a/en@quot.mo
-set locale_dir=~a
-set lang=~a~%"
- ;; Skip the search if there is an image, as it has already
- ;; been performed by eye-candy and traversing the store is
- ;; an expensive operation.
- #$(if (grub-theme-image (bootloader-theme config))
- "# "
- "")
- locales
- locales
- locale)))))
-
- (define keyboard-layout-config
- (let* ((layout (bootloader-configuration-keyboard-layout config))
- (keymap* (and layout
- (keyboard-layout-file layout #:grub grub)))
- (entry (first all-entries))
- (device (menu-entry-device entry))
- (mount-point (menu-entry-device-mount-point entry))
- (keymap (and keymap*
- (normalize-file keymap* mount-point
- store-directory-prefix))))
- #~(when #$keymap
- (format port "\
-insmod keylayouts
-keymap ~a~%" #$keymap))))
-
- (define builder
- #~(call-with-output-file #$output
- (lambda (port)
- (format port
- "# This file was generated from your Guix configuration. Any changes
-# will be lost upon reconfiguration.
-")
- #$@(crypto-devices)
- #$(sugar)
- #$locale-config
- #$keyboard-layout-config
- (format port "
-set default=~a
-set timeout=~a~%"
- #$(bootloader-configuration-default-entry config)
- #$(bootloader-configuration-timeout config))
- #$@(map menu-entry->gexp all-entries)
-
- #$@(if (pair? old-entries)
- #~((format port "
-submenu \"GNU system, old configurations...\" {~%")
- #$@(map menu-entry->gexp old-entries)
- (format port "}~%"))
- #~())
- (format port "
-if [ \"${grub_platform}\" == efi ]; then
- menuentry \"Firmware setup\" {
- fwsetup
- }
-fi~%"))))
-
- ;; Since this file is rather unique, there's no point in trying to
- ;; substitute it.
- (computed-file "grub.cfg" builder
- #:options '(#:local-build? #t
- #:substitutable? #f)))
-
-(define (grub-configuration-file config . args)
- (let* ((bootloader (bootloader-configuration-bootloader config))
- (grub (bootloader-package bootloader)))
- (apply make-grub-configuration grub config args)))
-
-(define (grub-efi-configuration-file . args)
- (apply make-grub-configuration grub-efi args))
-
-(define grub-cfg "/boot/grub/grub.cfg")
+ "-o" #$output)))))
+
+(define* (grub.dir grub #:key bootloader-config locale
+ #:allow-other-keys . args)
+ "Everything that should go in GRUB's prefix. Includes fonts, modules,
+locales, keymap, theme image, and grub.cfg."
+ (let* ((theme (or (bootloader-configuration-theme bootloader-config)
+ (grub-theme)))
+ (keyboard-layout (bootloader-configuration-keyboard-layout
+ bootloader-config))
+ (lang (and=> locale (compose locale-definition-source
+ locale-name->definition)))
+ (lc-mesg (and lang (file-append grub "/share/locale" lang
+ "/LC_MESSAGES/grub.mo"))))
+ (computed-file "grub.dir"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p #$output)
+ (chdir #$output)
+ ;; grub files
+ (copy-recursively #$(file-append grub "/lib/grub/") #$output
+ #:copy-file symlink)
+ (mkdir "fonts")
+ (symlink #$(file-append grub "/share/grub/unicode.pf2")
+ "fonts/unicode.pf2")
+ ;; config file
+ (symlink #$(apply grub.cfg args) "grub.cfg")
+ ;; locales
+ ;; XXX: Warn if missing?
+ (when (and=> #$lc-mesg file-exists?)
+ (mkdir "locales")
+ (symlink #$lc-mesg
+ (string-append "locales/" #$lang ".mo")))
+ ;; keymap
+ #$@(when-list
+ (and keyboard-layout
+ #~(symlink #$(keyboard-layout-file keyboard-layout
+ grub)
+ "keymap"))
+ ;; image
+ (and (grub-theme-image theme)
+ #~(copy-file #$(grub-theme-png theme)
+ "image.png")))))
+ #:options '(#:local-build? #t #:substitutable? #f))))
-
;;;
-;;; Install procedures.
+;;; Installers.
;;;
-(define install-grub
- #~(lambda (bootloader device mount-point)
- (let ((grub (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot")))
- ;; 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 a font and GRUB modules.
- (let* ((fonts (string-append install-dir "/grub/fonts")))
- (mkdir-p fonts)
- (copy-file (string-append bootloader "/share/grub/unicode.pf2")
- (string-append fonts "/unicode.pf2"))
- (copy-recursively (string-append bootloader "/lib/")
- install-dir))))))
-
-(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)
- ;; There is nothing useful to do when called in the context of a disk
- ;; image generation.
- (when efi-dir
- ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
- ;; system whose root is mounted at MOUNT-POINT.
- (let ((grub-install (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot"))
- ;; When installing Guix, it's common to mount EFI-DIR below
- ;; MOUNT-POINT rather than /boot/efi on the live image.
- (target-esp (if (file-exists? (string-append mount-point efi-dir))
- (string-append mount-point efi-dir)
- efi-dir)))
- ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
- ;; root partition.
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet grub-install "--boot-directory" install-dir
- "--bootloader-id=Guix"
- "--efi-directory" target-esp)))))
-
-(define install-grub-efi-removable
- #~(lambda (bootloader efi-dir mount-point)
- ;; NOTE: mount-point is /mnt in guix system init /etc/config.scm /mnt/point
- ;; NOTE: efi-dir comes from target list of booloader configuration
- ;; There is nothing useful to do when called in the context of a disk
- ;; image generation.
- (when efi-dir
- ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
- ;; system whose root is mounted at MOUNT-POINT.
- (let ((grub-install (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot"))
- ;; When installing Guix, it's common to mount EFI-DIR below
- ;; MOUNT-POINT rather than /boot/efi on the live image.
- (target-esp (if (file-exists? (string-append mount-point efi-dir))
- (string-append mount-point efi-dir)
- efi-dir)))
- ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
- ;; root partition.
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet grub-install "--boot-directory" install-dir
- "--removable"
- ;; "--no-nvram"
- "--bootloader-id=Guix"
- "--efi-directory" target-esp)))))
-
-(define install-grub-efi32
- #~(lambda (bootloader efi-dir mount-point)
- ;; There is nothing useful to do when called in the context of a disk
- ;; image generation.
- (when efi-dir
- ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
- ;; system whose root is mounted at MOUNT-POINT.
- (let ((grub-install (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot"))
- ;; When installing Guix, it's common to mount EFI-DIR below
- ;; MOUNT-POINT rather than /boot/efi on the live image.
- (target-esp (if (file-exists? (string-append mount-point efi-dir))
- (string-append mount-point efi-dir)
- efi-dir)))
- ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
- ;; root partition.
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet grub-install "--boot-directory" install-dir
- "--bootloader-id=Guix"
- (cond ((target-x86?) "--target=i386-efi")
- ((target-arm?) "--target=arm-efi"))
- "--efi-directory" target-esp)))))
-
-(define* (make-grub-efi-netboot-installer grub-efi grub-cfg subdir)
- "Make a bootloader-installer for a grub-efi-netboot bootloader, which expects
-its files in SUBDIR and its configuration file in GRUB-CFG.
-
-As a grub-efi-netboot package is already pre-installed by 'grub-mknetdir', the
-installer basically copies all files from the bootloader-package (or profile)
-into the bootloader-target directory.
-
-Additionally for network booting over TFTP, two relative symlinks to the store
-and to the GRUB-CFG file are necessary. Due to this a TFTP root directory must
-not be located on a FAT file-system.
-
-If the bootloader-target does not support symlinks, then it is assumed to be a
-kind of EFI System Partition (ESP). In this case an intermediate configuration
-file is created with the help of GRUB-EFI to load the GRUB-CFG.
-
-The installer is usable for any efi-bootloader-chain, which prepares the
-bootloader-profile in a way ready for copying.
-
-The installer does not manipulate the system's 'UEFI Boot Manager'.
-
-The returned installer accepts the BOOTLOADER, TARGET and MOUNT-POINT
-arguments. Its job is to copy the BOOTLOADER, which must be a pre-installed
-grub-efi-netboot package with a SUBDIR like efi/boot or efi/Guix, below the
-directory TARGET for the system whose root is mounted at MOUNT-POINT.
-
-MOUNT-POINT is the last argument in 'guix system init /etc/config.scm mnt/point'
-or '/' for other 'guix system' commands.
-
-Where TARGET comes from the targets argument given to the
-bootloader-configuration in:
-
-(operating-system
- (bootloader (bootloader-configuration
- (targets '(\"/boot/efi\"))
- …))
- …)
-
-TARGET is required to be an absolute directory name, usually mounted via NFS,
-and finally needs to be provided by a TFTP server as
-the TFTP root directory.
-
-Usually the installer will be used to prepare network booting over TFTP. Then
-GRUB will load tftp://server/SUBDIR/grub.cfg and this file will instruct it to
-load more files from the store like tftp://server/gnu/store/…-linux…/Image.
-
-To make this possible two symlinks are created. The first symlink points
-relatively form MOUNT-POINT/TARGET/SUBDIR/grub.cfg to
-MOUNT-POINT/boot/grub/grub.cfg, and the second symlink points relatively from
-MOUNT-POINT/TARGET/%store-prefix to MOUNT-POINT/%store-prefix.
-
-It is important to note that these symlinks need to be relative, as the absolute
-paths on the TFTP server side are unknown.
-
-It is also important to note that both symlinks will point outside the TFTP root
-directory and that the TARGET/%store-prefix symlink makes the whole store
-accessible via TFTP. Possibly the TFTP server must be configured to allow
-accesses outside its TFTP root directory. This all may need to be considered
-for security aspects. It is advised to disable any TFTP write access!
-
-The installer can also be used to prepare booting from local storage, if the
-underlying file-system, like FAT on an EFI System Partition (ESP), does not
-support symlinks. In this case the MOUNT-POINT/TARGET/SUBDIR/grub.cfg will be
-created with the help of GRUB-EFI to load the /boot/grub/grub.cfg file. A
-symlink to the store is not needed in this case."
- (with-imported-modules '((guix build union))
- #~(lambda (bootloader target mount-point)
- ;; In context of a disk image creation TARGET will be #f and an
- ;; installer is expected to do necessary installations on MOUNT-POINT,
- ;; which will become the root file system. If TARGET is #f, this
- ;; installer has nothing to do, as it only cares about the EFI System
- ;; Partition (ESP).
- (when target
- (use-modules ((guix build union) #:select (symlink-relative))
- (ice-9 popen)
- (ice-9 rdelim))
- (let* ((mount-point/target (string-append mount-point target "/"))
- ;; When installing Guix, it is common to mount TARGET below
- ;; MOUNT-POINT rather than the root directory.
- (bootloader-target (if (file-exists? mount-point/target)
- mount-point/target
- target))
- (store (string-append mount-point (%store-prefix)))
- (store-link (string-append bootloader-target (%store-prefix)))
- (grub-cfg (string-append mount-point #$grub-cfg))
- (grub-cfg-link (string-append bootloader-target
- #$subdir "/"
- (basename grub-cfg))))
- ;; Copy the bootloader into the bootloader-target directory.
- ;; Should we beforehand recursively delete any existing file?
- (copy-recursively bootloader bootloader-target
- #:follow-symlinks? #t
- #:log (%make-void-port "w"))
- ;; For TFTP we need to install additional relative symlinks.
- ;; If we install on an EFI System Partition (ESP) or some other FAT
- ;; file-system, then symlinks cannot be created and are not needed.
- ;; Therefore we ignore exceptions when trying.
- ;; Prepare the symlink to the grub.cfg.
- (mkdir-p (dirname grub-cfg-link))
- (false-if-exception (delete-file grub-cfg-link))
- (if (unspecified?
- (false-if-exception (symlink-relative grub-cfg grub-cfg-link)))
- ;; Symlinks are supported.
- (begin
- ;; Prepare the symlink to the store.
- (mkdir-p (dirname store-link))
- (false-if-exception (delete-file store-link))
- (symlink-relative store store-link))
- ;; Creating symlinks does not seem to be supported. Probably
- ;; an ESP is used. Add a script to search and load the actual
- ;; grub.cfg.
- (let* ((probe #$(file-append grub-efi "/sbin/grub-probe"))
- (port (open-pipe* OPEN_READ probe "--target=fs_uuid"
- grub-cfg))
- (search-root
- (match (read-line port)
- ((? eof-object?)
- ;; There is no UUID available. As a fallback search
- ;; everywhere for the grub.cfg.
- (string-append "search --file --set " #$grub-cfg))
- (fs-uuid
- ;; The UUID to load the grub.cfg from is known.
- (string-append "search --fs-uuid --set " fs-uuid))))
- (load-grub-cfg (string-append "configfile " #$grub-cfg)))
- (close-pipe port)
- (with-output-to-file grub-cfg-link
- (lambda ()
- (display (string-join (list search-root
- load-grub-cfg)
- "\n")))))))))))
+(define* (install-grub.dir grub #:key bootloader-config
+ #:allow-other-keys . args)
+ (with-targets (bootloader-configuration-targets bootloader-config)
+ (('install => (path :path))
+ #~(copy-recursively #$(apply grub.dir grub args) #$path
+ #:log (%make-void-port "w")
+ #:follow-symlinks? #t
+ #:copy-file atomic-copy))))
+
+(define (install-grub-bios grub)
+ "Returns an installer for the bios-bootable grub package GRUB."
+ (lambda* (#:key bootloader-config #:allow-other-keys . args)
+ (gbegin (apply install-grub.dir grub args)
+ (with-targets (bootloader-configuration-targets bootloader-config)
+ (('disk => (device :device))
+ #~(invoke #$(file-append grub "/sbin/grub-bios-setup") "-v" "-v"
+ "--directory" "/" ; can't be blank
+ "--device-map" "" ; no dev map - need to specify
+ "--boot-image"
+ #$(file-append grub "/lib/grub/i386-pc/boot.img")
+ "--core-image" #$(apply core.img grub "pc" args)
+ "--root-device" #$(string-append "hostdisk/" device)
+ #$device))))))
+
+(define* (install-grub-efi #:key bootloader-config
+ #:allow-other-keys . args)
+ "Installs GRUB into the system's UEFI bootloader, taking into account
+user-specified requirements for a 32-bit or fallback bootloader."
+ (let* ((32? (bootloader-configuration-32bit? bootloader-config))
+ (grub (if 32? grub-efi32 grub-efi))
+ (core (apply core.img grub "efi" args))
+ (copy #~(lambda (dest) (copy-file #$core dest))))
+ (gbegin (apply install-grub.dir grub args)
+ (install-efi bootloader-config
+ #~`((,#$copy "grub.efi" . "GNU GRUB"))))))
-
;;;
-;;; Bootloader definitions.
+;;; Bootloaders.
;;;
-;;; For all these grub-bootloader variables the path to /boot/grub/grub.cfg
-;;; is fixed. Inheriting and overwriting the field 'configuration-file' will
-;;; break 'guix system delete-generations', 'guix system switch-generation',
-;;; and 'guix system roll-back'.
+
+(define %grub-default-targets
+ (list (bootloader-target
+ (type 'install)
+ (offset 'root)
+ (path "boot"))))
(define grub-bootloader
(bootloader
- (name 'grub)
- (package grub)
- (installer install-grub)
- (disk-image-installer install-grub-disk-image)
- (configuration-file grub-cfg)
- (configuration-file-generator grub-configuration-file)))
+ (name 'grub)
+ (default-targets %grub-default-targets)
+ (installer (install-grub-bios grub))))
(define grub-minimal-bootloader
(bootloader
- (inherit grub-bootloader)
- (package grub-minimal)))
+ (name 'grub)
+ (default-targets %grub-default-targets)
+ (installer (install-grub-bios grub-minimal))))
(define grub-efi-bootloader
(bootloader
- (name 'grub-efi)
- (package grub-efi)
- (installer install-grub-efi)
- (disk-image-installer #f)
- (configuration-file grub-cfg)
- (configuration-file-generator grub-configuration-file)))
-
-(define grub-efi-removable-bootloader
- (bootloader
- (inherit grub-efi-bootloader)
- (name 'grub-efi-removable-bootloader)
- (installer install-grub-efi-removable)))
+ (name 'grub-efi)
+ (default-targets (list (bootloader-target
+ (type 'vendir)
+ (offset 'esp)
+ (path "EFI/Guix"))
+ (bootloader-target
+ (type 'install)
+ (offset 'esp)
+ (path "grub"))))
+ (installer install-grub-efi)))
+
+
+;;;
+;;; Deprecated! Use the bootloader-config flags instead. Or, in the
+;;; case of netboot, set your 'install (or parent thereof) target fs to
+;;; be "tftp" or "nfs".
+;;;
-(define grub-efi32-bootloader
+(define (deprecated-installer installer removable? 32?)
+ "INSTALLER with overrides for its bootloader-config argument."
+ (lambda args
+ (apply installer (substitute-keyword-arguments args
+ ((#:bootloader-config conf)
+ (bootloader-configuration
+ (inherit conf)
+ (efi-removable? removable?)
+ (32bit? 32?)))))))
+
+(define-deprecated grub-efi-removable-bootloader grub-efi-bootloader
(bootloader
- (inherit grub-efi-bootloader)
- (installer install-grub-efi32)
- (name 'grub-efi32)
- (package grub-efi32)))
+ (inherit grub-efi-bootloader)
+ (installer (deprecated-installer install-grub-efi #t #f))))
-(define (make-grub-efi-netboot-bootloader name subdir)
+(define-deprecated grub-efi32-bootloader grub-efi-bootloader
(bootloader
- (name name)
- (package (make-grub-efi-netboot (symbol->string name) subdir))
- (installer (make-grub-efi-netboot-installer grub-efi grub-cfg subdir))
- (disk-image-installer #f)
- (configuration-file grub-cfg)
- (configuration-file-generator grub-efi-configuration-file)))
-
-(define grub-efi-netboot-bootloader
- (make-grub-efi-netboot-bootloader 'grub-efi-netboot-bootloader
- "efi/Guix"))
-
-(define grub-efi-netboot-removable-bootloader
- (make-grub-efi-netboot-bootloader 'grub-efi-netboot-removable-bootloader
- "efi/boot"))
-
-(define grub-mkrescue-bootloader
+ (inherit grub-efi-bootloader)
+ (installer (deprecated-installer install-grub-efi #f #t))))
+
+(define %netboot-targets
+ (list (bootloader-target
+ (type 'install)
+ (offset 'root)
+ (path "boot")
+ (file-system "tftp"))
+ (bootloader-target
+ (type 'vendir)
+ (offset 'esp)
+ (path "EFI/Guix"))))
+
+(define-deprecated grub-efi-netboot-bootloader
+ grub-efi-bootloader
(bootloader
- (inherit grub-efi-bootloader)
- (package grub-hybrid)))
+ (inherit grub-efi-bootloader)
+ (default-targets %netboot-targets)))
-
-;;;
-;;; Compatibility macros.
-;;;
-
-(define-syntax grub-configuration
- (syntax-rules (grub)
- ((_ (grub package) fields ...)
- (if (eq? package grub)
- (bootloader-configuration
- (bootloader grub-bootloader)
- fields ...)
- (bootloader-configuration
- (bootloader grub-efi-bootloader)
- fields ...)))
- ((_ fields ...)
- (bootloader-configuration
- (bootloader grub-bootloader)
- fields ...))))
-
-;;; grub.scm ends here
+(define-deprecated grub-efi-netboot-removable-bootloader
+ grub-efi-bootloader
+ (bootloader
+ (inherit grub-efi-bootloader)
+ (default-targets %netboot-targets)
+ (installer (deprecated-installer install-grub-efi #t #f))))
@@ -498,92 +498,6 @@ (define-public grub-hybrid
basename))))
(scandir input-dir)))))))))))
-(define-public (make-grub-efi-netboot name subdir)
- "Make a grub-efi-netboot package named NAME, which will be able to boot over
-network via TFTP by accessing its files in the SUBDIR of a TFTP root directory.
-This package is also able to boot from local storage devices.
-
-A bootloader-installer basically needs to copy the package content into the
-bootloader-target directory, which will usually be the TFTP root, as
-'grub-mknetdir' will be invoked already during the package creation.
-
-Alternatively the bootloader-target directory can be a mounted EFI System
-Partition (ESP), or a similar partition with a FAT file system, for booting
-from local storage devices.
-
-The name of the GRUB EFI binary will conform to the UEFI specification for
-removable media. Depending on the system it will be e.g. bootx64.efi or
-bootaa64.efi below SUBDIR.
-
-The SUBDIR argument needs to be set to \"efi/boot\" to create a package which
-conforms to the UEFI specification for removable media.
-
-The SUBDIR argument defaults to \"efi/Guix\", as it is also the case for
-'grub-efi-bootloader'."
- (package
- (name name)
- (version (package-version grub-efi))
- ;; Source is not needed, but it cannot be omitted.
- (source #f)
- (build-system trivial-build-system)
- (arguments
- (let* ((system (string-split (nix-system->gnu-triplet
- (or (%current-target-system)
- (%current-system)))
- #\-))
- (arch (first system))
- (boot-efi
- (match system
- ;; These are the supportend systems and the names defined by
- ;; the UEFI standard for removable media.
- (("i686" _ ...) "/bootia32.efi")
- (("x86_64" _ ...) "/bootx64.efi")
- (("arm" _ ...) "/bootarm.efi")
- (("aarch64" _ ...) "/bootaa64.efi")
- (("riscv" _ ...) "/bootriscv32.efi")
- (("riscv64" _ ...) "/bootriscv64.efi")
- ;; Other systems are not supported, although defined.
- ;; (("riscv128" _ ...) "/bootriscv128.efi")
- ;; (("ia64" _ ...) "/bootia64.efi")
- ((_ ...) #f)))
- (core-efi (string-append
- ;; This is the arch dependent file name of GRUB, e.g.
- ;; i368-efi/core.efi or arm64-efi/core.efi.
- (match arch
- ("i686" "i386")
- ("aarch64" "arm64")
- ("riscv" "riscv32")
- (_ arch))
- "-efi/core.efi")))
- (list
- #:modules '((guix build utils))
- #:builder
- #~(begin
- (use-modules (guix build utils))
- (let* ((bootloader #$(this-package-input "grub-efi"))
- (net-dir #$output)
- (sub-dir (string-append net-dir "/" #$subdir "/"))
- (boot-efi (string-append sub-dir #$boot-efi))
- (core-efi (string-append sub-dir #$core-efi)))
- ;; Install GRUB, which refers to the grub.cfg, with support for
- ;; encrypted partitions,
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet (string-append bootloader "/bin/grub-mknetdir")
- (string-append "--net-directory=" net-dir)
- (string-append "--subdir=" #$subdir)
- ;; These modules must be pre-loaded to allow booting
- ;; from an ESP or a similar partition with a FAT
- ;; file system.
- (string-append "--modules=part_msdos part_gpt fat"))
- ;; Move GRUB's core.efi to the removable media name.
- (false-if-exception (delete-file boot-efi))
- (rename-file core-efi boot-efi))))))
- (inputs (list grub-efi))
- (synopsis (package-synopsis grub-efi))
- (description (package-description grub-efi))
- (home-page (package-home-page grub-efi))
- (license (package-license grub-efi))))
-
(define-public syslinux
(let ((commit "bb41e935cc83c6242de24d2271e067d76af3585c"))
(package
From: Lilah Tascheter <lilah@lunabee.space> * gnu/bootloader.scm (bootloader-configuration)[terminal-outputs, terminal-inputs]: Don't assume grub. [%bootloader-configuration-targets]: Rename to the below. (bootloader-configuration-targets): Delete procedure. * gnu/bootloader/grub.scm (normalize-file, bootloader-theme, image->png, grub-background-image, grub-locale-directory, eye-candy, keyboard-layout-file, grub-setup-io, grub-root-search, make-grub-configuration, grub-configuration-file, grub-efi-configuration-file, install-grub, install-grub-disk-image, install-grub-efi, install-grub-efi-removable, install-grub-efi32, make-grub-efi-netboot-installer, make-grub-efi-netboot-bootloader): Remove procedures. (grub-cfg, grub-mkrescue-bootloader): Remove variables. (grub-efi-removable-bootloader, grub-efi32-bootloader, grub-efi-netboot-bootloader, grub-efi-netboot-removable-bootloader): Deprecate variables. (grub-configuration): Remove macro. (sanitize, search/target, search/menu-entry, when-list, grub-theme-png, core.cfg->core.img, core.cfg, core.img, menu-entry->gexp, make-grub.cfg, grub.cfg, grub.dir, install-grub.dir, install-grub-bios, install-grub-efi, deprecated-installer): Add procedures. (%grub-default-targets, %netboot-targets): Add variables. (keyboard-layout-file): Return computed file. * gnu/packages/bootloaders.scm (make-grub-efi-netboot): Delete procedure. * doc/guix.texi (system Configuration)[Bootloader Configuration]: Update terminal-outputs and terminal-inputs to not be GRUB-specific. Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739 --- doc/guix.texi | 23 +- gnu/bootloader.scm | 14 +- gnu/bootloader/grub.scm | 1332 ++++++++++++++-------------------- gnu/packages/bootloaders.scm | 86 --- 4 files changed, 550 insertions(+), 905 deletions(-)