From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0.migadu.com ([2001:41d0:303:e224::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id wFPzOQX8rmZPLAEAqHPOHw:P1 (envelope-from ) for ; Sun, 04 Aug 2024 03:56:54 +0000 Received: from aspmx1.migadu.com ([2001:41d0:303:e224::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0.migadu.com with LMTPS id wFPzOQX8rmZPLAEAqHPOHw (envelope-from ) for ; Sun, 04 Aug 2024 05:56:54 +0200 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=ZTtH7l4I; dkim=fail ("headers rsa verify failed") header.d=lunabee.space header.s=purelymail2 header.b=MA6u5YXL; dkim=fail ("headers rsa verify failed") header.d=purelymail.com header.s=purelymail2 header.b=ZrUBmFah; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1722743813; h=from:from:sender:sender:reply-to: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:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=s49vBlwC4U0083tfDLE1LJl2fW99pHoou1bOYIPFTm8=; b=NaHDAdtTegYe7ceRe0ngZigfkO312Hs6Az7Q7+P8GYdc2qr8aw4sUwifQo+tTTbKl9NtoD NaVYijHXlSHE6CEkhUuTASqwwtJQcRhAsIPN2b13FE8SiQUO5cfKblQ6M4wNWijGb7N2fk kyIE534hMs4v9NPAmAeJNRDG+Lu0kcv2eYW+p6DD7LgIq+oX7TPwgTP8Ydmkovdpl53P4M MD/yA4uIjrcUrlYqrxRtjWH3jctMxmDk7+h83zpA6Kk6n+q5AsQLaiycZUtGGNrQa1Icsy 51obeyah3oZIkX8Jiva/J9bVxzDClCmPVeb4HLdSK+XMZKzuVMmf8ShU+Lw8XQ== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1722743813; a=rsa-sha256; cv=none; b=S5/glBgtqY3hvY0myyKnI8SJriFniZfjaU0P1mRjpcWBzpmD6+BpRoaDce13nhtAJcTT10 0rD68tc5uxhjsBxgDVcrh+NyjgHVVvt0yar8lZnINAeujxEuUFoYKrazCFeXQ4uG7I3cCZ sEQuNab/QbkQT/SRodLehfyJHXsqOkJm4BEj1jXUu15VCzuiorc8h63PFzzttAUbWtzVLO bE/YvPWNuOGPvIfmn93g/NJpkSEoNZsvZHyo283hYqzh7e199iPNwj7p7XjCPrFbAlW4kR OTvxr9WAU3iqbgwFjPuG+L7UOX1xR2O9PiatebT57nqmjldEipD97jLFkdeLZA== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=ZTtH7l4I; dkim=fail ("headers rsa verify failed") header.d=lunabee.space header.s=purelymail2 header.b=MA6u5YXL; dkim=fail ("headers rsa verify failed") header.d=purelymail.com header.s=purelymail2 header.b=ZrUBmFah; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 4F485629E8 for ; Sun, 4 Aug 2024 05:56:53 +0200 (CEST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1saSMR-0007M3-V8; Sat, 03 Aug 2024 23:56:48 -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 1saSMR-0007Ld-4c for guix-patches@gnu.org; Sat, 03 Aug 2024 23:56:47 -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 1saSMQ-000490-Q1; Sat, 03 Aug 2024 23:56:46 -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=s49vBlwC4U0083tfDLE1LJl2fW99pHoou1bOYIPFTm8=; b=ZTtH7l4Is/WWRIBbMRCjI6Nac92fAOkmwdcFixjARvDIWXzsaZrZ098krkmYPKDG9bRFFlEtjoQsSkU0+HB6WlLG4yaCQ6xuAp1fpsRm0M/t7Tnt6WnYEC7+hPutVRWwYiW0Ek+wuXfSfr0FpTnoRb+nWb+tKE8dSnMhnfubwBfBVoZoGt+/PRZdRqEM/tMKuWUFQyy2a00eJTr5CDqho7osyj8zqQqZ3Y3MFWruK/rnjmfgGHnZhIEfXFXXvlfzU+Tl4WnnWRJw3IjgB0zmLY8HXQ8a7KQjqyMSvqbdbPox7+wmCbjCHt+0U6lESw9FkkshGygZSWK9RuL0w3yJdQ==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1saSMi-0001JD-QC; Sat, 03 Aug 2024 23:57:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#72457] [PATCH 04/15] gnu: Core bootloader changes. Resent-From: Lilah Tascheter Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, efraim@flashner.co.il, dev@jpoiret.xyz, lilah@lunabee.space, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr, vagrant@debian.org, guix-patches@gnu.org Resent-Date: Sun, 04 Aug 2024 03:57: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 , Christopher Baines , Efraim Flashner , Josselin Poiret , Lilah Tascheter , Ludovic Court??s , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice , Vagrant Cascadian X-Debbugs-Original-Xcc: Christopher Baines , Efraim Flashner , Josselin Poiret , Lilah Tascheter , Ludovic Court??s , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice , Vagrant Cascadian Received: via spool by 72457-submit@debbugs.gnu.org id=B72457.17227438224984 (code B ref 72457); Sun, 04 Aug 2024 03:57:04 +0000 Received: (at 72457) by debbugs.gnu.org; 4 Aug 2024 03:57:02 +0000 Received: from localhost ([127.0.0.1]:55125 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1saSMg-0001IG-6V for submit@debbugs.gnu.org; Sat, 03 Aug 2024 23:57:02 -0400 Received: from sendmail.purelymail.com ([34.202.193.197]:60930) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1saSMe-0001HJ-55 for 72457@debbugs.gnu.org; Sat, 03 Aug 2024 23:57:00 -0400 DKIM-Signature: a=rsa-sha256; b=MA6u5YXLhJo9wmT4/nCbZcmiU7PGaBzjoeN1IruJirPiiNhpSTEZC1uUUX35Vlsa7Y7tRON8bJD3Btmda1QVKzq+pDQKUYjH1FkpZBbPtGxgNWCy6qKHFDjFRzKORC7w9Lf8JMrAzKBxmdqiNnl9J4gPg/10flu6i9+itrkn1Ts0rtbHvJTwKjyiFhLGZSYrREPVNYtZtNqdQ293aTnt7MDVqXDbga7u/xvLMLewcekqSVJjPBPreY1WhRlY2qNXIfLB381f4/rMglzTocbTVhrSnDpwpQ5pw5DHc7vQyQfTpFYxF0GMD7en+liYTooKM5i1zdlXM6ofCHfT5K5Kbg==; s=purelymail2; d=lunabee.space; v=1; bh=AgXt7qnfFRpE3NNlhkjhHLEo04AMUogeAqm1KTiICo8=; h=Received:From:To:Subject:Date; DKIM-Signature: a=rsa-sha256; b=ZrUBmFahVu3aZ/RO9Icnd65nyMZ33Ry270823LBzzgjmich7Cl03u0//D8DyVktR5eokegByE/T6FwqMMvO6WIpu/l/R1A6EhdpqJu/u4OPDsS0a7jVHn1lffQprBGMJFBcLswl4M/FfZOMaHSA/Hcs6QIH45zS+umsM60hd3EuxfCDlPlolydVMifZBMTBttGDhC4hYKzHMcAmhM3GQR9XTQfraDE4RsEcLa3BYCz0FsoWV7JTDYxx9Ywv1R9q3PSvBrhXc85TL7h1UV/+H15gSXGK4dEcWkZlBP/4G6D1OHW6CoY7ym+Xj7crB8ix2zQLupwRWiHsDOL5AGI4X5Q==; s=purelymail2; d=purelymail.com; v=1; bh=AgXt7qnfFRpE3NNlhkjhHLEo04AMUogeAqm1KTiICo8=; h=Feedback-ID:Received:From:To:Subject:Date; Feedback-ID: 8937:2070:null:purelymail X-Pm-Original-To: 72457@debbugs.gnu.org Received: by smtp.purelymail.com (Purelymail SMTP) with ESMTPSA id 1753051598; (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Sun, 04 Aug 2024 03:56:21 +0000 (UTC) Date: Sat, 3 Aug 2024 22:55:24 -0500 Message-ID: <72fc11d9e6fe8b32a2afccd684371bacbb5a24b8.1722741997.git.lilah@lunabee.space> In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable X-MIME-Autoconverted: from 8bit to quoted-printable by Purelymail 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: , From: Lilah Tascheter via Guix-patches Reply-To: Lilah Tascheter Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Flow: FLOW_IN X-Migadu-Country: US X-Migadu-Queue-Id: 4F485629E8 X-Migadu-Scanner: mx12.migadu.com X-Migadu-Spam-Score: -5.44 X-Spam-Score: -5.44 X-TUID: 5yB29VM7xHJD Sorry this is a massive commit. It's kinda impossible to split it without either completely breaking basic functionality or making a buggy shim layer that's written just to be immediately removed. But, anyway, this is the real body of the bootloader subsystem update. One of my favorite new things possible with this is easy generation of disk images using arbitrary bootloaders, including ones that require one or more data/install partitions (such as p-boot or depthcharge)! * gnu/bootloader.scm (menu-entry): Add device-subvol field. (menu-entry->sexp, sexp->menu-entry): Support device-subvol. (normalize-file, warn-update-targets, target-overrides, normalize, bootloader-configuration->gexp, bootloader-configurations->gexps, efi-arch, install-efi): New procedures. (bootloader): Rewrite record. (bootloader-configuration)[target]: Remove deprecated field. [targets]: Include sanitizer and allow multiple bootloaders. [terminal-outputs, terminal-inputs]: Don't assume grub. [efi-removable?, 32bit?]: New fields. (warn-target-field-deprecation): Delete deprecation warning. (%bootloaders): Delete variable. (bootloader-configuration-target, bootloader-configuration-targets, lookup-bootloader-by-name, bootloader-modules, efi-bootloader-profile, efi-bootloader-chain): Delete procedures. * gnu/bootloader/depthcharge.scm, gnu/bootloader/extlinux.scm, gnu/bootloader/grub.scm, gnu/bootloader/u-boot.scm: Rewrite entirely. * gnu/build/bootloader.scm (parse-bootnums): New variable. (atomic-copy, in-temporary-directory, efi-bootnums): New procedures. (install-efi-loader): Delete procedure. (install-efi): Rewrite to support installation of any efi bootloader. * gnu/build/image.scm (initialize-efi32-partition: Deprecate. (initialize-efi-partitition): Only create EFI directory. (initialize-root-partition): Don't install bootloader here. (make-iso9660-image): Pull in grub.dir instead of a bootcfg. * gnu/build/install.scm (install-boot-config): Delete procedure. * gnu/image.scm (partition)[target]: New field in order to support dynamic provision of image partitions as bootloader targets. * gnu/installer/parted.scm (bootloader-configuration), gnu/machine/ssh.scm (deploy-managed-host) (roll-back-managed-host): Use new bootloader system. * gnu/packages/bootloaders.scm (make-grub-efi-netboot): Delete procedure. * gnu/packages/raspberry-pi.scm (grub-efi-bootloader-chain-raspi-64): Delete procedure. Can be recreated with a raspberry pi bootloader combined with grub-efi. * gnu/system.scm (convert-bootloader-field): New procedure. (operating-system)[bootloader]: Use above sanitizer and support multiple bootloaders. (operating-system-bootcfg): Rename to... (operating-system-bootmeta): ...this. Rewrite to return relavent information instead of calling the config procedure directly. (operating-system-boot-parameters): Support multiple bootloaders. * gnu/system/boot.scm (read-boot-parameters): Support multiple bootloaders. (boot-parameters->menu-entry): Support device-subvol. (boot-alternative->menu-entry): New procedure. * gnu/system/image.scm (root-partition, esp-partition): Use target field. (esp32-partition, efi32-disk-partition, efi32-raw-image-type): Deprecate. (root-partition-index): Delete procedure. (system-disk-image, system-iso9960-image): Support new bootloader system. (system-disk-image)[targets]: New subprocedure. * gnu/system/images/hurd.scm (hurd-barebones-os)[bootloader], gnu/system/images/novena.scm (novena-barebones-os)[bootloader], gnu/system/images/orangepi-r1-plus-lts-rk3328.scm (orangepi-r1-plus-lts-rk3328-barebones-os)[bootloader], gnu/system/images/pine64.scm (pine64-barebones-os)[bootloader], gnu/system/images/pinebook-pro.scm (pinebook-pro-barebones-os)[bootloader], gnu/system/images/rock64.scm (rock64-barebones-os)[bootloader], gnu/system/images/unmatched.scm (unmatched-barebones-os)[bootloader], gnu/system/images/visionfive2.scm (visionfive2-barebones-os)[bootloader]: Use new target format. * gnu/system/images/wsl2.scm (dummy-bootloader): Delete variable. (wsl-os)[bootloader]: Don't provide field. * gnu/system/install.scm (installation-os)[bootloader]: Use new format. (os-with-u-boot): Delete procedure. (embedded-installation-os)[bootloader]: Use new format. (beaglebone-black-installation-os, a20-olinuxino-lime-installation-os, a20-olinuxino-lime2-emmc-installation-os, a20-olinuxino-micro-installation-os, bananapi-m2-ultra-installation-os, firefly-rk3399-installation-os, mx6cuboxi-installation-os, novena-installation-os, nintendo-nes-classic-edition-installation-os, orangepi-r1-plus-lts-rk3328-installation-os, pine64-plus-installation-os, pinebook-installation-os, rock64-installation-os, rockpro64-installation-os, rk3399-puma-installation-os, wandboard-installation-os): Don't guess block device. * gnu/system/vm.scm (virtualized-operating-system): Don't provide bootloader. * gnu/tests/install.scm (%minimal-extlinux-os)[bootloader]: Use proper extlinux variable. (%btrfs-raid10-root-os): Use multiple bootloaders. * gnu/tests/reconfigure.scm (%test-install-bootloader): Delete variable. (run-install-bootloader-test): Delete procedure. * guix/scripts/system.scm (install, install-bootloader-from-provenance, perform-action): Support multiple bootloaders and work with new bootloader system instead of bootcfgs. (display-system-generation): Support multiple bootloaders. * guix/scripts/system/reconfigure.scm (install-bootloader-program): Rewrite to simply insert each bootloader's installer in the gexp directly, instead of copying bootcfgs. (install-bootloader): Work with new bootloader system. Just in case, add install-bootloader.scm to the gc roots too. Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739 --- gnu/bootloader.scm | 424 +++--- gnu/bootloader/depthcharge.scm | 153 +- gnu/bootloader/extlinux.scm | 149 +- gnu/bootloader/grub.scm | 1279 +++++++---------- gnu/bootloader/u-boot.scm | 439 ++---- gnu/build/bootloader.scm | 157 +- gnu/build/image.scm | 40 +- gnu/build/install.scm | 16 +- gnu/image.scm | 3 + gnu/installer/parted.scm | 12 +- gnu/machine/ssh.scm | 71 +- gnu/packages/bootloaders.scm | 86 -- gnu/packages/raspberry-pi.scm | 18 - gnu/system.scm | 45 +- gnu/system/boot.scm | 8 +- gnu/system/image.scm | 162 ++- gnu/system/images/hurd.scm | 4 +- gnu/system/images/novena.scm | 3 +- .../images/orangepi-r1-plus-lts-rk3328.scm | 3 +- gnu/system/images/pine64.scm | 3 +- gnu/system/images/pinebook-pro.scm | 3 +- gnu/system/images/rock64.scm | 3 +- gnu/system/images/unmatched.scm | 3 +- gnu/system/images/visionfive2.scm | 3 +- gnu/system/images/wsl2.scm | 14 +- gnu/system/install.scm | 43 +- gnu/system/vm.scm | 11 - gnu/tests/install.scm | 10 +- gnu/tests/reconfigure.scm | 86 +- guix/scripts/system.scm | 88 +- guix/scripts/system/reconfigure.scm | 159 +- 31 files changed, 1410 insertions(+), 2088 deletions(-) diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index 3ddc112cc6..2bb13437dc 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -7,6 +7,7 @@ ;;; Copyright =C2=A9 2022 Josselin Poiret ;;; Copyright =C2=A9 2022 Reza Alizadeh Majd ;;; Copyright =C2=A9 2024 Tomas Volf <~@wolfsden.cz> +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,45 +25,52 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (gnu bootloader) + #:autoload (gnu build file-systems) + (read-partition-label read-partition-uuid + find-partition-by-label find-partition-by-uuid) + #:use-module (gnu packages linux) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) - #:use-module (guix discovery) - #:use-module (guix gexp) - #:use-module (guix profiles) - #:use-module (guix records) + #:autoload (guix build syscalls) + (mounts mount-source mount-point mount-type) #:use-module (guix deprecation) #:use-module (guix diagnostics) + #:use-module (guix gexp) #:use-module (guix i18n) #:use-module (guix modules) + #:use-module (guix profiles) + #:use-module (guix records) + #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 match) - #:export (menu-entry + #:use-module (ice-9 receive) + #:export ( + menu-entry menu-entry? menu-entry-label menu-entry-device + menu-entry-device-mount-point + menu-entry-device-subvol menu-entry-linux menu-entry-linux-arguments menu-entry-initrd - menu-entry-device-mount-point menu-entry-multiboot-kernel menu-entry-multiboot-arguments menu-entry-multiboot-modules menu-entry-chain-loader =20 + normalize-file menu-entry->sexp sexp->menu-entry =20 bootloader bootloader? bootloader-name - bootloader-package + bootloader-default-targets bootloader-installer - bootloader-disk-image-installer - bootloader-configuration-file - bootloader-configuration-file-generator =20 bootloader-target @@ -84,13 +92,15 @@ (define-module (gnu bootloader) :path :devpath :device :fs :label :uuid with-targets =20 + bootloader-configuration bootloader-configuration? bootloader-configuration-bootloader - bootloader-configuration-target ;deprecated bootloader-configuration-targets bootloader-configuration-menu-entries bootloader-configuration-default-entry + bootloader-configuration-efi-removable? + bootloader-configuration-32bit? bootloader-configuration-timeout bootloader-configuration-keyboard-layout bootloader-configuration-theme @@ -101,10 +111,11 @@ (define-module (gnu bootloader) bootloader-configuration-device-tree-support? bootloader-configuration-extra-initrd =20 - %bootloaders - lookup-bootloader-by-name + bootloader-configuration->gexp + bootloader-configurations->gexp =20 - efi-bootloader-chain)) + efi-arch + install-efi)) =20 =0C ;;; @@ -119,6 +130,8 @@ (define-record-type* (default #f)) (device-mount-point menu-entry-device-mount-point (default #f)) + (device-subvol menu-entry-device-subvol + (default #f)) (linux menu-entry-linux (default #f)) (linux-arguments menu-entry-linux-arguments @@ -135,6 +148,18 @@ (define-record-type* (chain-loader menu-entry-chain-loader (default #f))) ; string, path of efi file =20 +(define (normalize-file entry val) + "Normalize a file VAL stored in a menu entry into one suitable for a +bootloader. Realizes device-mount-point and device-subvol." + (match-record entry (device-mount-point device-subvol) + #~(let* ((rel (lambda (s) (substring s (if (string-prefix? "/" s) 1 0)= ))) + (file (rel #$val)) + (subvol (and=3D> #$device-subvol rel)) + (mount (and=3D> #$device-mount-point rel))) + (string-append (if subvol (string-append "/" subvol "/") "/") + (if (and mount (string-prefix? mount file)) + (substring file (string-length mount)) file))))= ) + (define (report-menu-entry-error menu-entry) (raise (condition @@ -162,7 +187,7 @@ (define (menu-entry->sexp entry) `(label ,(file-system-label->string label))) (_ device))) (match entry - (($ label device mount-point + (($ label device mount-point subvol (? identity linux) linux-arguments (? identity initrd= ) #f () () #f) `(menu-entry (version 0) @@ -171,8 +196,9 @@ (define (menu-entry->sexp entry) (device-mount-point ,mount-point) (linux ,linux) (linux-arguments ,linux-arguments) - (initrd ,initrd))) - (($ label device mount-point #f () #f + (initrd ,initrd) + (device-subvol ,subvol))) + (($ label device mount-point subvol #f () #f (? identity multiboot-kernel) multiboot-arguments multiboot-modules #f) `(menu-entry (version 0) @@ -181,19 +207,23 @@ (define (menu-entry->sexp entry) (device-mount-point ,mount-point) (multiboot-kernel ,multiboot-kernel) (multiboot-arguments ,multiboot-arguments) - (multiboot-modules ,multiboot-modules))) - (($ label device mount-point #f () #f #f () () + (multiboot-modules ,multiboot-modules) + (device-subvol ,subvol))) + (($ label device mount-point subvol #f () #f #f () () (? identity chain-loader)) `(menu-entry (version 0) (label ,label) (device ,(device->sexp device)) (device-mount-point ,mount-point) - (chain-loader ,chain-loader))) + (chain-loader ,chain-loader) + (device-subvol ,subvol))) (_ (report-menu-entry-error entry)))) =20 (define (sexp->menu-entry sexp) "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a record." + ;; XXX: rely on shadowing to support the match ors below + (define subvol #f) (define (sexp->device device-sexp) (match device-sexp (('uuid type uuid-string) @@ -206,35 +236,41 @@ (define (sexp->menu-entry sexp) ('label label) ('device device) ('device-mount-point mount-point) ('linux linux) ('linux-arguments linux-arguments) - ('initrd initrd) _ ...) + ('initrd initrd) + (or ('device-subvol subvol _ ...) (_ ...))) (menu-entry (label label) (device (sexp->device device)) (device-mount-point mount-point) + (device-subvol subvol) (linux linux) (linux-arguments linux-arguments) (initrd initrd))) (('menu-entry ('version 0) ('label label) ('device device) - ('device-mount-point mount-point) + ('device-mount-point mount-point) ('device-subvol subvol= ) ('multiboot-kernel multiboot-kernel) ('multiboot-arguments multiboot-arguments) - ('multiboot-modules multiboot-modules) _ ...) + ('multiboot-modules multiboot-modules) + (or ('device-subvol subvol _ ...) (_ ...))) (menu-entry (label label) (device (sexp->device device)) (device-mount-point mount-point) + (device-subvol subvol) (multiboot-kernel multiboot-kernel) (multiboot-arguments multiboot-arguments) (multiboot-modules multiboot-modules))) (('menu-entry ('version 0) ('label label) ('device device) - ('device-mount-point mount-point) - ('chain-loader chain-loader) _ ...) + ('device-mount-point mount-point) ('device-subvol subvol= ) + ('chain-loader chain-loader) + (or ('device-subvol subvol _ ...) (_ ...))) (menu-entry (label label) (device (sexp->device device)) (device-mount-point mount-point) + (device-subvol subvol) (chain-loader chain-loader))))) =20 =0C @@ -247,15 +283,10 @@ (define (sexp->menu-entry sexp) ;; has to be described by this record. =20 (define-record-type* - bootloader make-bootloader - bootloader? - (name bootloader-name) - (package bootloader-package) - (installer bootloader-installer) - (disk-image-installer bootloader-disk-image-installer - (default #f)) - (configuration-file bootloader-configuration-file) - (configuration-file-generator bootloader-configuration-file-generator= )) + bootloader make-bootloader bootloader? + (name bootloader-name) + (default-targets bootloader-default-targets (default '())) + (installer bootloader-installer)) =20 =0C ;;; @@ -450,28 +481,48 @@ (define-syntax with-targets ;; The record contains bootloader independant ;; configuration used to fill bootloader configuration file. =20 -(define-with-syntax-properties (warn-target-field-deprecation - (value properties)) - (when value - (warning (source-properties->location properties) - (G_ "the 'target' field is deprecated, please use 'targets' \ -instead~%"))) - value) +(define-with-syntax-properties (warn-update-targets (value properties)) + (let ((loc (source-properties->location properties))) + (define update + (match-lambda + ((? bootloader-target? target) (cons #f target)) + ((? string? s) (cons #t (if (string-prefix? "/dev" s) + (bootloader-target + (type 'disk) + (device s)) + (bootloader-target + (type 'esp) + (offset 'root) + (path s))))) + (x (error loc (G_ "invalid target '~a'~%") x)))) + + (let* ((updated (map update (if (list? value) value (list value)))) + (targets (map cdr updated)) + (types (map bootloader-target-type targets))) + ;; XXX: should this be an error? + (when (any car updated) + (warning loc (G_ "the 'targets' field should now contain \ + records. inferring a best guess (this might break!)...= ~%"))) + (when (not (eqv? (length types) (length (delete-duplicates types)))) + (error loc (G_ "the 'targets' field may not contain duplicates~%")= )) + targets))) =20 (define-record-type* bootloader-configuration make-bootloader-configuration bootloader-configuration? (bootloader - bootloader-configuration-bootloader) ; - (targets %bootloader-configuration-targets - (default #f)) ;list of strings - (target %bootloader-configuration-target ;deprecated - (default #f) - (sanitize warn-target-field-deprecation)) + bootloader-configuration-bootloader) ; + (targets bootloader-configuration-targets + (default '()) ;list of strings + (sanitize warn-update-targets)) (menu-entries bootloader-configuration-menu-entries (default '())) ;list of (default-entry bootloader-configuration-default-entry (default 0)) ;integer + (efi-removable? bootloader-configuration-efi-removable? + (default #f)) ;bool + (32bit? bootloader-configuration-32bit? + (default #f)) ;bool (timeout bootloader-configuration-timeout (default 5)) ;seconds as integer (keyboard-layout bootloader-configuration-keyboard-layout @@ -479,9 +530,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 o= uts) (terminal-inputs bootloader-configuration-terminal-inputs - (default '())) ;list of symbols + (default #f)) ;list of symbols | #f (default i= ns) (serial-unit bootloader-configuration-serial-unit (default #f)) ;integer | #f (serial-speed bootloader-configuration-serial-speed @@ -491,164 +542,129 @@ (define-record-type* (extra-initrd bootloader-configuration-extra-initrd (default #f))) ;string | #f =20 -(define-deprecated (bootloader-configuration-target config) - bootloader-configuration-targets - (%bootloader-configuration-target config)) +=0C +;;; +;;; Bootloader installation paths. +;;; =20 -(define (bootloader-configuration-targets config) - (or (%bootloader-configuration-targets config) - ;; TODO: Remove after the deprecated 'target' field is removed. - (list (%bootloader-configuration-target config)) - ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has = this - ;; peculiar behavior of installing fonts and GRUB modules when DEVIC= E is #f, - ;; hence the default value of '(#f) rather than '(). - (list #f))) +;; highest -> lowest priority +(define (target-overrides . layers) + (let* ((types (fold append '() + (map (cute map bootloader-target-type <>) layers))) + (pred (lambda (type layer found) + (or found (get-target-of-type type layer)))) + (find (lambda (type) (fold (cute pred type <> <>) #f layers)))) + (filter ->bool (map find (delete-duplicates types))))) + +(define (normalize targets) + "Augments user-supplied targets with filesystem information at runtime, +allowing users to specify a lot less information. Relatively minimal to p= revent +errors. Puts targets into a normal form, where all paths are fully specif= ied up +to a device offset." + (let* ((mass (lambda (m) `((,(mount-source m) . ,m) (,(mount-point m) . = ,m)))) + (amounts (delay (apply append (map mass (mounts))))) + (accessible=3D> (lambda (d f) (and d (access? d R_OK) (f d)))) + (assoc-mnt (lambda (f) (lambda (v) + (and=3D> (assoc-ref (force amounts) v) f= ))))) + + (define (scrape target) + (match-record target + (expected? path offset device label uuid file-system) + (if expected? target + (bootloader-target + (inherit target) + (device (or device (false-if-exception + (or (and=3D> uuid find-partition-by-uuid) + (and=3D> label find-partition-by-labe= l))) + (and path ((assoc-mnt mount-source) + (unfold-pathcat target targets))= ))) + (label (or label (accessible=3D> device read-partition-label))= ) + (uuid (or uuid (accessible=3D> device read-partition-uuid))) + (file-system (or file-system (and=3D> device (assoc-mnt mount-= type)))) + (offset (and path offset)) + (path (or path (and=3D> device (assoc-mnt mount-point)))))))) + + (define (arborify target targets) + (let* ((up (lambda (t) (and t (parent-of t targets)))) + (proto (unfold target-base? identity up (up target) list)) + (chain (reverse (cons target proto)))) + (bootloader-target + (inherit target) + (offset (and=3D> (car chain) bootloader-target-type)) + (path (reduce pathcat #f (map bootloader-target-path (cdr chain)= )))))) + + (let ((mid (map scrape targets))) (map (cut arborify <> mid) mid)))) + +(define* (bootloader-configuration->gexp bootloader-config args #:key + (root-offset "/") (overrides '()= )) + "Returns a gexp to install BOOTLOADER-CONFIG to its targets, passing ARG= S +to each installer alongside the additional #:bootloader-config keyword +arguments. Target OVERRIDES are applied and all path targets have ROOT-OF= FSET +applied. The following keyword arguments are expected in ARGS: +@enumerate +@item current-boot-alternative +@item old-boot-alternatives +@item locale (from bootmeta) +@item store-directory-prefix (from bootmeta) +@item store-crypto-devices (from bootmeta) +@end enumerate" + (let* ((bootloader (bootloader-configuration-bootloader bootloader-confi= g)) + (installer (bootloader-installer bootloader)) + (auto-targets (list (bootloader-target + (type 'root) + (path root-offset) + (offset #f)))) + (targets (target-overrides + overrides + (bootloader-configuration-targets bootloader-config) + auto-targets + (bootloader-default-targets bootloader))) + (conf (bootloader-configuration + (inherit bootloader-config) + (targets (normalize targets))))) + (apply installer #:bootloader-config conf args))) + +(define (bootloader-configurations->gexp bootloader-configs . rest) + (apply gbegin (filter-map (cut apply bootloader-configuration->gexp <> r= est) + bootloader-configs))) =20 =0C ;;; -;;; Bootloaders. +;;; EFI shit ;;; =20 -(define (bootloader-modules) - "Return the list of bootloader modules." - ;; don't provide #:warn to prevent mutual imports - (all-modules (map (lambda (entry) - `(,entry . "gnu/bootloader")) - %load-path))) - -(define %bootloaders - ;; The list of publically-known bootloaders. - (delay (fold-module-public-variables (lambda (obj result) - (if (bootloader? obj) - (cons obj result) - result)) - '() - (bootloader-modules)))) - -(define (lookup-bootloader-by-name name) - "Return the bootloader called NAME." - (or (find (lambda (bootloader) - (eq? name (bootloader-name bootloader))) - (force %bootloaders)) - (leave (G_ "~a: no such bootloader~%") name))) - -(define (efi-bootloader-profile packages files hooks) - "Creates a profile from the lists of PACKAGES and FILES from the store. -This profile is meant to be used by the bootloader-installer. - -FILES is a list of file or directory names from the store, which will be -symlinked into the profile. If a directory name ends with '/', then the -directory content instead of the directory itself will be symlinked into t= he -profile. - -FILES may contain file like objects produced by procedures like plain-file= , -local-file, etc., or package contents produced with file-append. - -HOOKS lists additional hook functions to modify the profile." - (define* (efi-bootloader-profile-hook manifest #:optional system) - (define build - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules ((guix build utils) - #:select (mkdir-p strip-store-file-name)) - ((ice-9 ftw) - #:select (scandir)) - ((srfi srfi-1) - #:select (append-map every remove)) - ((srfi srfi-26) - #:select (cut))) - (define (symlink-to file directory transform) - "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTO= RY." - (symlink file (string-append directory "/" (transform file))= )) - (define (directory-content directory) - "Creates a list of absolute path names inside DIRECTORY." - (map (lambda (name) - (string-append directory name)) - (or (scandir directory (lambda (name) - (not (member name '("." ".."))= ))) - '()))) - (define name-ends-with-/? (cut string-suffix? "/" <>)) - (define (name-is-store-entry? name) - "Return #t if NAME is a direct store entry and nothing insid= e." - (not (string-index (strip-store-file-name name) #\/))) - (let* ((files '#$files) - (directories (filter name-ends-with-/? files)) - (names-from-directories - (append-map (lambda (directory) - (directory-content directory)) - directories)) - (names (append names-from-directories - (remove name-ends-with-/? files)))) - (mkdir-p #$output) - (if (every file-exists? names) - (begin - (for-each (lambda (name) - (symlink-to name #$output - (if (name-is-store-entry? name= ) - strip-store-file-name - basename))) - names) - #t) - #f))))) - - (gexp->derivation "efi-bootloader-profile" - build - #:system system - #:local-build? #t - #:substitutable? #f - #:properties - `((type . profile-hook) - (hook . efi-bootloader-profile-hook)))) - - (profile (content (packages->manifest packages)) - (name "efi-bootloader-profile") - (hooks (cons efi-bootloader-profile-hook hooks)) - (locales? #f) - (allow-collisions? #f) - (relative-symlinks? #f))) - -(define* (efi-bootloader-chain final-bootloader - #:key - (packages '()) - (files '()) - (hooks '()) - installer - disk-image-installer) - "Define a chain of bootloaders with the FINAL-BOOTLOADER, optional PACKA= GES, -and optional directories and files from the store given in the list of FIL= ES. - -The package of the FINAL-BOOTLOADER and all PACKAGES and FILES will be pla= ced -in an efi-bootloader-profile, which will be passed to the INSTALLER. - -FILES may contain file-like objects produced by procedures like plain-file= , -local-file, etc., or package contents produced with file-append. - -If a directory name in FILES ends with '/', then the directory content ins= tead -of the directory itself will be symlinked into the efi-bootloader-profile. - -The procedures in the HOOKS list can be used to further modify the bootloa= der -profile. It is possible to pass a single function instead of a list. - -If the INSTALLER argument is used, then this gexp procedure will be called= to -install the efi-bootloader-profile. Otherwise the installer of the -FINAL-BOOTLOADER will be called. - -If the DISK-IMAGE-INSTALLER is used, then this gexp procedure will be call= ed -to install the efi-bootloader-profile into a disk image. Otherwise the -disk-image-installer of the FINAL-BOOTLOADER will be called." - (bootloader - (inherit final-bootloader) - (name "efi-bootloader-chain") - (package - (efi-bootloader-profile (cons (bootloader-package final-bootloader) - packages) - files - (if (list? hooks) - hooks - (list hooks)))) - (installer - (or installer - (bootloader-installer final-bootloader))) - (disk-image-installer - (or disk-image-installer - (bootloader-disk-image-installer final-bootloader))))) +(define* (efi-arch #:key (target (or (%current-target-system) (%current-sy= stem))) + (32? #f)) + "Returns the UEFI architecture name for the current target, in lowercase= ." + (cond ((target-x86-32? target) "ia32") + ((target-x86-64? target) (if 32? "ia32" "x64")) + ((target-arm32? target) "arm") + ((target-aarch64? target) (if 32? "arm" "aa64")) + ((target-riscv64? target) (if 32? "riscv32" "riscv64")) + (else (raise (formatted-message (G_ "no UEFI standard arch for ~a!= ") + target))))) + +(define (install-efi bootloader-config plan) + "Returns a gexp installing PLAN to the ESP, as denoted by the 'vendir ta= rget. +PLAN is a gexp of a list of '(BUILDER DEST-BASENAME . LABEL) triples, that +should be in boot order. If the user selects a removable bootloader, only= the +first entry in PLAN is used." + (match-record bootloader-config + (targets efi-removable? 32bit?) + (if efi-removable? + ;; Hard code the output location to a well-known path recognized by + ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour": + ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202= _6.pdf + (with-targets targets + (('esp =3D> (path :path)) + #~(let ((boot #$(string-append path "/EFI/BOOT")) + (arch #$(string-upcase (efi-arch #:32? 32bit?))) + (builder (car (car #$plan)))) + (mkdir-p boot) + ;; only realize first planspec + (builder (string-append boot "/BOOT" arch ".EFI"))))) + ;; normal install when not doing a removable config + (with-targets targets + (('vendir =3D> (vendir :path) (loader :devpath) (disk :device)) + #~(install-efi #+(file-append efibootmgr "/sbin/efibootmgr") + #$vendir #$loader #$disk #$plan)))))) diff --git a/gnu/bootloader/depthcharge.scm b/gnu/bootloader/depthcharge.sc= m index 0a50374bd9..ad29f5d5e4 100644 --- a/gnu/bootloader/depthcharge.scm +++ b/gnu/bootloader/depthcharge.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright =C2=A9 2019 Timothy Sample +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,92 +18,86 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (gnu bootloader depthcharge) - #:use-module (gnu bootloader extlinux) #:use-module (gnu bootloader) #:use-module (gnu packages bootloaders) + #:use-module (gnu system boot) #:use-module (guix gexp) + #:use-module (guix deprecation) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module (guix records) #:use-module (guix utils) - #:use-module (ice-9 match) - #:export (depthcharge-bootloader)) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) + #:export (depthcharge-veyron-speedy-bootloader + depthcharge-bootloader)) =20 -(define (signed-kernel kernel kernel-arguments initrd) - (define builder - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 binary-ports) - (rnrs bytevectors)) - (set-path-environment-variable "PATH" '("bin") (list #$dtc)) +(define* (install-depthcharge arch dtb + #:key bootloader-config current-boot-alterna= tive + #:allow-other-keys) + (when (not (null? (bootloader-configuration-menu-entries bootloader-conf= ig))) + (raise (formatted-message + (G_ "extra menu-entries are not supported for depthcharge!"))= )) + (with-targets (bootloader-configuration-targets bootloader-config) + ;; use 'part instead of 'disk, cause we write an image directly into a + ;; partition instead of the extra-partition disk space + (('part =3D> (disk :device)) + (match-record (boot-alternative->menu-entry current-boot-alternative) + (linux linux-arguments initrd) + #~(begin + (use-modules (ice-9 binary-ports) (rnrs bytevectors)) + (set-path-environment-variable "PATH" '("bin") (list #$dtc)) =20 - ;; TODO: These files have to be writable, so we copy them. - ;; This can probably be fixed by using a ".its" file, just - ;; be careful not to break initrd loading. - (copy-file #$kernel "zImage") - (chmod "zImage" #o755) - (copy-file (string-append (dirname #$kernel) "/lib/dtbs/" - "rk3288-veyron-speedy.dtb") - "rk3288-veyron-speedy.dtb") - (chmod "rk3288-veyron-speedy.dtb" #o644) - (copy-file #$initrd "initrd") - (chmod "initrd" #o644) + ;; TODO: These files have to be writable, so we copy them. + ;; This can probably be fixed by using a ".its" file, just + ;; be careful not to break initrd loading. + (copy-file #$linux "zImage") + (chmod "zImage" #o755) + (copy-file (string-append (dirname #$linux) "/lib/dtbs/" #$dtb) + "dtb") + (chmod "dtb" #o644) + (copy-file #$initrd "initrd") + (chmod "initrd" #o644) =20 - (invoke (string-append #$u-boot-tools "/bin/mkimage") - "-D" "-I dts -O dtb -p 2048" -=09=09 "-f" "auto" - "-A" "arm" - "-O" "linux" - "-T" "kernel" - "-C" "None" - "-d" "zImage" - "-a" "0" - "-b" "rk3288-veyron-speedy.dtb" - "-i" "initrd" -=09 "image.itb") - (call-with-output-file "bootloader.bin" - (lambda (port) - (put-bytevector port (make-bytevector 512 0)))) - (with-output-to-file "kernel-arguments" -=09 (lambda () -=09 (display (string-join (list #$@kernel-arguments))))) - (invoke (string-append #$vboot-utils "/bin/vbutil_kernel") - "--pack" #$output - "--version" "1" - "--vmlinuz" "image.itb" -=09=09 "--arch" "arm" -=09=09 "--keyblock" (string-append #$vboot-utils - "/share/vboot-utils/devkeys/= " - "kernel.keyblock") -=09=09 "--signprivate" (string-append #$vboot-utils - "/share/vboot-utils/devke= ys/" - "kernel_data_key.vbprivk"= ) - "--config" "kernel-arguments" - "--bootloader" "bootloader.bin")))) - (computed-file "vmlinux.kpart" builder)) + (invoke #+(file-append u-boot-tools "/bin/mkimage") + "-D" "-I dts -O dtb -p 2048" + "-f" "auto" ; format + "-A" #$arch ; architecture + "-O" "linux" ; os + "-T" "kernel" ; image type + "-C" "None" ; compression + "-d" "zImage" ; image data + "-a" "0" ; load address (hex) + "-b" "dtb" ; dtb for device + "-i" "initrd" ; initrd + "image.itb") + (call-with-output-file "bootloader.bin" + (lambda (port) + (put-bytevector port (make-bytevector 512 0)))) + (call-with-output-file "kernel-arguments" + (lambda (port) + (display (string-join (list #$@linux-arguments)) port))) + (invoke #+(file-append vboot-utils "/bin/vbutil_kernel") + "--version" "1" + "--vmlinuz" "image.itb" + "--arch" #$arch + "--keyblock" + #$(file-append vboot-utils + "/share/vboot-utils/devkeys/kernel.keyblock") + "--signprivate" + #$(file-append vboot-utils + "/share/vboot-utils/devkeys/kernel_data_key.vbprivk= ") + "--config" "kernel-arguments" + "--pack" "vmlinux.kpart") + (write-file-on-device "vmlinux.kpart" + (stat:size (stat "vmlinux.kpart")) + #$disk 0)))))) =20 -(define* (depthcharge-configuration-file config entries - #:key - (system (%current-system)) - (old-entries '()) - #:allow-other-keys) - (match entries - ((entry) - (let ((kernel (menu-entry-linux entry)) - (kernel-arguments (menu-entry-linux-arguments entry)) - (initrd (menu-entry-initrd entry))) - ;; XXX: Make this a symlink. - (signed-kernel kernel kernel-arguments initrd))) - (_ (error "Too many bootloader menu entries!")))) - -(define install-depthcharge - #~(lambda (bootloader device mount-point) - (let ((kpart (string-append mount-point - "/boot/depthcharge/vmlinux.kpart"))) - (write-file-on-device kpart (stat:size (stat kpart)) device 0)))) - -(define depthcharge-bootloader +(define depthcharge-veyron-speedy-bootloader (bootloader (name 'depthcharge) - (package #f) - (installer install-depthcharge) - (configuration-file "/boot/depthcharge/vmlinux.kpart") - (configuration-file-generator depthcharge-configuration-file))) + (installer (cute install-depthcharge "arm" "rk3288-veyron-speedy.dtb" + <...>)))) + +(define-deprecated/alias depthcharge-bootloader + depthcharge-veyron-speedy-bootloader) diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm index d9b6d8bf8a..c3ab6f3275 100644 --- a/gnu/bootloader/extlinux.scm +++ b/gnu/bootloader/extlinux.scm @@ -2,6 +2,7 @@ ;;; Copyright =C2=A9 2017 David Craven ;;; Copyright =C2=A9 2017 Mathieu Othacehe ;;; Copyright =C2=A9 2022 Reza Alizadeh Majd +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,112 +22,102 @@ (define-module (gnu bootloader extlinux) #:use-module (gnu bootloader) #:use-module (gnu packages bootloaders) + #:use-module (gnu system boot) #:use-module (guix gexp) + #:use-module (guix deprecation) + #:use-module (guix records) #:use-module (guix utils) - #:export (extlinux-bootloader + #:export (install-extlinux-config ; for u-boot + extlinux-bootloader + extlinux-gpt-bootloader extlinux-bootloader-gpt)) =20 -(define* (extlinux-configuration-file config entries - #:key - (system (%current-system)) - (old-entries '()) - #:allow-other-keys) - "Return the U-Boot configuration file corresponding to CONFIG, a - object, and where the store is available at STORE-F= S, a - object. OLD-ENTRIES is taken to be a list of menu entries -corresponding to old generations of the system." - - (define all-entries - (append entries (bootloader-configuration-menu-entries config))) - - (define with-fdtdir? - (bootloader-configuration-device-tree-support? config)) +=0C +;;; +;;; Config procedures. +;;; =20 - (define (menu-entry->gexp entry) - (let ((label (menu-entry-label entry)) - (kernel (menu-entry-linux entry)) - (kernel-arguments (menu-entry-linux-arguments entry)) - (initrd (menu-entry-initrd entry))) - #~(format port "LABEL ~a +(define* (install-extlinux-config #:key bootloader-config + current-boot-alternative + old-boot-alternatives + #:allow-other-keys) + "Installer for the extlinux configuration file, meant to be shared by al= l +bootloaders that use the format to specify boot options." + (match-record bootloader-config + (targets menu-entries device-tree-support? timeout) + (define (menu-entry->gexp entry) + (match-record entry (label linux linux-arguments initrd= ) + (let* ((normkern (normalize-file entry linux)) + (fdt #~(string-append "FDTDIR" (dirname #$normkern) "/lib/d= tbs"))) + #~(format port "LABEL ~a MENU LABEL ~a KERNEL ~a ~a INITRD ~a APPEND ~a -~%" - #$label #$label - #$kernel - (if #$with-fdtdir? - (string-append "FDTDIR " (dirname #$kernel) "/lib/dtbs= ") - "") - #$initrd - (string-join (list #$@kernel-arguments))))) - - (define builder - #~(call-with-output-file #$output - (lambda (port) - (let ((timeout #$(bootloader-configuration-timeout config))) - (format port "# This file was generated from your Guix configu= ration. Any changes +~%" #$label #$label #$normkern + #$(if device-tree-support? fdt "") + #$(normalize-file entry initrd) + (string-join (list #$@linux-arguments)))))) + + (let ((ents (cons (boot-alternative->menu-entry current-boot-alternati= ve) + (append menu-entries + (map boot-alternative->menu-entry old-boot-alternative= s))))) + (with-targets targets + (('extlinux =3D> (path :path)) + #~(begin (mkdir-p #$path) + (call-with-output-file #$path + (lambda (port) + (format port "\ +# This file was generated from your Guix configuration. Any changes # will be lost upon reconfiguration. UI menu.c32 MENU TITLE GNU Guix Boot Options PROMPT ~a -TIMEOUT ~a~%" - (if (> timeout 0) 1 0) - ;; timeout is expressed in 1/10s of seconds. - (* 10 timeout)) - #$@(map menu-entry->gexp all-entries) - - #$@(if (pair? old-entries) - #~((format port "~%") - #$@(map menu-entry->gexp old-entries) - (format port "~%")) - #~()))))) - - (computed-file "extlinux.conf" builder - #:options '(#:local-build? #t - #:substitutable? #f))) - +TIMEOUT ~a~%" ;; timeout is expressed in tenths of a second + #$(if (> timeout 0) 1 0) #$(* 10 timeout)) + #$@(map menu-entry->gexp ents))))))))) =20 =0C - ;;; -;;; Install procedures. +;;; Install procedure. ;;; =20 (define (install-extlinux mbr) - #~(lambda (bootloader device mount-point) - (let ((extlinux (string-append bootloader "/sbin/extlinux")) - (install-dir (string-append mount-point "/boot/extlinux")) - (syslinux-dir (string-append bootloader "/share/syslinux"))) - (for-each (lambda (file) - (install-file file install-dir)) - (find-files syslinux-dir "\\.c32$")) - (invoke/quiet extlinux "--install" install-dir) - (write-file-on-device (string-append syslinux-dir "/" #$mbr) - 440 device 0)))) - -(define install-extlinux-mbr - (install-extlinux "mbr.bin")) + (lambda* (#:key bootloader-config #:allow-other-keys . args) + (with-targets (bootloader-configuration-targets bootloader-config) + (('extlinux =3D> (path :path)) + #~(begin + #$(apply install-extlinux-config args) + (copy-recursively #$(file-append syslinux "/share/syslinux") #$= path) + (invoke/quiet #+(file-append syslinux "/sbin/extlinux") + "--install" #$path))) + (('disk =3D> (disk :device)) + #~(write-file-on-device #$(file-append syslinux "/share/syslinux/" = mbr) + 440 #$disk 0))))) =20 -(define install-extlinux-gpt - (install-extlinux "gptmbr.bin")) =20 =0C - ;;; ;;; Bootloader definitions. ;;; =20 (define extlinux-bootloader (bootloader - (name 'extlinux) - (package syslinux) - (installer install-extlinux-mbr) - (configuration-file "/boot/extlinux/extlinux.conf") - (configuration-file-generator extlinux-configuration-file))) - -(define extlinux-bootloader-gpt + (name 'extlinux) + (default-targets (list (bootloader-target + (type 'install) + (offset 'root) + (path "boot")) + (bootloader-target + (type 'extlinux) + (offset 'install) + (path "extlinux")))) + (installer (install-extlinux "mbr.bin")))) + +(define extlinux-gpt-bootloader (bootloader - (inherit extlinux-bootloader) - (installer install-extlinux-gpt))) + (inherit extlinux-bootloader) + (installer (install-extlinux "gptmbr.bin")))) + +(define-deprecated/alias extlinux-bootloader-gpt extlinux-gpt-bootloader) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index 2723eda5f4..71fcc90ec7 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -10,6 +10,7 @@ ;;; Copyright =C2=A9 2022 Karl Hallsby ;;; Copyright =C2=A9 2022 Denis 'GNUtoo' Carikli ;;; Copyright =C2=A9 2024 Tomas Volf <~@wolfsden.cz> +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,24 +28,26 @@ ;;; along with GNU Guix. If not, see . =20 (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 +56,109 @@ (define-module (gnu bootloader grub) grub-theme-color-highlight grub-theme-gfxmode =20 - 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-efi-netboot-removable-bootloader)) =20 - grub-configuration)) - -;;; Commentary: +=0C ;;; -;;; Configuration of GNU GRUB. +;;; General utils. ;;; -;;; Code: =20 -(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." +;; in-gexp procedure to sanitize a value to be inserted into a GRUB script +(define (sanitize str) + "Sanitize a value for use in a GRUB script." + #~(let* ((glycerin (lambda (l r) (if (pair? l) (append l r) (cons l r)))= ) + (isopropyl (lambda (c) (case c ((#\\ #\$ #\") '(#\\ ,c)) (else = c))))) + (use-modules (srfi srfi-1)) + (list->string (fold-right glycerin '() + (map isopropyl (string->list #$str)))))) =20 - (define (strip-mount-point mount-point file) - (if mount-point - (if (string=3D? mount-point "/") - file - #~(let ((file #$file)) - (if (string-prefix? #$mount-point file) - (substring #$file #$(string-length mount-point)) - file))) - file)) =20 - (define (prepend-store-directory-prefix store-directory-prefix file) - (if store-directory-prefix - #~(string-append #$store-directory-prefix #$file) - file)) =20 - (prepend-store-directory-prefix store-directory-prefix - (strip-mount-point mount-point file))) +(define (grub-format type 32?) + (string-append + (cond ((string-prefix? "pc" type) "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))))= )) + "-" type)) =20 =20 =20 +(define* (search/target type targets var #:optional (port #f)) + "Returns a gexp of a GRUB search command for target TYPE, storing the re= sult +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 =3D> (path :devpath) (device :device) (fs :fs) + (label :label) (uuid :uuid)) + (cond ((member fs '("tftp" "nfs")) #~(format #$port "set ~a=3Dtftp~%"= #$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 FIL= E, +a gexp. The result is a gexp that can be inserted in the grub.cfg-generat= ion +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) #$v= ar)) + ((? 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=3Dtftp~%" #$var)) + ((or #f (? string?)) + #~(format #$port "search.file \"~a\" ~a~%" #$(sanitize file) #$var)))= ) + + + +=0C +;;; +;;; Theming. +;;; + (define-record-type* ;; Default theme contributed by Felipe L=C3=B3pez. - 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,128 +171,274 @@ (define-record-type* (gfxmode grub-theme-gfxmode (default '("auto")))) ;list of string =20 +(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)))) + + + =0C ;;; -;;; Background image & themes. +;;; Core config. +;;; GRUB architecture works by having a bootstage load up a core.img, whic= h then +;;; sets the root and prefix variables, allowing grub to load its main con= fig +;;; 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 u= p a +;;; minimal core.img capable of finding the user-configured 'install targe= t to +;;; load its config from there. ;;; =20 -(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 fo= und. -If the suffix of the image file is \".svg\", then it is converted into a P= NG -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' p= art -concerned with graphics mode, background images, colors, and all that. -STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POIN= T is -its mount point; these are used to determine where the background image an= d -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 " +(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=3D> + (with-targets targets + (('install =3D> (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=3D($root)~a\"~%" #$(sanitize path)= ))))) + (cut computed-file "core.cfg" <>))) + + + +;; TODO: do we need LVM support here? +(define* (core.img grub format #:key bootloader-config store-crypto-device= s + #:allow-other-keys) + "The core image for GRUB, built for FORMAT." + (let* ((targets (bootloader-configuration-targets bootloader-config)) + (bios? (string-prefix? format "pc")) + (efi? (string=3D? format "efi")) + (32? (bootloader-configuration-32bit? bootloader-config)) + (cfg (core.cfg targets store-crypto-devices))) + (and cfg + (and=3D> + (with-targets targets + (('install =3D> (fs :fs)) + (let ((tftp? (or (string=3D? fs "tftp") (string=3D? fs "nfs")))= ) + (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 f= ormat + "--format" #$(string-append (grub-format format 32?) + (if (and bios? tftp?) "-pxe" "")) + "--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")) '("ex= t2")) + ((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_u= uid")) + ((use "search.fs_label") '("search_lab= el")) + ((use "search.file") '("search_fs_file= ")) + (else '())))))))))))) + (cut computed-file "core.img" <> + #:options '(#:local-build? #t #:substitutable? #f)))))) + + + +=0C +;;; +;;; Main config. +;;; This is what does the heavy lifting after core.img finds it. +;;; + +(define (menu-entry->gexp store extra-initrd port) + (lambda (entry) + (match-record entry + (label device linux linux-arguments initrd + multiboot-kernel multiboot-arguments multiboot-modules chain-loader= ) + (let ((norm (compose sanitize (cut normalize-file entry <>)))) + #~(begin + (format #$port "menuentry ~s {~% " #$label) + #$(search/menu-entry + device (or linux multiboot-kernel chain-loader) "boot" por= t) + #$@(cond + (linux + (list #~(format #$port " linux \"($boot)~a\" ~a~%" + #$(norm linux) + ;; grub passes rest of the line _verbat= im_ + (string-join (list #$@linux-arguments))= ) + #~(format #$port " initrd ~a \"($boot)~a\"~%" + (if #$extra-initrd (string-append "($boot)\"" + (norm #$extra-initrd) "\= "") + "") + #$(norm initrd)))) + ;; previously, this provided a (wrong) root=3D argument. = just + ;; don't bother anymore. better less info than wrong info + (multiboot-kernel + (cons #~(format #$port " multiboot \"($boot)~a\" ~a~%" + #$(norm multiboot-kernel) + (string-join (list #$@multiboot-argumen= ts))) + (map (lambda (mod) #~(format port " module \"($boot)= ~a\"~%" + #$(norm mod))) + multiboot-modules))) + (chain-loader + (list #~(format #$port " chainloader \"~a\"~%" + #$(norm chain-loader))))) + (format #$port "}~%")))))) + + + +(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. Expects locales, ke= ymap, +and theme image at LOCALES-TARG, KEYMAP-TARG, and IMAGE-TARG, respectively= ." + (match-record bootloader-config + ;; can't match keyboard-layout here cause it's bound to its struct + (targets menu-entries default-entry timeout extra-initrd + theme terminal-outputs terminal-inputs serial-unit serial-speed) + (let* ((entry->gexp (menu-entry->gexp store-directory-prefix + extra-initrd #~port)) + (terms->str (compose string-join (cut map symbol->string <>))) + (colors->str (lambda (c) (format #f "~a/~a" (assoc-ref c 'fg) + (assoc-ref c 'bg)))= ) + (outputs (or terminal-outputs '(gfxterm))) ; set default outs + (inputs (or terminal-inputs '())) ; set default ins + (theme (or theme (grub-theme)))) + (and=3D> + (with-targets targets + (('install =3D> (install :devpath)) + #~(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~%") + #$@(filter ->bool + (list + ;; menu settings + (and default-entry + #~(format port "set default=3D~a~%" #$default-en= try)) + (and timeout + #~(format port "set timeout=3D~a~%" #$timeout)) + ;; gfxterm setup + (and (memq 'gfxterm outputs) + #~(format port "\ if loadfont unicode; then set gfxmode=3D~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 - +fi~%" #$(string-join (grub-theme-gfxmode theme) ";= "))) + ;; io + (and (or serial-unit serial-speed) + #~(format port "serial --unit=3D~a --speed=3D~a~= %" + ;; documented defaults are unit 0 at 9600 ba= ud. + #$(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=3D($root)~a/locales\" +set lang=3D~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=3D~a set color_highlight=3D~a else set menu_color_normal=3Dcyan/blue - set menu_color_highlight=3Dwhite/blue -fi~%" - #$(grub-root-search store-device image) - #$(setup-gfxterm config) - #$(grub-setup-io config) + set menu_color_highlight=3Dwhiute/blue +fi~%" #$(sanitize install) + #$(colors->str color-normal) + #$(colors->str color-highlight)))))) + ;; menu entries + #$(entry->gexp + (boot-alternative->menu-entry current-boot-alternativ= e)) + #$@(map entry->gexp menu-entries) + #$@(if (pair? old-boot-alternatives) + (append (list #~(format port "submenu ~s {~%" + "GNU system, old configurations...= ")) + (map (compose entry->gexp + boot-alternative->menu-entry) + old-boot-alternatives) + (list #~(format port "}~%"))) '()) + (format port " +if [ \"${grub_platform}\" =3D=3D efi ]; then + menuentry \"Firmware setup\" { + fwsetup + } +fi~%"))))) + (cut computed-file "grub.cfg" <> + ;; Since this file is rather unique, there's no point in tryi= ng to + ;; substitute it. + #:options '(#:local-build? #t #:substitutable? #f)))))) =20 - #$image - #$(theme-colors grub-theme-color-normal) - #$(theme-colors grub-theme-color-highlight)))) =20 -=0C -;;; -;;; Configuration file. -;;; =20 -(define* (keyboard-layout-file layout - #:key - (grub grub)) +(define (keyboard-layout-file layout grub) "Process the X keyboard layout description LAYOUT, a r= ecord, 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 + (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)) @@ -243,670 +447,175 @@ (define* (keyboard-layout-file layout ;; (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 r= esult -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) (<=3D unit 3) (>=3D = unit 0)) - (string-append " --unit=3D" (number->string uni= t)) - #f) - "") - (if speed - (if (exact-integer? speed) - (string-append " --speed=3D" (number->string sp= eed)) - #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 FIL= E, -a gexp. The result is a gexp that can be inserted in the grub.cfg-generat= ion -code." - ;; Usually FILE is a file name gexp like "/gnu/store/=E2=80=A6-linux/vml= inuz", 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' comma= nd. - (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-ur= i) - ;; If the device is an NFS share, then we assume that the expecte= d - ;; file on that device (e.g. the GRUB background image or the ker= nel) - ;; 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=3D(tftp)" here even though if grub.cfg - ;; had been loaded via TFTP, Grub would have set "root=3D(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 stil= l - ;; 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=3D(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 me= nu -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 requir= ed -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 buil= t-in - ;; IDE driver ("hdX") and those understood by rumpdisk ("wd= X" - ;; 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=3Dpart:~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=3D~a -set lang=3D~a~%" - ;; Skip the search if there is an image, as it has alr= eady - ;; been performed by eye-candy and traversing the stor= e 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=3D~a -set timeout=3D~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}\" =3D=3D efi ]; then - menuentry \"Firmware setup\" { - fwsetup - } -fi~%")))) + "-o" #$output))))) + + + +(define* (grub.dir grub #:key bootloader-config locale + #:allow-other-keys . args) + "Everything what should go in GRUB's prefix, including fonts, modules, +locales, keymap, theme image, and grub.cfg." + (match-record bootloader-config + ;; can't match for keyboard-layout: identifier bound in this scope + (targets theme) + (let* ((theme (or theme (grub-theme))) + (keyboard-layout (bootloader-configuration-keyboard-layout + bootloader-config)) + (lang (and=3D> locale (compose locale-definition-source + locale-name->definition))) + (lc-mesg (and=3D> lang (cut file-append grub "/share/locale" <> + "/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 + (when (and=3D> #$lc-mesg file-exists?) + (mkdir "locales") + (symlink #$lc-mesg (string-append "locales/" #$lang ".mo")= )) + ;; keymap + #$@(filter ->bool + (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))))) =20 - ;; 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))) =20 -(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") =20 =0C - ;;; -;;; Install procedures. +;;; Installers. ;;; =20 -(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 DEVI= CE - ;; 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 a= s - ;; "Installing for i386-pc platform." - (invoke/quiet grub "--no-floppy" "--target=3Di386-pc" - "--boot-directory" install-dir - device)) - ;; When creating a disk-image, only install a font and GRUB mo= dules. - (let* ((fonts (string-append install-dir "/grub/fonts"))) - (mkdir-p fonts) - (copy-file (string-append bootloader "/share/grub/unicode.pf= 2") - (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.im= g")) - (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 t= he - ;; 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 sect= or - ;; by GRUB-BIOS-SETUP. - (copy-file boot-img "boot.img") - - ;; Install both the "boot.img" and the "core.img" files on the giv= en - ;; 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 dis= k - ;; 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 /boo= t or - ;; root partition. - (setenv "GRUB_ENABLE_CRYPTODISK" "y") - (invoke/quiet grub-install "--boot-directory" install-dir - "--bootloader-id=3DGuix" - "--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 /mn= t/point - ;; NOTE: efi-dir comes from target list of booloader configuration - ;; There is nothing useful to do when called in the context of a dis= k - ;; 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 /boo= t or - ;; root partition. - (setenv "GRUB_ENABLE_CRYPTODISK" "y") - (invoke/quiet grub-install "--boot-directory" install-dir - "--removable" - ;; "--no-nvram" - "--bootloader-id=3DGuix" - "--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 dis= k - ;; 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 /boo= t or - ;; root partition. - (setenv "GRUB_ENABLE_CRYPTODISK" "y") - (invoke/quiet grub-install "--boot-directory" install-dir - "--bootloader-id=3DGuix" -=09=09=09(cond ((target-x86?) "--target=3Di386-efi") - ((target-arm?) "--target=3Darm-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 ex= pects -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 profi= le) -into the bootloader-target directory. - -Additionally for network booting over TFTP, two relative symlinks to the s= tore -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 configur= ation -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-install= ed -grub-efi-netboot package with a SUBDIR like efi/boot or efi/Guix, below th= e -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\")) - =E2=80=A6)) - =E2=80=A6) - -TARGET is required to be an absolute directory name, usually mounted via N= FS, -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 i= t to -load more files from the store like tftp://server/gnu/store/=E2=80=A6-linu= x=E2=80=A6/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 f= rom -MOUNT-POINT/TARGET/%store-prefix to MOUNT-POINT/%store-prefix. - -It is important to note that these symlinks need to be relative, as the ab= solute -paths on the TFTP server side are unknown. - -It is also important to note that both symlinks will point outside the TFT= P 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 conside= red -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 t= he -underlying file-system, like FAT on an EFI System Partition (ESP), does no= t -support symlinks. In this case the MOUNT-POINT/TARGET/SUBDIR/grub.cfg wil= l 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-PO= INT, - ;; which will become the root file system. If TARGET is #f, this - ;; installer has nothing to do, as it only cares about the EFI Sys= tem - ;; 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 bel= ow - ;; 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-pref= ix))) - (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 othe= r FAT - ;; file-system, then symlinks cannot be created and are not ne= eded. - ;; 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-l= ink))) - ;; 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. Proba= bly - ;; an ESP is used. Add a script to search and load the ac= tual - ;; grub.cfg. - (let* ((probe #$(file-append grub-efi "/sbin/grub-probe")) - (port (open-pipe* OPEN_READ probe "--target=3Dfs_uu= id" - grub-cfg)) - (search-root - (match (read-line port) - ((? eof-object?) - ;; There is no UUID available. As a fallback se= arch - ;; everywhere for the grub.cfg. - (string-append "search --file --set " #$grub-cf= g)) - (fs-uuid - ;; The UUID to load the grub.cfg from is known. - (string-append "search --fs-uuid --set " fs-uui= d)))) - (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 =3D> (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 =3D> (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/" devi= ce) + #$device)))))) + +(define* (install-grub-efi #:key bootloader-config #:allow-other-keys . ar= gs) + "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")= ))))) + =20 -=0C =20 +=0C ;;; -;;; Bootloader definitions. +;;; Bootloaders. ;;; -;;; For all these grub-bootloader variables the path to /boot/grub/grub.cf= g -;;; is fixed. Inheriting and overwriting the field 'configuration-file' w= ill -;;; 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")))) =20 (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)))) =20 (define grub-minimal-bootloader (bootloader - (inherit grub-bootloader) - (package grub-minimal))) + (name 'grub) + (default-targets %grub-default-targets) + (installer (install-grub-bios grub-minimal)))) =20 (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 (cons (bootloader-target + (type 'vendir) + (offset 'esp) + (path "EFI/Guix")) + %grub-default-targets)) + (installer install-grub-efi))) =20 -(define grub-efi32-bootloader - (bootloader - (inherit grub-efi-bootloader) - (installer install-grub-efi32) - (name 'grub-efi32) - (package grub-efi32))) =20 -(define (make-grub-efi-netboot-bootloader name subdir) - (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 - (bootloader - (inherit grub-efi-bootloader) - (package grub-hybrid))) =20 =0C ;;; -;;; Compatibility macros. +;;; deprecated shit! +;;; use the bootloader-config flags instead! or, in the case of netboot, s= et +;;; your 'install (or parent thereof) target fs to be "tftp" or "nfs" ;;; =20 -(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-installer installer removable? 32?) + (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 (deprecated-installer install-grub-efi #t #f)))) + +(define-deprecated grub-efi32-bootloader grub-efi-bootloader + (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) + (default-targets %netboot-targets))) + +(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/bootloader/u-boot.scm b/gnu/bootloader/u-boot.scm index c5437a7b63..7d3e202f8c 100644 --- a/gnu/bootloader/u-boot.scm +++ b/gnu/bootloader/u-boot.scm @@ -7,6 +7,7 @@ ;;; Copyright =C2=A9 2023 Efraim Flashner ;;; Copyright =C2=A9 2023 Herman Rimm ;;; Copyright =C2=A9 2024 Zheng Junjie <873216071@qq.com> +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,12 +25,11 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (gnu bootloader u-boot) - #:use-module (gnu bootloader extlinux) #:use-module (gnu bootloader) + #:use-module (gnu bootloader extlinux) #:use-module (gnu packages bootloaders) #:use-module (guix gexp) - #:export (u-boot-bootloader - u-boot-a20-olinuxino-lime-bootloader + #:export (u-boot-a20-olinuxino-lime-bootloader u-boot-a20-olinuxino-lime2-bootloader u-boot-a20-olinuxino-micro-bootloader u-boot-bananapi-m2-ultra-bootloader @@ -53,301 +53,172 @@ (define-module (gnu bootloader u-boot) u-boot-ts7970-q-2g-1000mhz-c-bootloader u-boot-wandboard-bootloader)) =20 -(define install-u-boot - #~(lambda (bootloader root-index image) - (if bootloader - (error "Failed to install U-Boot")))) +(define (make-install-u-boot firmware installers) + (lambda* (#:key bootloader-config #:allow-other-keys . args) + (with-targets (bootloader-configuration-targets bootloader-config) + ('extlinux (apply install-extlinux-config args)) + (('install =3D> (path :path)) #~(let ((path #$path) #$firmware))) + (('disk =3D> (disk :device)) #~(let ((disk #$disk)) #f #$@installers= ))))) + +(define-syntax-rule (define-u-bootloader def-name package firmware + (file size doffset) ...) + "Defines a u-boot installer DEF-NAME, using u-boot PACKAGE. Installs eac= h +given FILE of SIZE (or #f to autodetect) to the targetted disk at OFFSET. +FIRMWARE is ran on the u-boot firmware directory for installation of suppo= rting +files, with the variable path set to the dir path." + (define def-name + (bootloader + (name 'u-boot) + (default-targets (list (bootloader-target + (type 'install) + (offset 'root) + (path "boot")) + (bootloader-target + (type 'extlinux) + (offset 'install) + (path "extlinux")))) + (installer (make-install-u-boot firmware + (list #~(let ((fw #$(file-append package "/libexec/" fi= le))) + (write-file-on-device fw + #$(or size #~(stat:size (stat fw))) + disk #$doffset)) ...)))))) + +=0C +;;; +;;; Bootloader definitions. +;;; =20 -(define install-beaglebone-black-u-boot +(define-u-bootloader u-boot-beaglebone-black-bootloader + u-boot-am335x-boneblack #f ;; http://wiki.beyondlogic.org/index.php?title=3DBeagleBoneBlack_Upgradi= ng_uBoot ;; This first stage bootloader called MLO (U-Boot SPL) is expected at ;; 0x20000 by BBB ROM code. The second stage bootloader will be loaded b= y ;; the MLO and is expected at 0x60000. Write both first stage ("MLO") a= nd - ;; second stage ("u-boot.img") images, read in BOOTLOADER directory, to = the - ;; specified DEVICE. - #~(lambda (bootloader root-index image) - (let ((mlo (string-append bootloader "/libexec/MLO")) - (u-boot (string-append bootloader "/libexec/u-boot.img"))) - (write-file-on-device mlo (* 256 512) - image (* 256 512)) - (write-file-on-device u-boot (* 1024 512) - image (* 768 512))))) - -(define install-allwinner-u-boot - #~(lambda (bootloader root-index image) - (let ((u-boot (string-append bootloader - "/libexec/u-boot-sunxi-with-spl.bin"))) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 8 1024))))) - -(define install-allwinner64-u-boot - #~(lambda (bootloader root-index image) - (let ((spl (string-append bootloader "/libexec/u-boot-sunxi-with-spl= .bin")) - (u-boot (string-append bootloader "/libexec/u-boot-sunxi-with-= spl.fit.itb"))) - (write-file-on-device spl (stat:size (stat spl)) - image (* 8 1024)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 40 1024))))) - -(define install-imx-u-boot - #~(lambda (bootloader root-index image) - (let ((spl (string-append bootloader "/libexec/SPL")) - (u-boot (string-append bootloader "/libexec/u-boot.img"))) - (write-file-on-device spl (stat:size (stat spl)) - image (* 1 1024)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 69 1024))))) - -(define install-orangepi-r1-plus-lts-rk3328-u-boot - #~(lambda (bootloader root-index image) - (let ((idb (string-append bootloader "/libexec/idbloader.img")) - (u-boot (string-append bootloader "/libexec/u-boot.itb"))) - (write-file-on-device idb (stat:size (stat idb)) - image (* 64 512)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 16384 512))))) - -(define install-puma-rk3399-u-boot - #~(lambda (bootloader root-index image) - (let ((spl (string-append bootloader "/libexec/idbloader.img")) - (u-boot (string-append bootloader "/libexec/u-boot.itb"))) - (write-file-on-device spl (stat:size (stat spl)) - image (* 64 512)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 512 512))))) - -(define install-firefly-rk3399-u-boot - #~(lambda (bootloader root-index image) - (let ((idb (string-append bootloader "/libexec/idbloader.img")) - (u-boot (string-append bootloader "/libexec/u-boot.itb"))) - (write-file-on-device idb (stat:size (stat idb)) - image (* 64 512)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 16384 512))))) - -(define install-rock64-rk3328-u-boot - #~(lambda (bootloader root-index image) - (let ((idb (string-append bootloader "/libexec/idbloader.img")) - (u-boot (string-append bootloader "/libexec/u-boot.itb"))) - (write-file-on-device idb (stat:size (stat idb)) - image (* 64 512)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 16384 512))))) - -(define install-rockpro64-rk3399-u-boot - #~(lambda (bootloader root-index image) - (let ((idb (string-append bootloader "/libexec/idbloader.img")) - (u-boot (string-append bootloader "/libexec/u-boot.itb"))) - (write-file-on-device idb (stat:size (stat idb)) - image (* 64 512)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 16384 512))))) - -(define install-pinebook-pro-rk3399-u-boot install-rockpro64-rk3399-u-boot= ) - -(define install-u-boot-ts7970-q-2g-1000mhz-c-u-boot - #~(lambda (bootloader device mount-point) - (let ((u-boot.imx (string-append bootloader "/libexec/u-boot.imx")) - (install-dir (string-append mount-point "/boot"))) - (install-file u-boot.imx install-dir)))) - -(define install-sifive-unmatched-u-boot - #~(lambda (bootloader root-index image) - (let ((spl (string-append bootloader "/libexec/spl/u-boot-spl.bin")) - (u-boot (string-append bootloader "/libexec/u-boot.itb"))) - (write-file-on-device spl (stat:size (stat spl)) - image (* 34 512)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 2082 512))))) - -(define install-starfive-visionfive2-u-boot - #~(lambda (bootloader root-index image) - (let ((spl (string-append - bootloader "/libexec/spl/u-boot-spl.bin.normal.out")) - (u-boot (string-append bootloader "/libexec/u-boot.itb"))) - (write-file-on-device spl (stat:size (stat spl)) - image (* 34 512)) - (write-file-on-device u-boot (stat:size (stat u-boot)) - image (* 2082 512))))) - -(define install-starfive-visionfive2-uEnv.txt - #~(lambda (bootloader device mount-point) - (mkdir-p (string-append mount-point "/boot")) - (call-with-output-file (string-append mount-point "/boot/uEnv.txt") + ;; second stage ("u-boot.img") images to the target. + ("MLO" (* 256 512) (* 256 512)) + ("u-boot.img" (* 1024 512) (* 768 512))) + +(define-u-bootloader u-boot-sifive-unmatched-bootloader + u-boot-sifive-unmatched #f + ("spl/u-boot-spl.bin" #f (* 34 512)) + ("u-boot.itb" #f (* 2082 512))) + +(define-u-bootloader u-boot-starfive-visionfive2-bootloader + u-boot-starfive-visionfive2 + #~(begin (mkdir-p path) + (call-with-output-file (string-append path "/uEnv.txt") (lambda (port) (format port - ;; if board SPI use vender's u-boot, will find - ;; ""starfive/starfive_visionfive2.dtb"", We cannot guar= antee - ;; that users will update this u-boot, so set it. - "fdtfile=3Dstarfive/jh7110-starfive-visionfive-2-v1.3b.d= tb~%"))))) + ;; if board SPI use vender's u-boot, will find + ;; ""starfive/starfive_visionfive2.dtb"", We cannot guarantee + ;; that users will update this u-boot, so set it. + "fdtfile=3Dstarfive/jh7110-starfive-visionfive-2-v1.3b.dtb~%")= ))) + ("spl/u-boot-spl.bin.normal.out" #f (* 34 512)) + ("u-boot.itb" #f (* 2082 512))) + +=0C +;;; +;;; Allwinner bootloader definitions. +;;; +(define-syntax-rule (define-u-bootloader-allwinner def-name package) + (define-u-bootloader def-name package #f + ("u-boot-sunxi-with-spl.bin" #f (* 8 1024)))) + =20 -(define install-qemu-riscv64-u-boot - #~(lambda (bootloader device mount-point) - (let ((u-boot.bin (string-append bootloader "/libexec/u-boot.bin")) - (install-dir (string-append mount-point "/boot"))) - (install-file u-boot.bin install-dir)))) +(define-u-bootloader-allwinner u-boot-nintendo-nes-classic-edition-bootloa= der + u-boot-nintendo-nes-classic-edition) + +(define-u-bootloader-allwinner u-boot-a20-olinuxino-lime-bootloader + u-boot-a20-olinuxino-lime) + +(define-u-bootloader-allwinner u-boot-a20-olinuxino-lime2-bootloader + u-boot-a20-olinuxino-lime2) + +(define-u-bootloader-allwinner u-boot-a20-olinuxino-micro-bootloader + u-boot-a20-olinuxino-micro) + +(define-u-bootloader-allwinner u-boot-bananapi-m2-ultra-bootloader + u-boot-bananapi-m2-ultra) + +(define-u-bootloader-allwinner u-boot-cubietruck-bootloader u-boot-cubietr= uck) + +(define-u-bootloader-allwinner u-boot-pine64-lts-bootloader u-boot-pine64-= lts) =20 =0C +;;; +;;; Allwinner64 bootloader definitions. +;;; +(define-syntax-rule (define-u-bootloader-allwinner64 def-name package) + (define-u-bootloader def-name package #f + ("u-boot-sunxi-with-spl.bin" #f (* 8 1024)) + ("u-boot-sunxi-with-spl.fit.itb" #f (* 40 1024)))) + + +(define-u-bootloader-allwinner64 u-boot-pine64-plus-bootloader + u-boot-pine64-plus) + +(define-u-bootloader-allwinner64 u-boot-pinebook-bootloader u-boot-pineboo= k) =20 +=0C ;;; -;;; Bootloader definitions. +;;; IMX bootloader definitions. ;;; +(define-syntax-rule (define-u-bootloader-imx def-name package) + (define-u-bootloader def-name package #f + ("SPL" #f (* 8 1024)) + ("u-boot.img" #f (* 40 1024)))) =20 -(define u-boot-bootloader - (bootloader - (inherit extlinux-bootloader) - (name 'u-boot) - (package #f) - (installer #f) - (disk-image-installer install-u-boot))) - -(define u-boot-beaglebone-black-bootloader - (bootloader - (inherit u-boot-bootloader) - (package u-boot-am335x-boneblack) - (disk-image-installer install-beaglebone-black-u-boot))) - -(define u-boot-allwinner-bootloader - (bootloader - (inherit u-boot-bootloader) - (disk-image-installer install-allwinner-u-boot))) - -(define u-boot-allwinner64-bootloader - (bootloader - (inherit u-boot-bootloader) - (disk-image-installer install-allwinner64-u-boot))) - -(define u-boot-imx-bootloader - (bootloader - (inherit u-boot-bootloader) - (disk-image-installer install-imx-u-boot))) - -(define u-boot-nintendo-nes-classic-edition-bootloader - (bootloader - (inherit u-boot-allwinner-bootloader) - (package u-boot-nintendo-nes-classic-edition))) - -(define u-boot-a20-olinuxino-lime-bootloader - (bootloader - (inherit u-boot-allwinner-bootloader) - (package u-boot-a20-olinuxino-lime))) - -(define u-boot-a20-olinuxino-lime2-bootloader - (bootloader - (inherit u-boot-allwinner-bootloader) - (package u-boot-a20-olinuxino-lime2))) - -(define u-boot-a20-olinuxino-micro-bootloader - (bootloader - (inherit u-boot-allwinner-bootloader) - (package u-boot-a20-olinuxino-micro))) - -(define u-boot-bananapi-m2-ultra-bootloader - (bootloader - (inherit u-boot-allwinner-bootloader) - (package u-boot-bananapi-m2-ultra))) - -(define u-boot-cubietruck-bootloader - (bootloader - (inherit u-boot-allwinner-bootloader) - (package u-boot-cubietruck))) - -(define u-boot-firefly-rk3399-bootloader - ;; SD and eMMC use the same format - (bootloader - (inherit u-boot-bootloader) - (package u-boot-firefly-rk3399) - (disk-image-installer install-firefly-rk3399-u-boot))) - -(define u-boot-mx6cuboxi-bootloader - (bootloader - (inherit u-boot-imx-bootloader) - (package u-boot-mx6cuboxi))) - -(define u-boot-wandboard-bootloader - (bootloader - (inherit u-boot-imx-bootloader) - (package u-boot-wandboard))) - -(define u-boot-novena-bootloader - (bootloader - (inherit u-boot-imx-bootloader) - (package u-boot-novena))) - -(define u-boot-orangepi-r1-plus-lts-rk3328-bootloader - (bootloader - (inherit u-boot-bootloader) - (package u-boot-orangepi-r1-plus-lts-rk3328) - (disk-image-installer install-orangepi-r1-plus-lts-rk3328-u-boot))) - -(define u-boot-pine64-plus-bootloader - (bootloader - (inherit u-boot-allwinner64-bootloader) - (package u-boot-pine64-plus))) - -(define u-boot-pine64-lts-bootloader - (bootloader - (inherit u-boot-allwinner-bootloader) - (package u-boot-pine64-lts))) - -(define u-boot-pinebook-bootloader - (bootloader - (inherit u-boot-allwinner64-bootloader) - (package u-boot-pinebook))) - -(define u-boot-puma-rk3399-bootloader - (bootloader - (inherit u-boot-bootloader) - (package u-boot-puma-rk3399) - (disk-image-installer install-puma-rk3399-u-boot))) - -(define u-boot-rock64-rk3328-bootloader - ;; SD and eMMC use the same format - (bootloader - (inherit u-boot-bootloader) - (package u-boot-rock64-rk3328) - (disk-image-installer install-rock64-rk3328-u-boot))) =20 -(define u-boot-rockpro64-rk3399-bootloader - ;; SD and eMMC use the same format - (bootloader - (inherit u-boot-bootloader) - (package u-boot-rockpro64-rk3399) - (disk-image-installer install-rockpro64-rk3399-u-boot))) +(define-u-bootloader-imx u-boot-mx6cuboxi-bootloader u-boot-mx6cuboxi) + +(define-u-bootloader-imx u-boot-wandboard-bootloader u-boot-wandboard) =20 -(define u-boot-pinebook-pro-rk3399-bootloader +(define-u-bootloader-imx u-boot-novena-bootloader u-boot-novena) + +=0C +;;; +;;; Rockchip bootloader definitions. +;;; +(define-syntax-rule (define-u-bootloader-rockchip def-name package) ;; SD and eMMC use the same format - (bootloader - (inherit u-boot-bootloader) - (package u-boot-pinebook-pro-rk3399) - (disk-image-installer install-pinebook-pro-rk3399-u-boot))) - -(define u-boot-ts7970-q-2g-1000mhz-c-bootloader - ;; This bootloader doesn't really need to be installed, as it is read fr= om - ;; an SPI memory chip, not the SD card. It is copied to /boot/u-boot.im= x - ;; for convenience and should be manually flashed at the U-Boot prompt. - (bootloader - (inherit u-boot-bootloader) - (package u-boot-ts7970-q-2g-1000mhz-c) - (installer install-u-boot-ts7970-q-2g-1000mhz-c-u-boot) - (disk-image-installer #f))) - -(define u-boot-sifive-unmatched-bootloader - (bootloader - (inherit u-boot-bootloader) - (package u-boot-sifive-unmatched) - (disk-image-installer install-sifive-unmatched-u-boot))) - -(define u-boot-starfive-visionfive2-bootloader - (bootloader - (inherit u-boot-bootloader) - (package u-boot-starfive-visionfive2) - (installer install-starfive-visionfive2-uEnv.txt) - (disk-image-installer install-starfive-visionfive2-u-boot))) - -(define u-boot-qemu-riscv64-bootloader - (bootloader - (inherit u-boot-bootloader) - (package u-boot-qemu-riscv64) - (installer install-qemu-riscv64-u-boot) - (disk-image-installer #f))) + (define-u-bootloader def-name package #f + ("idbloader.img" #f (* 64 512)) + ("u-boot.itb" #f (* 16384 512)))) + +(define-u-bootloader-rockchip u-boot-firefly-rk3399-bootloader + u-boot-firefly-rk3399) + +(define-u-bootloader-rockchip u-boot-orangepi-r1-plus-lts-rk3328-bootloade= r + u-boot-orangepi-r1-plus-lts-rk3328) + +(define-u-bootloader-rockchip u-boot-rock64-rk3328-bootloader + u-boot-rock64-rk3328) + +(define-u-bootloader-rockchip u-boot-rockpro64-rk3399-bootloader + u-boot-rockpro64-rk3399) + +(define-u-bootloader-rockchip u-boot-pinebook-pro-rk3399-bootloader + u-boot-pinebook-pro-rk3399) + +(define-u-bootloader u-boot-puma-rk3399-bootloader u-boot-puma-rk3399 #f + ("idbloader.img" #f (* 64 512)) + ("u-boot.itb" #f (* 512 512))) + +=0C +;;; +;;; Copy-only bootloader definitions. +;;; + +;; These bootloaders don't really need to be installed, as they are read f= rom +;; an SPI memory chip or directly from the FS, not the disk. +(define-syntax-rule (define-u-bootloader-copy def-name package file) + (define-u-bootloader def-name package + #~(install-file #$(file-append package "/libexec/" file) path))) + +;; user should manually install this to SPI flash +;; TODO: write directly to SPI flash? unless wear issues are a problem. +(define-u-bootloader-copy u-boot-ts7970-q-2g-1000mhz-c-bootloader + u-boot-ts7970-q-2g-1000mhz-c "u-boot.imx") + +(define-u-bootloader-copy u-boot-qemu-riscv64-bootloader + u-boot-qemu-riscv64 "u-boot.bin") diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm index af6063a884..b59287d759 100644 --- a/gnu/build/bootloader.scm +++ b/gnu/build/bootloader.scm @@ -3,6 +3,7 @@ ;;; Copyright =C2=A9 2019 Ludovic Court=C3=A8s ;;; Copyright =C2=A9 2022 Denis 'GNUtoo' Carikli ;;; Copyright =C2=A9 2022 Timothy Sample +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,20 +21,45 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (gnu build bootloader) + #:autoload (guix build syscalls) (free-disk-space) #:use-module (guix build utils) - #:use-module (guix utils) - #:use-module (ice-9 binary-ports) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) #:use-module (rnrs io ports) #:use-module (rnrs io simple) - #:export (write-file-on-device - install-efi-loader)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) + #:export (atomic-copy + in-temporary-directory + write-file-on-device + install-efi)) =20 =0C ;;; ;;; Writing utils. ;;; =20 +(define (atomic-copy from to) + (let ((pivot (string-append to ".new"))) + (copy-file from pivot) + (rename-file pivot to))) + +(define-syntax-rule (in-temporary-directory block ...) + "Run blocks... while chdir'd into a temporary directory." + ;; mkdtemp under POSIX.1-2008 must make the dir with 700 perms + (let* ((tmp (or (getenv "TMPDIR") "/tmp")) + (dir (mkdtemp (string-append tmp "/guix-bootloader.XXXXXX"))) + (cwd (getcwd))) + (dynamic-wind (lambda () (chdir dir)) + (lambda () block ...) + (lambda () (chdir cwd) (delete-file-recursively dir))))) + (define (write-file-on-device file size device offset) "Write SIZE bytes from FILE to DEVICE starting at OFFSET." (call-with-input-file file @@ -56,57 +82,78 @@ (define (write-file-on-device file size device offset) ;;; EFI bootloader. ;;; =20 -(define* (install-efi grub grub-config esp #:key targets) - "Write a self-contained GRUB EFI loader to the mounted ESP using -GRUB-CONFIG. - -If TARGETS is set, use its car as the GRUB image format and its cdr as -the output filename. Otherwise, use defaults for the host platform." - (let* ((system %host-type) - ;; Hard code the output location to a well-known path recognized = by - ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviou= r": - ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%= 202_6.pdf - (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone")) - (efi-directory (string-append esp "/EFI/BOOT")) - ;; Map grub target names to boot file names. - (efi-targets (or targets - (cond ((string-prefix? "x86_64" system) - '("x86_64-efi" . "BOOTX64.EFI")) - ((string-prefix? "i686" system) - '("i386-efi" . "BOOTIA32.EFI")) - ((string-prefix? "armhf" system) - '("arm-efi" . "BOOTARM.EFI")) - ((string-prefix? "aarch64" system) - '("arm64-efi" . "BOOTAA64.EFI")))))) - ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image. - (setenv "TMPDIR" esp) - - (mkdir-p efi-directory) - (invoke grub-mkstandalone "-O" (car efi-targets) - "-o" (string-append efi-directory "/" - (cdr efi-targets)) - ;; Graft the configuration file onto the image. - (string-append "boot/grub/grub.cfg=3D" grub-config)))) +(define parse-bootnums + (make-regexp "^Boot([0-9a-fA-F]+).*[^A-Za-z]File\\(([^)]+)\\)$" regexp/n= ewline)) =20 -(define* (install-efi-loader grub-efi esp #:key targets) - "Install in ESP directory the given GRUB-EFI bootloader. Configure it t= o -load the Grub bootloader located in the 'Guix_image' root partition. +;; XXX: parsing efibootmgr output may be kinda jank? a better way may exis= t +(define (efi-bootnums efibootmgr) + "Returns '(path . bootnum) pairs for each EFI boot entry. bootnum is a s= tring, +and path is backslash-deliminated and relative to the ESP." + (let* ((pipe (open-pipe* OPEN_READ efibootmgr)) + (text (get-string-all pipe)) + (status (status:exit-val (close-pipe pipe)))) + (unless (zero? status) + (raise-exception + (formatted-message (G_ "efibootmgr exited with error code ~a") sta= tus))) + (fold-matches parse-bootnums text '() + (lambda (match acc) + (let* ((path (match:substring match 2)) + (bootnum (match:substring match 1))) + (cons (cons path bootnum) acc)))))) =20 -If TARGETS is set, use its car as the GRUB image format and its cdr as -the output filename. Otherwise, use defaults for the host platform." - (let ((grub-config "grub.cfg")) - (call-with-output-file grub-config - (lambda (port) - ;; Create a tiny configuration file telling the embedded grub wher= e to - ;; load the real thing. XXX This is quite fragile, and can preven= t - ;; the image from booting when there's more than one volume with t= his - ;; label present. Reproducible almost-UUIDs could reduce the risk - ;; (not eliminate it). - (format port - "insmod part_msdos~@ - insmod part_gpt~@ - search --set=3Droot --label Guix_image~@ - configfile /boot/grub/grub.cfg~%"))) - (install-efi grub-efi grub-config esp #:targets targets) - (delete-file grub-config))) +(define (install-efi efibootmgr vendir loader* disk plan) + "See install-efi in (gnu bootloader)." + (let* ((loader (string-map (match-lambda (#\/ #\\) (x x)) loader*)) + (bootnums (filter (compose (cut string-prefix? loader <>) car) + (efi-bootnums efibootmgr))) + (plan-files (map cadr plan))) + (define (size file) (if (file-exists? file) (stat:size (stat file)) 0)= ) + (define (vendirof file) (string-append vendir "/" file)) + (define (loaderof file) (string-append loader "\\" file)) + (define (delete-boot num file) + (invoke efibootmgr "--quiet" "--bootnum" num "--delete-bootnum") + (when (file-exists? file) (delete-file file))) =20 + (mkdir-p vendir) + ;; delete old entries first, to clear up space + (for-each (lambda (spec) ; '(path . bootnum) + (let* ((s (substring (car spec) (string-length loader))) + (file (substring s (if (string-prefix? "\\" s) 1 0)= ))) + (unless (member file plan-files) + (delete-boot (cdr spec) (vendirof file))))) + bootnums) + ;; new and updated entries + (in-temporary-directory + (for-each + (lambda (spec) + (let* ((builder (car spec)) (name (cadr spec)) + (dest (vendirof name)) (loadest (loaderof name)) + (rest (reverse (cdr (member name plan-files))))) + (builder name) ; build to a tmp file so we can check size + ;; disk space is usually limited on esps. + ;; try to clear space as we install new bootloaders. + (if (while (> (- (size name) (size dest)) (free-disk-space ven= dir)) + (let ((del (find (compose file-exists? vendirof) rest))) + (if del (delete-file (vendirof del)) (break #t)))) + (begin + (and=3D> (assoc-ref bootnums loadest) (cut delete-boot <> = dest)) + (warning (G_ "ESP too small for bootloader ~a!~%") name)) + ;; esp too small for atomic copy + (begin + (copy-file name dest) + (unless (assoc loadest bootnums) + (invoke efibootmgr "--quiet" "--create-only" + "--label" (cddr spec) "--disk" disk "--loader" loadest= )))) + (delete-file name))) + plan)) + ;; verify at least the first entry was installed + (unless (file-exists? (vendirof (cadr (car plan)))) + ;; extremely fatal error so we use leave instead of raise + (leave (G_ "not enough space in ESP to install bootloader! + SYSTEM WILL NOT BOOT UNLESS THIS IS FIXED!~%"))) + ;; boot order. recall efi-bootnums to get fresh list with new installs + ;; some UEFI systems will refuse to acknowledge the existence of boot + ;; entries unless they're in bootorder, so just shove everything in th= ere + (invoke efibootmgr "--quiet" "--bootorder" + (let ((num (cute assoc-ref (efi-bootnums efibootmgr) <>))) ; cute is= eager + (string-join (filter-map (compose num loaderof) plan-files) ",")))= )) diff --git a/gnu/build/image.scm b/gnu/build/image.scm index 49dc01c0d1..b1abc99bba 100644 --- a/gnu/build/image.scm +++ b/gnu/build/image.scm @@ -28,6 +28,7 @@ (define-module (gnu build image) #:use-module (guix build store-copy) #:use-module (guix build syscalls) #:use-module (guix build utils) + #:use-module (guix deprecation) #:use-module (guix store database) #:use-module (guix utils) #:use-module (gnu build bootloader) @@ -181,30 +182,13 @@ (define* (register-closure prefix closure #:prefix prefix #:registration-time %epoch))))) =20 -(define* (initialize-efi-partition root - #:key - grub-efi - #:allow-other-keys) - "Install in ROOT directory, an EFI loader using GRUB-EFI." - (install-efi-loader grub-efi root)) - -(define* (initialize-efi32-partition root - #:key - grub-efi32 - #:allow-other-keys) - "Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32." - (install-efi-loader grub-efi32 root - #:targets (cond ((target-x86?) - '("i386-efi" . "BOOTIA32.EFI")) - ((target-arm?) - '("arm-efi" . "BOOTARM.EFI"))))) +(define (initialize-efi-partition root . rest) + (mkdir-p (string-append root "/EFI"))) + +(define-deprecated/alias initialize-efi32-partition initialize-efi-partiti= on) =20 (define* (initialize-root-partition root #:key - bootcfg - bootcfg-location - bootloader-package - bootloader-installer (copy-closures? #t) (deduplicate? #t) references-graphs @@ -251,18 +235,10 @@ (define* (initialize-root-partition root =20 (unless copy-closures? (delete-file root-store) - (rename-file tmp-store root-store))) - - ;; There's no point installing a bootloader if we do not populate the st= ore. - (when copy-closures? - (when bootloader-installer - (display "installing bootloader...\n") - (bootloader-installer bootloader-package #f root)) - (when bootcfg - (install-boot-config bootcfg bootcfg-location root)))) + (rename-file tmp-store root-store)))) =20 (define* (make-iso9660-image xorriso grub-mkrescue-environment - grub bootcfg system-directory root target + grub grub.dir system-directory root target #:key (volume-id "Guix_image") (volume-uuid #= f) register-closures? (references-graphs '()) (compression? #t)) @@ -321,7 +297,7 @@ (define* (make-iso9660-image xorriso grub-mkrescue-envi= ronment (apply invoke grub-mkrescue (string-append "--xorriso=3D" grub-mkrescue-sed.sh) "-o" target - (string-append "boot/grub/grub.cfg=3D" bootcfg) + (string-append "boot/grub=3D" grub.dir) root "--" ;; Set all timestamps to 1. diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 0aa227b4d8..6b5435f13c 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -25,8 +25,7 @@ (define-module (gnu build install) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (install-boot-config - evaluate-populate-directive + #:export (evaluate-populate-directive populate-root-file-system install-database-and-gc-roots populate-single-profile-directory @@ -42,19 +41,6 @@ (define-module (gnu build install) ;;; ;;; Code: =20 -(define (install-boot-config bootcfg bootcfg-location mount-point) - "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note -that the caller must make sure that BOOTCFG is registered as a GC root so -that the fonts, background images, etc. referred to by BOOTCFG are not GC'= d." - (let* ((target (string-append mount-point bootcfg-location)) - (pivot (string-append target ".new"))) - (mkdir-p (dirname target)) - - ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't - ;; work when /boot is on a separate partition. Do that atomically. - (copy-file bootcfg pivot) - (rename-file pivot target))) - (define* (evaluate-populate-directive directive target #:key (default-gid 0) diff --git a/gnu/image.scm b/gnu/image.scm index 7fb06dec10..6a3251014f 100644 --- a/gnu/image.scm +++ b/gnu/image.scm @@ -35,6 +35,7 @@ (define-module (gnu image) partition-label partition-uuid partition-flags + partition-target partition-initializer =20 image @@ -131,6 +132,8 @@ (define-record-type* partition make-partiti= on (flags partition-flags (default '()) ;list of symbols (sanitize validate-partition-flags)) + (target partition-target ; bootloader target type: symbol = | #f + (default #f)) (initializer partition-initializer (default #false))) ;gexp | #false =20 diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index 51fa7cf9d9..83682ea539 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -1454,15 +1454,19 @@ (define (root-user-partition? partition) =20 (define (bootloader-configuration user-partitions) "Return the bootloader configuration field for USER-PARTITIONS." - (let* ((root-partition (find root-user-partition? - user-partitions)) + (let* ((root-partition (find root-user-partition? user-partitions)) (root-partition-disk (user-partition-disk-file-name root-partitio= n))) `((bootloader-configuration ,@(if (efi-installation?) `((bootloader grub-efi-bootloader) - (targets (list ,(default-esp-mount-point)))) + (targets (list (bootloader-target + (type 'esp) + (path ,(default-esp-mount-point)))))) `((bootloader grub-bootloader) - (targets (list ,root-partition-disk)))) + (targets (list (bootloader-target + (type 'disk) + ;; TODO: we should provide a uuid or label= here + (device ,root-partition-disk)))))) =20 ;; XXX: Assume we defined the 'keyboard-layout' field of ;; right above. diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 8dd8c342a0..4a9d3faee1 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -505,18 +505,15 @@ (define (deploy-managed-host machine) (machine-ssh-session machine) (machine-become-command machine))) =20 - (mlet %store-monad ((_ (check-deployment-sanity machine)) - (boot-alternatives (machine->boot-alternatives machi= ne))) + (mlet %store-monad ((_ (check-deployment-sanity machine))) ;; Make sure code that check %CURRENT-SYSTEM, such as ;; %BASE-INITRD-MODULES, gets to see the right value. (parameterize ((%current-system system) (%current-target-system #f)) (let* ((os (machine-operating-system machine)) (eval (cut machine-remote-eval machine <>)) - (menu-entries (map boot-parameters->menu-entry - (map boot-alternative-parameters boot-alte= rnatives))) - (bootloader-configuration (operating-system-bootloader os)) - (bootcfg (operating-system-bootcfg os menu-entries))) + (bootloader-config (operating-system-bootloader os)) + (bootmeta (operating-system-bootmeta os))) (define-syntax-rule (eval/error-handling condition handler ...) ;; Return a wrapper around EVAL such that HANDLER is evaluated i= f an ;; exception is raised. @@ -548,13 +545,15 @@ (define (deploy-managed-host machine) (inferior-exception-= arguments c))) os) - (install-bootloader (eval/error-handling c - (raise (formatted-message - (G_ "\ + (mlet %store-monad + ((boot-alternatives (machine->boot-alternatives mach= ine))) + (apply install-bootloader + (eval/error-handling c + (raise (formatted-message + (G_ "\ failed to install bootloader on '~a':~%~{~s ~}~%") - host - (inferior-exception-argument= s c)))) - bootloader-configuration bootcfg))))))= ))) + host (inferior-exception-arguments c)))) + bootloader-config boot-alternatives bootmeta)))))))))) =20 =0C ;;; @@ -585,32 +584,28 @@ (define (roll-back-managed-host machine) (define roll-back-failure (condition (&message (message (G_ "could not roll-back machine"))))) =20 - (mlet* %store-monad ((boot-alternatives (machine->boot-alternatives mach= ine)) - (_ -> (if (< (length boot-alternatives) 2) - (raise roll-back-failure))) - (chosen-alternative (second boot-alternatives)) - (parameters (boot-alternative-parameters chosen-alt= ernative)) - (entries -> (list (boot-parameters->menu-entry para= meters))) - (locale -> (boot-parameters-locale parameters)) - (crypto-dev -> (boot-parameters-store-crypto-device= s parameters)) - (store-dir -> (boot-parameters-store-directory-pref= ix parameters)) - (old-entries -> (map boot-parameters->menu-entry - (map boot-alternative-paramete= rs - (drop boot-alternatives 2= )))) - (bootloader -> (operating-system-bootloader - (machine-operating-system machine))= ) - (bootcfg (lower-object - ((bootloader-configuration-file-generator - (bootloader-configuration-bootloader - bootloader)) - bootloader entries - #:locale locale - #:store-crypto-devices crypto-dev - #:store-directory-prefix store-dir - #:old-entries old-entries))) - (remote-result (machine-remote-eval machine remote-= exp))) - (when (eqv? 'error remote-result) - (raise roll-back-failure)))) + (mlet %store-monad ((boot-alternatives (machine->boot-alternatives machi= ne))) + (when (< (length boot-alternatives) 2) (raise roll-back-failure)) + (mlet* %store-monad ((remote-result (machine-remote-eval machine remot= e-exp))) + (mwhen (eqv? 'error remote-result) + (raise roll-back-failure))) + + (mlet* %store-monad ((os -> (machine-operating-system machine)) + (chosen -> (cadr boot-alternatives)) + (alts -> (cons* chosen (car boot-alternatives) + (cddr boot-alternatives))) + (params -> (boot-alternative-parameters chosen)) + (locale -> (boot-parameters-locale chosen)) + (crypto-dev -> (boot-parameters-store-crypto-devi= ces + chosen)) + (store-pre -> (boot-parameters-store-directory-pr= efix + chosen))) + (install-bootloader (cute machine-remote-eval machine <>) + (operating-system-bootloader os) + alts + #:locale locale + #:store-crypto-devices crypto-dev + #:store-directory-prefix store-pre)))) =20 =0C ;;; diff --git a/gnu/packages/bootloaders.scm b/gnu/packages/bootloaders.scm index 4072df50d7..12f918a123 100644 --- a/gnu/packages/bootloaders.scm +++ b/gnu/packages/bootloaders.scm @@ -498,92 +498,6 @@ (define-public grub-hybrid basename)))) (scandir input-dir))))))))))) =20 -(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 direc= tory. -This package is also able to boot from local storage devices. - -A bootloader-installer basically needs to copy the package content into th= e -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 bootin= g -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 wh= ich -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 b= y - ;; 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=3D" net-dir) - (string-append "--subdir=3D" #$subdir) - ;; These modules must be pre-loaded to allow b= ooting - ;; from an ESP or a similar partition with a F= AT - ;; file system. - (string-append "--modules=3Dpart_msdos part_gp= t 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 diff --git a/gnu/packages/raspberry-pi.scm b/gnu/packages/raspberry-pi.scm index c4f03c3ed9..66f980dd79 100644 --- a/gnu/packages/raspberry-pi.scm +++ b/gnu/packages/raspberry-pi.scm @@ -19,8 +19,6 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (gnu packages raspberry-pi) - #:use-module (gnu bootloader) - #:use-module (gnu bootloader grub) #:use-module (gnu packages) #:use-module (gnu packages admin) #:use-module (gnu packages algebra) @@ -328,22 +326,6 @@ (define (make-raspi-bcm28-dtbs linux) (format #f "The device-tree files for Raspberry Pi models from ~a." (package-name linux))))) =20 -(define-public grub-efi-bootloader-chain-raspi-64 - ;; A bootloader capable to boot a Raspberry Pi over network via TFTP or = from - ;; a local storage like a micro SD card. It neither installs firmware n= or - ;; device-tree files for the Raspberry Pi. It just assumes them to be - ;; existing in boot/efi in the same way that some UEFI firmware with ACP= I - ;; data is usually assumed to be existing on PCs. It creates firmware - ;; configuration files and a bootloader-chain with U-Boot to provide an = EFI - ;; API for the final GRUB bootloader. It also serves as a blue-print to - ;; create an a custom bootloader-chain with firmware and device-tree - ;; packages or files. - (efi-bootloader-chain grub-efi-netboot-removable-bootloader - #:packages (list u-boot-rpi-arm64-efi-bin) - #:files (list %raspi-config-txt - %raspi-bcm27-dtb-txt - %raspi-u-boot-bootloader-txt))) - (define (make-raspi-defconfig arch defconfig sha256-as-base32) "Make for the architecture ARCH a file-like object from the DEFCONFIG fi= le with the hash SHA256-AS-BASE32. This object can be used as the #:defconfi= g diff --git a/gnu/system.scm b/gnu/system.scm index 4a084b2ecf..a345b52d55 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -140,10 +140,11 @@ (define-module (gnu system) =20 operating-system-derivation operating-system-profile - operating-system-bootcfg + operating-system-bootmeta operating-system-etc-directory operating-system-locale-directory operating-system-boot-script + operating-system-boot-parameters operating-system-uuid =20 operating-system-with-gc-roots @@ -171,6 +172,9 @@ (define-module (gnu system) ;;; ;;; Code: =20 +(define (convert-bootloader-field bootloader) + (if (list? bootloader) bootloader (list bootloader))) + (define-with-syntax-properties (warn-hosts-file-field-deprecation (value properties)) (when value @@ -193,7 +197,9 @@ (define-record-type* operating-syste= m (default %default-kernel-arguments)) ; list of gexps/s= trings (hurd operating-system-hurd (default #f)) ; package - (bootloader operating-system-bootloader) ; + (bootloader operating-system-bootloader ; + (default '()) + (sanitize convert-bootloader-field)) (label operating-system-label ; string (thunked) (default (operating-system-default-label this-operating-system))) @@ -1208,30 +1214,17 @@ (define (operating-system-store-file-system os) "Return the file system that contains the store of OS." (store-file-system (operating-system-file-systems os))) =20 -(define* (operating-system-bootcfg os #:optional (old-entries '())) - "Return the bootloader configuration file for OS. Use OLD-ENTRIES, -a list of , to populate the \"old entries\" menu." +(define (operating-system-bootmeta os) + "Return operating system information to be passed to the bootloader +installers." (let* ((file-systems (operating-system-file-systems os)) + (store-root (btrfs-store-subvolume-file-name file-systems)) (root-fs (operating-system-root-file-system os)) - (root-device (file-system-device root-fs)) (locale (operating-system-locale os)) - (crypto-devices (operating-system-bootloader-crypto-devices os)) - (params (operating-system-boot-parameters - os root-device - #:system-kernel-arguments? #t)) - (entry (boot-parameters->menu-entry params)) - (bootloader-conf (operating-system-bootloader os))) - - (define generate-config-file - (bootloader-configuration-file-generator - (bootloader-configuration-bootloader bootloader-conf))) - - (generate-config-file bootloader-conf (list entry) - #:old-entries old-entries - #:locale locale - #:store-crypto-devices crypto-devices - #:store-directory-prefix -=09=09=09 (btrfs-store-subvolume-file-name file-systems)))) + (crypto-devices (operating-system-bootloader-crypto-devices os))= ) + (list #:store-crypto-devices crypto-devices + #:store-directory-prefix store-root + #:locale locale))) =20 (define (operating-system-multiboot-modules os) (if (operating-system-hurd os) (hurd-multiboot-modules os) '())) @@ -1295,9 +1288,9 @@ (define* (operating-system-boot-parameters os root-de= vice (file-systems (operating-system-file-systems os)) (crypto-devices (operating-system-bootloader-crypto-devices os)) (locale (operating-system-locale os)) - (bootloader (bootloader-configuration-bootloader - (operating-system-bootloader os))) - (bootloader-name (bootloader-name bootloader)) + (bootloader (map bootloader-configuration-bootloader + (operating-system-bootloader os))) + (bootloader-name (map bootloader-name bootloader)) (label (operating-system-label os)) (multiboot-modules (operating-system-multiboot-modules os))) (boot-parameters diff --git a/gnu/system/boot.scm b/gnu/system/boot.scm index 833caef496..2b5302ce5f 100644 --- a/gnu/system/boot.scm +++ b/gnu/system/boot.scm @@ -81,6 +81,7 @@ (define-module (gnu system boot) epoch->date-string decorated-boot-label boot-parameters->menu-entry + boot-alternative->menu-entry =20 ensure-not-/dev system-linux-image-file-name)) @@ -171,7 +172,8 @@ (define (read-boot-parameters port) =20 (bootloader-name (match (assq 'bootloader-name rest) - ((_ args) args) + ((_ (args ...)) args) + ((_ args) (list args)) (#f 'grub))) ; for compatibility reasons. =20 (bootloader-menu-entries @@ -340,6 +342,7 @@ (define (boot-parameters->menu-entry conf) (label (boot-parameters-label conf)) (device (boot-parameters-store-device conf)) (device-mount-point (boot-parameters-store-mount-point conf)) + (device-subvol (boot-parameters-store-directory-prefix conf)) (linux (and (not multiboot?) kernel)) (linux-arguments (if (not multiboot?) (boot-parameters-kernel-arguments conf) @@ -353,6 +356,9 @@ (define (boot-parameters->menu-entry conf) (boot-parameters-multiboot-modules conf) '()))))) =20 +(define boot-alternative->menu-entry + (compose boot-parameters->menu-entry boot-alternative-parameters)) + (define (ensure-not-/dev device) "If DEVICE starts with a slash, return #f. This is meant to filter out Linux device names such as /dev/sda, and to preserve GRUB device names and diff --git a/gnu/system/image.scm b/gnu/system/image.scm index b0c96c60f0..050f5b578b 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -6,6 +6,7 @@ ;;; Copyright =C2=A9 2022 Alex Griffin ;;; Copyright =C2=A9 2023 Efraim Flashner ;;; Copyright =C2=A9 2023 Oleg Pykhalov +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +24,7 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (gnu system image) + #:use-module (guix deprecation) #:use-module (guix diagnostics) #:use-module (guix discovery) #:use-module (guix gexp) @@ -42,6 +44,7 @@ (define-module (gnu system image) #:use-module (gnu services base) #:use-module (gnu system) #:use-module (gnu system accounts) + #:use-module (gnu system boot) #:use-module (gnu system file-systems) #:use-module (gnu system linux-container) #:use-module (gnu system uuid) @@ -133,12 +136,10 @@ (define esp-partition ;; FAT-ness is based on file system size (16 in this case). (file-system "vfat") (flags '(esp)) - (initializer (gexp initialize-efi-partition)))) + (target 'esp) + (initializer #~initialize-efi-partition))) =20 -(define esp32-partition - (partition - (inherit esp-partition) - (initializer (gexp initialize-efi32-partition)))) +(define-deprecated/alias esp32-partition esp-partition) =20 (define root-partition (partition @@ -149,6 +150,7 @@ (define root-partition ;; with U-Boot. (file-system-options (list "-O" "^metadata_csum,^64bit")) (flags '(boot)) + (target 'root) (initializer (gexp initialize-root-partition)))) =20 (define mbr-disk-image @@ -173,11 +175,7 @@ (define efi-disk-image (partition-table-type 'gpt) (partitions (list esp-partition root-partition)))) =20 -(define efi32-disk-image - (image-without-os - (format 'disk-image) - (partition-table-type 'gpt) - (partitions (list esp32-partition root-partition)))) +(define-deprecated/alias efi32-disk-image efi-disk-image) =20 (define iso9660-image (image-without-os @@ -238,10 +236,7 @@ (define efi-raw-image-type (name 'efi-raw) (constructor (cut image-with-os efi-disk-image <>)))) =20 -(define efi32-raw-image-type - (image-type - (name 'efi32-raw) - (constructor (cut image-with-os efi32-disk-image <>)))) +(define-deprecated/alias efi32-raw-image-type efi-raw-image-type) =20 (define qcow2-image-type (image-type @@ -350,10 +345,6 @@ (define (find-root-partition image) (raise (formatted-message (G_ "image lacks a partition with the 'boot' flag"))))) =20 -(define (root-partition-index image) - "Return the index of the root partition of the given IMAGE." - (1+ (srfi-1:list-index root-partition? (image-partitions image)))) - =0C ;; ;; Disk image. @@ -362,8 +353,8 @@ (define (root-partition-index image) (define* (system-disk-image image #:key (name "disk-image") - bootcfg - bootloader + bootloader-config + bootmeta register-closures? (inputs '())) "Return as a file-like object, the disk-image described by IMAGE. Said @@ -380,6 +371,28 @@ (define* (system-disk-image image =20 (define genimage-name "image") =20 + (define (targets current) + ;; provides list of target overrides for a given CURRENT partition, wh= ich + ;; may be #f for the full-disk targets. + + ;; XXX: how we pass paths is v much a hack + (cons (bootloader-target + (type 'disk) + (device (and (not current) (string-append "images/" genimage-n= ame))) + (expected? (->bool current))) + (map (lambda (partition) + (let ((current? (and current (eq? (partition-target partition= ) + (partition-target current))= ))) + (bootloader-target + (type (partition-target partition)) + (expected? (not current?)) + (path (and current? "tmp-root")) + (offset #f) + (file-system (partition-file-system partition)) + (label (partition-label partition)) + (uuid (partition-uuid partition))))) + (filter partition-target (image-partitions image))))) + (define (image->genimage-cfg image) ;; Return as a file-like object, the genimage configuration file ;; describing the given IMAGE. @@ -460,7 +473,8 @@ (define* (system-disk-image image (list dosfstools fakeroot mtools)) (else '()))) - (image-root "tmp-root")) + (image-root (string-append (getcwd) "/tmp-root")) + (copy-closures? (not #$(image-shared-store? image)))) (sql-schema #$schema) =20 (set-path-environment-variable "PATH" '("bin" "sbin") inp= uts) @@ -476,18 +490,13 @@ (define* (system-disk-image image (initializer image-root #:references-graphs '#$graph #:deduplicate? #f - #:copy-closures? (not - #$(image-shared-store? ima= ge)) - #:system-directory #$os - #:grub-efi #+grub-efi - #:grub-efi32 #+grub-efi32 - #:bootloader-package - #+(bootloader-package bootloader) - #:bootloader-installer - #+(bootloader-installer bootloader) - #:bootcfg #$bootcfg - #:bootcfg-location - #$(bootloader-configuration-file bootloader)= ) + #:copy-closures? copy-closures? + #:system-directory #$os) + ;; no point installing a bootloader if we don't populate = store + (when copy-closures? + ;; root-offset isn't necessary - we override 'root + #$(bootloader-configurations->gexp bootloader-config bo= otmeta + #:overrides (targets partition))) (make-partition-image #$(partition->gexp partition) #$output image-root))))) @@ -534,14 +543,6 @@ (define* (system-disk-image image (image-partition-table-type image))) (else ""))) =20 - (when (and (memq (bootloader-name bootloader) - '(grub-efi grub-efi32 grub-efi-removable-bootloader)) - (not - (gpt-image? image))) - (raise - (formatted-message - (G_ "EFI bootloader required with GPT partitioning")))) - (let* ((format (image-format image)) (image-type (format->image-type format)) (image-type-options (genimage-type-options image-type image)) @@ -552,13 +553,15 @@ (define* (system-disk-image image (let ((format (@ (ice-9 format) format))) (call-with-output-file #$output (lambda (port) - (format port - "\ + (format port "\ image ~a { ~/~a {~a} ~{~a~^~%~} -}~%" #$genimage-name #$image-type #$image-type-options - (list #$@partitions-config)))))))) +}~%" + #$genimage-name + #$image-type + #$image-type-options + (list #$@partitions-config)))))))) (computed-file "genimage.cfg" builder))) =20 (let* ((image-name (image-name image)) @@ -570,17 +573,13 @@ (define* (system-disk-image image (builder (with-imported-modules* (let ((inputs '#+(list genimage coreutils findutils qemu-minima= l)) - (bootloader-installer - #+(bootloader-disk-image-installer bootloader)) (out-image (string-append "images/" #$genimage-name))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) (genimage #$(image->genimage-cfg image)) - ;; Install the bootloader directly on the disk-image. - (when bootloader-installer - (bootloader-installer - #+(bootloader-package bootloader) - #$(root-partition-index image) - out-image)) + ;; don't install bootloader unless installing store + (unless #$(image-shared-store? image) + #$(bootloader-configurations->gexp bootloader-config bootme= ta + #:overrides (targets #f)= )) (convert-disk-image out-image '#$format #$output))))) (computed-file name builder #:local-build? #f ;too I/O-intensive @@ -600,8 +599,8 @@ (define (has-guix-service-type? os) (define* (system-iso9660-image image #:key (name "image.iso") - bootcfg - bootloader + bootloader-config + bootmeta register-closures? (inputs '()) (grub-mkrescue-environment '())) @@ -621,7 +620,6 @@ (define* (system-iso9660-image image (uuid-bytevector (partition-uuid partition))))) =20 (let* ((os (image-operating-system image)) - (bootloader (bootloader-package bootloader)) (compression? (image-compression? image)) (substitutable? (image-substitutable? image)) (schema (local-file (search-path %load-path @@ -629,6 +627,14 @@ (define* (system-iso9660-image image (graph (match inputs (((names . _) ...) names))) + (config (bootloader-configuration + (bootloader grub-bootloader) + (targets (list (bootloader-target + (type 'root) + (path "tmp-root")) + (bootloader-target + (type 'install) + (path "boot/grub")))))) (builder (with-imported-modules* (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso @@ -649,10 +655,12 @@ (define* (system-iso9660-image image #:references-graphs '#$graph #:deduplicate? #f #:system-directory #$os) + (make-iso9660-image #$xorriso '#$grub-mkrescue-environment - #$bootloader - #$bootcfg + #$grub-hybrid + #$(apply grub.dir grub-hybrid + #:bootloader-config config bootmeta) #$os image-root #$output @@ -954,11 +962,7 @@ (define (operating-system-for-image image) file-systems #:volatile-root? volatile-root? rest))) - (bootloader (if (eq? format 'iso9660) - (bootloader-configuration - (inherit - (operating-system-bootloader base-os)) - (bootloader grub-mkrescue-bootloader)) + (bootloader (if (eq? format 'iso9660) '() (operating-system-bootloader base-os))) (file-systems (cons (file-system (mount-point "/") @@ -1007,17 +1011,28 @@ (define* (system-image image) (image* (image-with-os* image os)) (image-format (image-format image)) (register-closures? (has-guix-service-type? os)) - (bootcfg (operating-system-bootcfg os)) - (bootloader (bootloader-configuration-bootloader - (operating-system-bootloader os)))) + ;; force removable - images don't have efivarfs + (bootloader-config (map (lambda (c) (bootloader-configuration + (inherit c) + (efi-removable? #t))) + (operating-system-bootloader os))) + (alt (boot-alternative + (generation 1) + (system-path "/var/guix/profiles/system-1-link") + (epoch 0) + (parameters (operating-system-boot-parameters os + (partition-uuid (find-root-partition image= *)) + #:system-kernel-arguments? #t)))) + (bootmeta (cons* #:current-boot-alternative alt + #:old-boot-alternatives '() + (operating-system-bootmeta os)))) (cond ((memq image-format '(disk-image compressed-qcow2)) (system-disk-image image* - #:bootcfg bootcfg - #:bootloader bootloader + #:bootloader-config bootloader-config + #:bootmeta bootmeta #:register-closures? register-closures? - #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg)))) + #:inputs `(("system" ,os)))) ((memq image-format '(docker)) (system-docker-image image*)) ((memq image-format '(tarball)) @@ -1027,11 +1042,10 @@ (define* (system-image image) ((memq image-format '(iso9660)) (system-iso9660-image image* - #:bootcfg bootcfg - #:bootloader bootloader + #:bootloader-config bootloader-config + #:bootmeta bootmeta #:register-closures? register-closures? - #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg)) + #:inputs `(("system" ,os)) ;; Make sure to use a mode that does no imply ;; HFS+ tree creation that may fail with: ;; diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm index 9b618f7dc6..8fb00a6903 100644 --- a/gnu/system/images/hurd.scm +++ b/gnu/system/images/hurd.scm @@ -41,9 +41,7 @@ (define-module (gnu system images hurd) (define hurd-barebones-os (operating-system (inherit %hurd-default-operating-system) - (bootloader (bootloader-configuration - (bootloader grub-minimal-bootloader) - (targets '("/dev/sdX")))) + (bootloader (bootloader-configuration (bootloader grub-minimal-bootloa= der))) (file-systems (cons (file-system (device (file-system-label "my-root")) (mount-point "/") diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm index 810e2bed5f..a7a1f499dd 100644 --- a/gnu/system/images/novena.scm +++ b/gnu/system/images/novena.scm @@ -39,8 +39,7 @@ (define novena-barebones-os (timezone "Europe/Paris") (locale "en_US.utf8") (bootloader (bootloader-configuration - (bootloader u-boot-novena-bootloader) - (targets '("/dev/vda")))) + (bootloader u-boot-novena-bootloader))) (initrd-modules '()) (kernel linux-libre-arm-generic) (kernel-arguments '("console=3Dttymxc1,115200")) diff --git a/gnu/system/images/orangepi-r1-plus-lts-rk3328.scm b/gnu/system= /images/orangepi-r1-plus-lts-rk3328.scm index 6ec644f113..a3dae24377 100644 --- a/gnu/system/images/orangepi-r1-plus-lts-rk3328.scm +++ b/gnu/system/images/orangepi-r1-plus-lts-rk3328.scm @@ -39,8 +39,7 @@ (define orangepi-r1-plus-lts-rk3328-barebones-os (timezone "Europe/Amsterdam") (locale "en_US.utf8") (bootloader (bootloader-configuration - (bootloader u-boot-orangepi-r1-plus-lts-rk3328-bootloade= r) - (targets '("/dev/mmcblk0")))) + (bootloader u-boot-orangepi-r1-plus-lts-rk3328-bootloade= r))) (initrd-modules '()) (kernel linux-libre-arm64-generic) (file-systems (cons (file-system diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm index 457ff4345f..b166838ddd 100644 --- a/gnu/system/images/pine64.scm +++ b/gnu/system/images/pine64.scm @@ -41,8 +41,7 @@ (define pine64-barebones-os (timezone "Europe/Paris") (locale "en_US.utf8") (bootloader (bootloader-configuration - (bootloader u-boot-pine64-lts-bootloader) - (targets '("/dev/vda")))) + (bootloader u-boot-pine64-lts-bootloader))) (initrd-modules '()) (kernel linux-libre-arm64-generic) (file-systems (cons (file-system diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pineboo= k-pro.scm index 3a0f3abf1f..b26adfb7b9 100644 --- a/gnu/system/images/pinebook-pro.scm +++ b/gnu/system/images/pinebook-pro.scm @@ -38,8 +38,7 @@ (define pinebook-pro-barebones-os (timezone "Europe/Paris") (locale "en_US.utf8") (bootloader (bootloader-configuration - (bootloader u-boot-pinebook-pro-rk3399-bootloader) - (targets '("/dev/vda")))) + (bootloader u-boot-pinebook-pro-rk3399-bootloader))) (initrd-modules '()) (kernel linux-libre-arm64-generic) (file-systems (cons (file-system diff --git a/gnu/system/images/rock64.scm b/gnu/system/images/rock64.scm index b3dcfc6193..0b243662d6 100644 --- a/gnu/system/images/rock64.scm +++ b/gnu/system/images/rock64.scm @@ -39,8 +39,7 @@ (define rock64-barebones-os (timezone "Europe/Oslo") (locale "en_US.utf8") (bootloader (bootloader-configuration - (bootloader u-boot-rock64-rk3328-bootloader) - (targets '("/dev/sda")))) + (bootloader u-boot-rock64-rk3328-bootloader))) (initrd-modules '()) (kernel linux-libre-arm64-generic) (file-systems (cons (file-system diff --git a/gnu/system/images/unmatched.scm b/gnu/system/images/unmatched.= scm index d40a32f184..7eb147bbab 100644 --- a/gnu/system/images/unmatched.scm +++ b/gnu/system/images/unmatched.scm @@ -39,8 +39,7 @@ (define unmatched-barebones-os (timezone "Asia/Jerusalem") (locale "en_US.utf8") (bootloader (bootloader-configuration - (bootloader u-boot-sifive-unmatched-bootloader) - (targets '("/dev/vda")))) + (bootloader u-boot-sifive-unmatched-bootloader))) (initrd-modules '()) (kernel linux-libre-riscv64-generic) (file-systems (cons (file-system diff --git a/gnu/system/images/visionfive2.scm b/gnu/system/images/visionfi= ve2.scm index 26f70afbc1..a1c0733692 100644 --- a/gnu/system/images/visionfive2.scm +++ b/gnu/system/images/visionfive2.scm @@ -62,8 +62,7 @@ (define visionfive2-barebones-os (timezone "Etc/UTC") (locale "en_US.utf8") (bootloader (bootloader-configuration - (bootloader u-boot-starfive-visionfive2-bootloader) - (targets '("/dev/mmcblk0")))) + (bootloader u-boot-starfive-visionfive2-bootloader))) (file-systems (cons (file-system (device (file-system-label "Guix_image")) (mount-point "/") diff --git a/gnu/system/images/wsl2.scm b/gnu/system/images/wsl2.scm index d9aaa1a271..1501cb9a90 100644 --- a/gnu/system/images/wsl2.scm +++ b/gnu/system/images/wsl2.scm @@ -127,16 +127,6 @@ (define dummy-package (description #f) (license (fsdg-compatible "dummy")))) =20 -(define dummy-bootloader - (bootloader - (name 'dummy-bootloader) - (package dummy-package) - (configuration-file "/dev/null") - (configuration-file-generator - (lambda (. _rest) - (plain-file "dummy-bootloader" ""))) - (installer #~(const #t)))) - (define dummy-kernel dummy-package) =20 (define (dummy-initrd . _rest) @@ -146,9 +136,7 @@ (define-public wsl-os (operating-system (host-name "gnu") (timezone "Etc/UTC") - (bootloader - (bootloader-configuration - (bootloader dummy-bootloader))) + ;; no bootloader (kernel dummy-kernel) (initrd dummy-initrd) (initrd-modules '()) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 0195a0804d..e76d12e95a 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -77,8 +77,7 @@ (define-module (gnu system install) rock64-installation-os rockpro64-installation-os rk3399-puma-installation-os - wandboard-installation-os - os-with-u-boot)) + wandboard-installation-os)) =20 ;;; Commentary: ;;; @@ -503,9 +502,7 @@ (define installation-os (timezone "Europe/Paris") (locale "en_US.utf8") (name-service-switch %mdns-host-lookup-nss) - (bootloader (bootloader-configuration - (bootloader grub-bootloader) - (targets '("/dev/sda")))) + (bootloader (bootloader-configuration (bootloader grub-bootloader))) (label (string-append "GNU Guix installation " (or (getenv "GUIX_DISPLAYED_VERSION") (package-version guix)))) @@ -555,30 +552,14 @@ (define installation-os %installer-disk-utilities %base-packages)))) =20 -(define* (os-with-u-boot os board #:key (bootloader-target "/dev/mmcblk0") - (triplet "arm-linux-gnueabihf")) - "Given OS, amend it with the u-boot bootloader for BOARD, -installed to BOOTLOADER-TARGET (a drive), compiled for TRIPLET. - -If you want a serial console, make sure to specify one in your -operating-system's kernel-arguments (\"console=3DttyS0\" or similar)." - (operating-system (inherit os) - (bootloader (bootloader-configuration - (bootloader (bootloader (inherit u-boot-bootloader) - (package (make-u-boot-package board triplet)= ))) - (targets (list bootloader-target)))))) - -(define* (embedded-installation-os bootloader bootloader-target tty - #:key (extra-modules '())) +(define* (embedded-installation-os bootloader tty #:key (extra-modules '()= )) "Return an installation os for embedded systems. The initrd gets the extra modules EXTRA-MODULES. A getty is provided on TTY. The bootloader BOOTLOADER is installed to BOOTLOADER-TARGET." (operating-system (inherit installation-os) - (bootloader (bootloader-configuration - (bootloader bootloader) - (targets (list bootloader-target)))) + (bootloader (bootloader-configuration (bootloader bootloader))) (kernel linux-libre) (kernel-arguments (cons (string-append "console=3D" tty) @@ -587,7 +568,6 @@ (define* (embedded-installation-os bootloader bootloade= r-target tty =20 (define beaglebone-black-installation-os (embedded-installation-os u-boot-beaglebone-black-bootloader - "/dev/sda" "ttyO0" #:extra-modules ;; This module is required to mount the sd car= d. @@ -596,77 +576,62 @@ (define beaglebone-black-installation-os =20 (define a20-olinuxino-lime-installation-os (embedded-installation-os u-boot-a20-olinuxino-lime-bootloader - "/dev/mmcblk0" ; SD card storage "ttyS0")) =20 (define a20-olinuxino-lime2-emmc-installation-os (embedded-installation-os u-boot-a20-olinuxino-lime2-bootloader - "/dev/mmcblk1" ; eMMC storage "ttyS0")) =20 (define a20-olinuxino-micro-installation-os (embedded-installation-os u-boot-a20-olinuxino-micro-bootloader - "/dev/mmcblk0" ; SD card storage "ttyS0")) =20 (define bananapi-m2-ultra-installation-os (embedded-installation-os u-boot-bananapi-m2-ultra-bootloader - "/dev/mmcblk1" ; eMMC storage "ttyS0")) =20 (define firefly-rk3399-installation-os (embedded-installation-os u-boot-firefly-rk3399-bootloader - "/dev/mmcblk0" ; SD card/eMMC (SD priority) st= orage "ttyS2")) ; UART2 connected on the Pi2 bus =20 (define mx6cuboxi-installation-os (embedded-installation-os u-boot-mx6cuboxi-bootloader - "/dev/mmcblk0" ; SD card storage "ttymxc0")) =20 (define novena-installation-os (embedded-installation-os u-boot-novena-bootloader - "/dev/mmcblk1" ; SD card storage "ttymxc1")) =20 (define nintendo-nes-classic-edition-installation-os (embedded-installation-os u-boot-nintendo-nes-classic-edition-bootloader - "/dev/mmcblk0" ; SD card (solder it yourself) "ttyS0")) =20 (define orangepi-r1-plus-lts-rk3328-installation-os (embedded-installation-os u-boot-orangepi-r1-plus-lts-rk3328-bootloader - "/dev/mmcblk0" ; SD card storage "ttyS0")) =20 (define pine64-plus-installation-os (embedded-installation-os u-boot-pine64-plus-bootloader - "/dev/mmcblk0" ; SD card storage "ttyS0")) =20 (define pinebook-installation-os (embedded-installation-os u-boot-pinebook-bootloader - "/dev/mmcblk0" ; SD card storage "ttyS0")) =20 (define rock64-installation-os (embedded-installation-os u-boot-rock64-rk3328-bootloader - "/dev/mmcblk0" ; SD card/eMMC (SD priority) st= orage "ttyS2")) ; UART2 connected on the Pi2 bus =20 (define rockpro64-installation-os (embedded-installation-os u-boot-rockpro64-rk3399-bootloader - "/dev/mmcblk0" ; SD card/eMMC (SD priority) st= orage "ttyS2")) ; UART2 connected on the Pi2 bus =20 (define rk3399-puma-installation-os (embedded-installation-os u-boot-puma-rk3399-bootloader - "/dev/mmcblk0" ; SD card storage "ttyS0")) =20 (define wandboard-installation-os (embedded-installation-os u-boot-wandboard-bootloader - "/dev/mmcblk0" ; SD card storage "ttymxc0")) =20 ;; Return the default os here so 'guix system' can consume it directly. diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index a2743453e7..be12ae6b6c 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -172,17 +172,6 @@ (define* (virtualized-operating-system os =20 (operating-system (inherit os) - ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware), - ;; force the traditional i386/BIOS method. - ;; See . - (bootloader (bootloader-configuration - (inherit (operating-system-bootloader os)) - (bootloader - (if (target-riscv64? (or target system)) - u-boot-qemu-riscv64-bootloader - grub-bootloader)) - (targets '("/dev/vda")))) - (initrd (lambda (file-systems . rest) (apply (operating-system-initrd os) file-systems diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 36dbd9111f..18a2fc119b 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -140,7 +140,7 @@ (define-os-with-source (%minimal-extlinux-os (locale "en_US.UTF-8") =20 (bootloader (bootloader-configuration - (bootloader extlinux-bootloader-gpt) + (bootloader extlinux-gpt-bootloader) (targets (list "/dev/vdb")))) (kernel-arguments '("console=3DttyS0")) (file-systems (cons (file-system @@ -1464,9 +1464,11 @@ (define-os-with-source (%btrfs-raid10-root-os (host-name "hurd") (timezone "Europe/Paris") (locale "en_US.UTF-8") - (bootloader (bootloader-configuration - (bootloader grub-bootloader) - (targets (list "/dev/vdb" "/dev/vdc" "/dev/vdd" "/dev/vde= ")))) + (bootloader (map (lambda (targ) + (bootloader-configuration + (bootloader grub-bootloader) + (targets (list targ)))) + '("/dev/vdb" "/dev/vdc" "/dev/vdd" "/dev/vde"))) (kernel-arguments '("console=3DttyS0")) (file-systems (cons* (file-system (device (uuid "16ff18e2-eb41-4324-8df5-80d3b53c= 411b")) diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm index bcc7645fa3..8aa5311171 100644 --- a/gnu/tests/reconfigure.scm +++ b/gnu/tests/reconfigure.scm @@ -30,8 +30,7 @@ (define-module (gnu tests reconfigure) #:use-module (guix scripts system reconfigure) #:use-module (guix store) #:export (%test-switch-to-system - %test-upgrade-services - %test-install-bootloader)) + %test-upgrade-services)) =20 ;;; Commentary: ;;; @@ -178,83 +177,6 @@ (define* (run-upgrade-services-test) (disable (upgrade-services-program '() '() '(dummy) '()))) (test enable disable)))) =20 -(define* (run-install-bootloader-test) - "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs = a -bootloader's configuration file." - (define os - (marionette-operating-system - (simple-operating-system) - #:imported-modules '((gnu services herd) - (guix combinators)))) - - (define vm (virtual-machine - (operating-system os) - (volatile? #f))) - - (define (test script) - (with-imported-modules '((gnu build marionette)) - #~(begin - (use-modules (gnu build marionette) - (ice-9 regex) - (srfi srfi-1) - (srfi srfi-64)) - - (define marionette - (make-marionette (list #$vm))) - - ;; Return the system generation paths that have GRUB menu entrie= s. - (define (generations-in-grub-cfg marionette) - (let ((grub-cfg (marionette-eval - '(begin - (use-modules (rnrs io ports)) - (call-with-input-file "/boot/grub/grub.cfg= " - get-string-all)) - marionette))) - (map (lambda (parameter) - (second (string-split (match:substring parameter) #\= =3D))) - (list-matches "system=3D[^ ]*" grub-cfg)))) - - (test-runner-current (system-test-runner #$output)) - (test-begin "install-bootloader") - - (test-assert "no prior menu entry for system generation" - (not (member #$os (generations-in-grub-cfg marionette)))) - - (test-assert "script successfully evaluated" - (marionette-eval - '(primitive-load #$script) - marionette)) - - (test-assert "menu entry created for system generation" - (member #$os (generations-in-grub-cfg marionette))) - - (test-end)))) - - (let* ((bootloader ((compose bootloader-configuration-bootloader - operating-system-bootloader) - os)) - ;; The typical use-case for 'install-bootloader-program' is to re= ad - ;; the boot parameters for the existing menu entries on the syste= m, - ;; parse them with 'boot-parameters->menu-entry', and pass the - ;; results to 'operating-system-bootcfg'. However, to obtain boot - ;; parameters, we would need to start the marionette, which we sh= ould - ;; ideally avoid doing outside of the 'test' G-Expression. Thus, = we - ;; generate a bootloader configuration for the script as if there - ;; were no existing menu entries. In the grand scheme of things, = this - ;; matters little -- these tests should not make assertions about= the - ;; behavior of 'operating-system-bootcfg'. - (bootcfg (operating-system-bootcfg os '())) - (bootcfg-file (bootloader-configuration-file bootloader))) - (gexp->derivation - "install-bootloader" - ;; Due to the read-only nature of the virtual machines used in the sy= stem - ;; test suite, the bootloader installer script is omitted. 'grub-inst= all' - ;; would attempt to write directly to the virtual disk if the - ;; installation script were run. - (test - (install-bootloader-program #f #f #f bootcfg bootcfg-file '(#f) "/")= )))) - - (define %test-switch-to-system (system-test (name "switch-to-system") @@ -267,9 +189,3 @@ (define %test-upgrade-services (description "Upgrade the Shepherd by unloading obsolete services and loading new services.") (value (run-upgrade-services-test)))) - -(define %test-install-bootloader - (system-test - (name "install-bootloader") - (description "Install a bootloader and its configuration file.") - (value (run-install-bootloader-test)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 344bb74151..8c12acc296 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -209,7 +209,7 @@ (define* (copy-closure item target =20 (define* (install os-drv target #:key (log-port (current-output-port)) - install-bootloader? bootloader bootcfg) + install-bootloader? bootloaders bootmeta) "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to directory TARGET. TARGET must be an absolute directory name since that's = what 'register-path' expects. @@ -247,24 +247,27 @@ (define* (install os-drv target (chmod target #o755) (let ((os-dir (derivation->output-path os-drv)) (format (lift format %store-monad)) - (populate (lift2 populate-root-file-system %store-monad))) - - (mlet %store-monad ((bootcfg (lower-object bootcfg))) - (mbegin %store-monad - ;; Copy the closure of BOOTCFG, which includes OS-DIR, - ;; eventual background image and so on. - (maybe-copy (derivation->output-path bootcfg)) - - ;; Create a bunch of additional files. - (format log-port "populating '~a'...~%" target) - (populate os-dir target) - + (populate (lift2 populate-root-file-system %store-monad)) + (profile (string-append target "/var/guix/profiles/system"))) + + (mbegin %store-monad + ;; Create a bunch of system files. + (format log-port "populating '~a'...~%" target) + (populate os-dir target) + + ;; Copy the bootloader's closure, which includes OS-DIR, + ;; eventual background image and so on. + (mlet* %store-monad + ((alt -> (generation->boot-alternative profile 1)) + (inst (apply install-bootloader local-eval bootloaders + (list alt) #:dry-run (not install-bootloader?) + #:root-offset target bootmeta))) + (maybe-copy (derivation->output-path inst))) (mwhen install-bootloader? - (install-bootloader local-eval bootloader bootcfg - #:target target) (return (info (G_ "bootloader successfully installed on~{ ~a~}~%") - (bootloader-configuration-targets bootloader)))))))) + (fold append '() + (map bootloader-configuration-targets bootloaders))))))= )) =20 =0C ;;; @@ -389,20 +392,13 @@ (define (install-bootloader-from-provenance store num= ber) (let* ((generation (generation-file-name %system-profile number)) (os (receive (_ os) (system-provenance generation) (and=3D> os read-operating-system))) - (bootloader-config (operating-system-bootloader os)) - (bootloader (bootloader-configuration-bootloader bootloader-confi= g)) + (new (generation->boot-alternative %system-profile number)) (numbers (delv number (reverse (generation-numbers %system-profil= e)))) (old (profile->boot-alternatives %system-profile numbers))) (if os (run-with-store store - (mlet* %store-monad - ((bootcfg (lower-object (operating-system-bootcfg os old))) - (drvs -> (list bootcfg))) - (mbegin %store-monad - (built-derivations drvs) - ;; Only install bootloader configuration file. - (install-bootloader local-eval bootloader-config bootcfg - #:run-installer? #f)))) + (apply install-bootloader local-eval (operating-system-bootloader = os) + (cons new old) (operating-system-bootmeta os))) (leave (G_ "cannot rollback to provenanceless generation '~a'~%") number)))) =20 @@ -489,7 +485,7 @@ (define* (display-system-generation number (format #t (G_ " canonical file name: ~a~%") (readlink* generation)= ) ;; TRANSLATORS: Please preserve the two-space indentation. (format #t (G_ " label: ~a~%") label) - (format #t (G_ " bootloader: ~a~%") bootloader-name) + (format #t (G_ " bootloader: ~a~%") (string-join bootloader-name)) =20 ;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string mu= st ;; be preserved. They denote conditionals, such that the result wil= l @@ -775,18 +771,11 @@ (define* (perform-action action image (define os (image-operating-system image)) =20 - (define bootloader + (define bootloaders (operating-system-bootloader os)) =20 - (define bootcfg - (and (memq action '(init reconfigure)) - (operating-system-bootcfg - os - (if (eq? action 'init) - '() - (map boot-parameters->menu-entry - (map boot-alternative-parameters - (profile->boot-alternatives))))))) + (define bootmeta + (operating-system-bootmeta os)) =20 (when (eq? action 'reconfigure) (maybe-suggest-running-guix-pull) @@ -817,10 +806,7 @@ (define* (perform-action action image ;; For 'init' and 'reconfigure', always build BOOTCFG, even if ;; --no-bootloader is passed, because we then use it as a GC root. ;; See . - (drvs (mapm/accumulate-builds lower-object - (if (memq action '(init reconfig= ure)) - (list sys bootcfg) - (list sys)))) + (drvs (mapm/accumulate-builds lower-object (list sys))) (% (if derivations-only? (return (for-each (compose println derivation-file-n= ame) drvs)) @@ -838,12 +824,16 @@ (define* (perform-action action image (format #t (G_ "activating system...~%")) (mbegin %store-monad (switch-to-system local-eval os) + (apply install-bootloader local-eval bootloaders + (profile->boot-alternatives) + #:dry-run? (not install-bootloader?) + (if target (cons* #:root-offset target bootmeta) bootmeta= )) (mwhen install-bootloader? - (install-bootloader local-eval bootloader bootcfg - #:target (or target "/")) (return (info (G_ "bootloader successfully installed on '~a'~%") - (bootloader-configuration-targets bootloader)))) + (map bootloader-target-path + (fold append '() + (map bootloader-configuration-targets bootloaders)= ))))) (with-shepherd-error-handling (upgrade-shepherd-services local-eval os) (return (format #t (G_ "\ @@ -857,8 +847,8 @@ (define* (perform-action action image target) (install sys (canonicalize-path target) #:install-bootloader? install-bootloader? - #:bootloader bootloader - #:bootcfg bootcfg)) + #:bootloaders bootloaders + #:bootmeta bootmeta)) (else ;; All we had to do was to build SYS and maybe register an ;; indirect GC root. @@ -1254,11 +1244,7 @@ (define (process-action action args opts) (G_ "image lacks an operating-system"))))) (target-file (match args ((first second) second) - (_ #f))) - (bootloader-targets - (and bootloader? - (bootloader-configuration-targets - (operating-system-bootloader os))))) + (_ #f)))) =20 (define (graph-backend) (lookup-backend (assoc-ref opts 'graph-backend))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reco= nfigure.scm index 604ba08fee..8add639e6a 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -7,6 +7,7 @@ ;;; Copyright =C2=A9 2019 Christopher Baines ;;; Copyright =C2=A9 2019 Jakob L. Kreuze ;;; Copyright =C2=A9 2022 Arun Isaac +;;; Copyright =C2=A9 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -209,101 +210,83 @@ (define* (upgrade-shepherd-services eval os) ;;; Bootloader configuration. ;;; =20 -(define (install-bootloader-program installer disk-installer - bootloader-package bootcfg - bootcfg-file devices target) +(define (install-bootloader-program configs offset chosen-alt old-alts loc= ale + store-crypto-devices store-directory-p= refix) "Return an executable store item that, upon being evaluated, will instal= l BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICES, a list of file sy= stem devices, at TARGET, a mount point, and subsequently run INSTALLER from BOOTLOADER-PACKAGE." (program-file - "install-bootloader.scm" - (with-extensions (list guile-gcrypt) - (with-imported-modules `(,@(source-module-closure - '((gnu build bootloader) - (gnu build install) - (guix store) - (guix utils)) - #:select? not-config?) - ((guix config) =3D> ,(make-config.scm))) - #~(begin - (use-modules (gnu build bootloader) - (gnu build install) - (guix build utils) - (guix store) - (guix utils) - (ice-9 binary-ports) - (ice-9 match) - (srfi srfi-34) - (srfi srfi-35)) - - (let* ((gc-root (string-append #$target %gc-roots-directory "/b= ootcfg")) - (new-gc-root (string-append gc-root ".new"))) - ;; #$bootcfg has dependencies. - ;; The bootloader magically loads the configuration from - ;; (string-append #$target #$bootcfg-file) (for example - ;; "/boot/grub/grub.cfg"). - ;; If we didn't do something special, the garbage collector - ;; would remove the dependencies of #$bootcfg. - ;; Register #$bootcfg as a GC root. - ;; Preserve the previous activation's garbage collector root - ;; until the bootloader installer has run, so that a failure = in - ;; the bootloader's installer script doesn't leave the user w= ith - ;; a broken installation. - (switch-symlinks new-gc-root #$bootcfg) - (install-boot-config #$bootcfg #$bootcfg-file #$target) - (when (or #$installer #$disk-installer) - (catch #t - (lambda () - ;; The bootloader might not support installation on a - ;; mounted directory using the BOOTLOADER-INSTALLER - ;; procedure. In that case, fallback to installing the - ;; bootloader directly on DEVICES using the - ;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure. - (if #$installer - (for-each (lambda (device) - (#$installer #$bootloader-package devic= e - #$target)) - '#$devices) - (for-each (lambda (device) - (#$disk-installer #$bootloader-package - 0 device)) - '#$devices))) - (lambda args - (delete-file new-gc-root) - (match args - (('%exception exception) ;Guile 3 SRFI-34 or simi= lar - (raise-exception exception)) - ((key . args) - (apply throw key args)))))) - ;; We are sure that the installation of the bootloader - ;; succeeded, so we can replace the old GC root by the new - ;; GC root now. - (rename-file new-gc-root gc-root))))))) + "install-bootloader.scm" + ;; three sources of boot entries: bootloader-configuration-menu-entrie= s, + ;; current-boot-alternative, and old-boot-alternatives. + (let ((args (list #:current-boot-alternative chosen-alt + #:old-boot-alternatives old-alts + #:locale locale + #:store-directory-prefix store-directory-prefix + #:store-crypto-devices store-crypto-devices))) + (with-extensions (list guile-gcrypt) + (with-imported-modules + `(,@(source-module-closure '((gnu build bootloader) + (gnu build install) + (guix store) + (guix utils)) + #:select? not-config?) + ((guix config) =3D> ,(make-config.scm))) + #~(begin + (use-modules (gnu build bootloader) + (gnu build install) + (guix build utils) + (guix store) + (guix utils) + (ice-9 binary-ports) + (ice-9 match) + (srfi srfi-34) + (srfi srfi-35)) + ;; bootloader-installer is passed an additional #:target arg= ument + ;; denoting the specific target currently being installed to= . + ;; bootloaders should determine when to fully reinstall them= selves. + #$(bootloader-configurations->gexp configs args + #:root-offset offset)))))= )) =20 -(define* (install-bootloader eval configuration bootcfg - #:key - (run-installer? #t) - (target "/")) +(define* (install-bootloader eval configs alts #:key locale + store-crypto-devices store-directory-prefix + (root-offset "/") (dry-run? #f)) "Using EVAL, a monadic procedure taking a single G-Expression as an argu= ment, -configure the bootloader on TARGET such that OS will be booted by default = and -additional configurations specified by MENU-ENTRIES can be selected." - (let* ((bootloader (bootloader-configuration-bootloader configuration)) - (installer (and run-installer? - (bootloader-installer bootloader))) - (disk-installer (and run-installer? - (bootloader-disk-image-installer bootloader)= )) - (package (bootloader-package bootloader)) - (devices (bootloader-configuration-targets configuration)) - (bootcfg-file (bootloader-configuration-file bootloader))) - (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) - (primitive-load #$(install-bootloader-program installer - disk-installer - package - bootcfg - bootcfg-file - devices - target)))))) +configure the bootloader with bootloader-configuration CONFIG such that +ALTS may be selected, with the first element being the default. If QUICK?= only +the bootloader config is reinstalled. Returns the config installer drv." + (mlet* %store-monad + ((program (lower-object + (install-bootloader-program configs root-offset + (car alts) (cdr alts) locale + store-crypto-devices store-directory-prefix)))) + (mbegin %store-monad + (eval + (with-imported-modules `(,@(source-module-closure '((guix build ut= ils) + (guix store)) + #:select? not-co= nfig?) + ((guix config) =3D> ,(make-config.scm))) + #~(begin + (use-modules (guix build utils) (guix store)) + (parameterize ((current-warning-port (%make-void-port "w"))) + (let* ((gc-root (string-append + #$root-offset %gc-roots-directory "/boot= cfg")) + (new-gc-root (string-append gc-root ".new"))) + ;; since the installers are gexps directly included, we = add + ;; the installer runner as a gc root. this should make = sure + ;; no bootloader files get gc'd. only remove the old on= e on + ;; success. + ;; XXX: is this still necessary? + (switch-symlinks new-gc-root #$program) + (dynamic-wind (const #t) + (lambda () + (unless #$dry-run? (primitive-load #$program)) + (rename-file new-gc-root gc-root)) + (lambda () ; delete new root if failed + (when (file-exists? new-gc-root) + (delete-file new-gc-root))))))))) + (return program)))) =20 =0C ;;; --=20 2.45.2