From patchwork Tue Sep 24 18:29:09 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Herman Rimm X-Patchwork-Id: 68345 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 9ED6827BBE9; Tue, 24 Sep 2024 21:19:48 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.4 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_VALIDITY_CERTIFIED, RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE,SPF_HELO_PASS, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id D797A27BBE2 for ; Tue, 24 Sep 2024 21:19:45 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1stBzg-0004Fd-Ev; Tue, 24 Sep 2024 16:18:44 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1stBze-00049v-Rr for guix-patches@gnu.org; Tue, 24 Sep 2024 16:18:42 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1stBze-0002kG-H1; Tue, 24 Sep 2024 16:18:42 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=g/+zBuPo+Fwx8VjZV5tfZP/83D9KA5AceXggY3ah/fg=; b=ZVMY/7oy/9ziKVi/Hg+giN2d0nX6Kvxy3IFmUA/rehLa7ME7R4LXZqhoUaV8OBjdVfW0dfMz2Kdo4k0CelYrTUJDO/M6LZE93d0hD2AuVH40x1Wwkr4v7SGZr20kMVlX61NNROX60d4b4C3vql1/y24atByA5OYH9tv7YCV9dCY57tnO/1+9B7zctqNLfhS82eNkuvCPx0SBY6MJZFhcB+ve3pAflbBwBgr7KDQhn37fN7a2PLm7EsuzTzZH8onCFSM4molNyhK9fk0gFY0BRPDX07phwVjxNXIg12y0BJEUi47NDzRRAiYyhefafRGYx8ffKJMFf4HcRpIvV+X29g==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1stC00-0004m9-Ew; Tue, 24 Sep 2024 16:19:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#72457] [PATCH v6 02/12] gnu: bootloader: grub: Rewrite entirely. Resent-From: Herman Rimm Original-Sender: "Debbugs-submit" Resent-CC: efraim@flashner.co.il, pelzflorian@pelzflorian.de, lilah@lunabee.space, ludo@gnu.org, maxim.cournoyer@gmail.com, vagrant@debian.org, guix-patches@gnu.org Resent-Date: Tue, 24 Sep 2024 20:19:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 72457 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 72457@debbugs.gnu.org Cc: Lilah Tascheter , Efraim Flashner , Florian Pelz , Lilah Tascheter , Ludovic =?utf-8?q?Court=C3=A8s?= , Maxim Cournoyer , Vagrant Cascadian X-Debbugs-Original-Xcc: Efraim Flashner , Florian Pelz , Lilah Tascheter , Ludovic =?utf-8?q?Court=C3=A8s?= , Maxim Cournoyer , Vagrant Cascadian Received: via spool by 72457-submit@debbugs.gnu.org id=B72457.172720913018279 (code B ref 72457); Tue, 24 Sep 2024 20:19:04 +0000 Received: (at 72457) by debbugs.gnu.org; 24 Sep 2024 20:18:50 +0000 Received: from localhost ([127.0.0.1]:38423 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1stBzi-0004kU-Vo for submit@debbugs.gnu.org; Tue, 24 Sep 2024 16:18:50 -0400 Received: from 81-205-150-117.fixed.kpn.net ([81.205.150.117]:39007 helo=email.rimm.ee) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1stBzW-0004iX-Hb for 72457@debbugs.gnu.org; Tue, 24 Sep 2024 16:18:38 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=rimm.ee; s=herman; t=1727202611; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version:content-type:content-type: content-transfer-encoding:content-transfer-encoding: in-reply-to:in-reply-to:references:references; bh=DFFMgT0yXO1crwfGIXS5XHeryk7Xgggj8mvdJZHc7Bs=; b=sKe+VjBqG1czizOpux4eib3YDfNFS1IepDO4v0QAVMEGK7mmQDVIyXGyiaYtTB2nBOMNCj lqEtowo09tNrJltgK+T6UTGqqN63p1MS03/v3Y6xZd8QwYJ1sIwppmNqGFvOMHA1w3sAV7 WhwJ8OpJqMYlIPf839M3QcQZjkpv/UrZRyoQbivixk3jsJM0ksu9KgQeKA8Xj1bQkPbT84 Ins74vNdvpk/FBg2DnzLNHvmHV7XTnjZ20KYs8jEPrPmr3oXsnFjKWAYvZTYYDP86nLVjP QSs+KcRZkC8UXDzDNGFEr4PzLYZE0UOGWWuFyWspVOzU8Km0VvshabzIAx64hA== Received: by 81-205-150-117.fixed.kpn.net (OpenSMTPD) with ESMTPSA id 510f9f03 (TLSv1.3:TLS_CHACHA20_POLY1305_SHA256:256:NO); Tue, 24 Sep 2024 18:30:11 +0000 (UTC) Date: Tue, 24 Sep 2024 20:29:09 +0200 Message-ID: <6db91ca2342d184c376c664843a5cbf838f46312.1727201267.git.herman@rimm.ee> X-Mailer: git-send-email 2.45.2 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: Herman Rimm X-ACL-Warn: , Herman Rimm via Guix-patches X-Patchwork-Original-From: Herman Rimm via Guix-patches via From: Herman Rimm Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches From: Lilah Tascheter * 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(-) diff --git a/doc/guix.texi b/doc/guix.texi index 477d017202..a70b89957a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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}). diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index 522dd2fa7d..0a06c736c6 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -495,7 +495,7 @@ (define-record-type* bootloader-configuration? (bootloader bootloader-configuration-bootloader) ; - (targets %bootloader-configuration-targets + (targets bootloader-configuration-targets (default #f)) ;list of strings (menu-entries bootloader-configuration-menu-entries (default '())) ;list of @@ -512,9 +512,9 @@ (define-record-type* (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* (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. diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index 2723eda5f4..6e71f30f0d 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -10,6 +10,8 @@ ;;; Copyright © 2022 Karl Hallsby ;;; Copyright © 2022 Denis 'GNUtoo' Carikli ;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz> +;;; Copyright © 2024 Lilah Tascheter +;;; Copyright © 2024 Herman Rimm ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,24 +29,26 @@ ;;; along with GNU Guix. If not, see . (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 . + ((? 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* ;; 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* (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 (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 + (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 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 +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 . - ((? 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 - object, and where the store is available at -STORE-FS, a 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)))) diff --git a/gnu/packages/bootloaders.scm b/gnu/packages/bootloaders.scm index 2a12a38f1a..00b502aaee 100644 --- a/gnu/packages/bootloaders.scm +++ b/gnu/packages/bootloaders.scm @@ -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