From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0.migadu.com ([2001:41d0:403:58f0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id 6LfDGQSf7mYfKwEAqHPOHw:P1 (envelope-from ) for ; Sat, 21 Sep 2024 10:25:08 +0000 Received: from aspmx1.migadu.com ([2001:41d0:403:58f0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0.migadu.com with LMTPS id 6LfDGQSf7mYfKwEAqHPOHw (envelope-from ) for ; Sat, 21 Sep 2024 12:25:08 +0200 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=I6PgbPTJ; dkim=fail ("headers rsa verify failed") header.d=rimm.ee header.s=herman header.b=JKmcFmg7; 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"; dmarc=pass (policy=none) header.from=gnu.org ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1726914308; 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=26IXqhP4ocZJ66ql6huYd4LTNC6fMnEtmIf+zJm+SeA=; b=F0ktKC00ZSRw+EYKUF04/hkpcMNNPVr3f89KzjSCc+eHVPj29nL6tdPOpOeD07AhEMV82R tV+KzyU1PQJJo68LqnoXq9+YxgHuTBDEqOr/8YENZKmYqDvStrWnoDKyKxD6awbpJms7/S 58ZeNqIzfPMrR2N22W+mWqnDcsiIfrRwLFmPKcmbQDyc7bl791eOt+koDG+KOIZBt3h61B tCu45tX3GOFzOuBvvof4+8Xt7WK7V5dGYF5+nmnTq7FFKbNoPKIvWOqF9ZkUb3q/DKsGOI vruaddg34ziF96q06ij/E+uw6H8yaqrXaa0LcI+XeqWJM8iIr91tbliuIXg3gA== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=I6PgbPTJ; dkim=fail ("headers rsa verify failed") header.d=rimm.ee header.s=herman header.b=JKmcFmg7; 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"; dmarc=pass (policy=none) header.from=gnu.org ARC-Seal: i=1; s=key1; d=yhetil.org; t=1726914308; a=rsa-sha256; cv=none; b=ZQ3rqujRrP6NAhrjuZufYKBsxy6dYrLtHGPa7sO2FKDHc+/9Mfv76vZVYZZ+rEp+ArpbbB +v/02MqyQwXg2/Oadf4a5QzlZTZuCe4PN5mrzmmucRZaGX1plaG/UqeVN0f2azuYOhRX6L fMwN6pGPikkKLApuQNgnH5SwuQ/MlAyqkq3mswI7dmrKLtJG1kRz16zaz96VylxDKuPHzb nJYsohKANmAhKBnnOOAdZXQvUNlfcbH4kXMVHupiKZil1pV97r32BMk2/bYy4wmUxOibbE KQkUczcgPnwteXHIepRGqLwGrGlcz8iMnfRDDACABQPaugLKlS4PBeghNYlc5Q== 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 CCDC168C04 for ; Sat, 21 Sep 2024 12:25:07 +0200 (CEST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1srxIF-0008WK-5v; Sat, 21 Sep 2024 06:24:47 -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 1srxID-0008VW-If for guix-patches@gnu.org; Sat, 21 Sep 2024 06:24:45 -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 1srxID-0004cX-9d; Sat, 21 Sep 2024 06:24:45 -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=jBjv0A/X9g5+fsM1IjA/Fl0EBHv4GOQsxwrwwk025C4=; b=I6PgbPTJVp4MNXUUEM0F25TJl8zeMtxMoSSE6rgqS9TQd+yRD60Mbh4SqzE0NFYr9vpJfzVyzNyOHTZd9oOa4mbOe/Z6ody0cDmfmCLZ2icSMNwuA4Aey/RDLqZ24uxdL/UmRkjN2tJujYHJ8ezSmeZWJzg8so4Gt0jxOiz+Ca2xv9OaDTN7qULYkosS6tsBR39deI8CE/ZcYk7oawdn55DksIKCOPayTpxyTKKNMaS6zCGXn0qAha0/iPubQ9SVIUGvl/ojOxVmmjkSRjpAXGMZ2P5pN+YpWIIWARi/ORuz7Y259fFWxhtEQo4tjBi5JLLFJa1CeN0iMFr7BrZypw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1srxIV-0005of-D7; Sat, 21 Sep 2024 06:25:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#69343] [PATCH v5 02/10] Move record to a separate file. Resent-From: Herman Rimm Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Sat, 21 Sep 2024 10:25:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 69343 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 69343@debbugs.gnu.org Cc: Felix Lechner , Christopher Baines , Josselin Poiret , Ludovic =?UTF-8?Q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic =?UTF-8?Q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 69343-submit@debbugs.gnu.org id=B69343.172691429122279 (code B ref 69343); Sat, 21 Sep 2024 10:25:03 +0000 Received: (at 69343) by debbugs.gnu.org; 21 Sep 2024 10:24:51 +0000 Received: from localhost ([127.0.0.1]:37286 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1srxIG-0005mn-J0 for submit@debbugs.gnu.org; Sat, 21 Sep 2024 06:24:51 -0400 Received: from 81-205-150-117.fixed.kpn.net ([81.205.150.117]:57083 helo=email.rimm.ee) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1srxIB-0005li-Ke for 69343@debbugs.gnu.org; Sat, 21 Sep 2024 06:24:45 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=rimm.ee; s=herman; t=1726914252; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version:content-type:content-type: content-transfer-encoding:content-transfer-encoding: in-reply-to:in-reply-to:references:references; bh=26IXqhP4ocZJ66ql6huYd4LTNC6fMnEtmIf+zJm+SeA=; b=JKmcFmg70BJGy+0TNGOcWI6Z+GmJbXQ9aJTjlG2X0tAsCdlpw2kcfEIoO0wPeSMac6cv8W 2YptrZ3muUCs1hhnWq3hx1Qy0HDJwQ5fz04vO06M/eef12tk5A4DkofKJPAtBHBXH3/m9d T5v0XQxIbQYq5Hl3X1Ykosoh8Ltt1PYoWkjjvpA1EnzppEaOteYKGZ/iIO4qhvtb3bzRmi nyAvEWlhy8o1Xn8eH5wxXxk6do/ukpi/ZwEzYax01Uz5rvdf98vUAfOvE4nJ9gQfzSLavj mYABRelirvXkHai+uRq2uOG9jTVMjyPBTY8VzY+pCCTYTDxjeKP9PfPqMPgNBg== Received: by 81-205-150-117.fixed.kpn.net (OpenSMTPD) with ESMTPSA id 2639cefa (TLSv1.3:TLS_CHACHA20_POLY1305_SHA256:256:NO); Sat, 21 Sep 2024 10:24:12 +0000 (UTC) Date: Sat, 21 Sep 2024 12:23:15 +0200 Message-ID: X-Mailer: git-send-email 2.45.2 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: Herman Rimm X-ACL-Warn: , Herman Rimm via Guix-patches From: Herman Rimm via Guix-patches via 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: CCDC168C04 X-Migadu-Scanner: mx11.migadu.com X-Spam-Score: -5.51 X-Migadu-Spam-Score: -5.51 X-TUID: Z76upbS5TFBg From: Felix Lechner Required to avoid a missing dependency error on build-side. * gnu/system.scm (): Move this record, and... (system-linux-image-file-name, %boot-parameters-version, bootable-kernel-arguments, ensure-not-/dev, read-boot-parameters, read-boot-parameters-file, boot-parameters->menu-entry): ...these procedures, to... * gnu/system/boot.scm: ...this new file. * gnu/machine/ssh.scm, gnu/system.scm, guix/scripts/system.scm, tests/boot-parameters.scm: Use new module above. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new module above. * gnu/machine/ssh.scm (machine-boot-parameters): Don't private-import bootable-kernel-arguments. Change-Id: I50cca8d2187879cd351b8e9332e1e114ca5096ae --- gnu/local.mk | 1 + gnu/machine/ssh.scm | 4 +- gnu/system.scm | 287 +------------------------------- gnu/system/boot.scm | 335 ++++++++++++++++++++++++++++++++++++++ guix/scripts/system.scm | 1 + tests/boot-parameters.scm | 1 + 6 files changed, 340 insertions(+), 289 deletions(-) create mode 100644 gnu/system/boot.scm diff --git a/gnu/local.mk b/gnu/local.mk index 8e7abc8a47..6ba3aa3da8 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -762,6 +762,7 @@ GNU_SYSTEM_MODULES = \ \ %D%/system.scm \ %D%/system/accounts.scm \ + %D%/system/boot.scm \ %D%/system/file-systems.scm \ %D%/system/hurd.scm \ %D%/system/image.scm \ diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 3e10d984e7..863c28a13c 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -23,6 +23,7 @@ (define-module (gnu machine ssh) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) #:use-module (gnu system) + #:use-module (gnu system boot) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) #:use-module ((gnu services) #:select (sexp->system-provenance)) @@ -419,9 +420,6 @@ (define not-config? (define (machine-boot-parameters machine) "Monadic procedure returning a list of 'boot-parameters' for the generations of MACHINE's system profile, ordered from most recent to oldest." - (define bootable-kernel-arguments - (@@ (gnu system) bootable-kernel-arguments)) - (define remote-exp (with-extensions (list guile-gcrypt) (with-imported-modules `(((guix config) => ,(make-config.scm)) diff --git a/gnu/system.scm b/gnu/system.scm index 44f93f91d1..25afa96295 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -72,6 +72,7 @@ (define-module (gnu system) #:use-module (gnu services shepherd) #:use-module (gnu services base) #:use-module (gnu bootloader) + #:use-module (gnu system boot) #:use-module (gnu system shadow) #:use-module (gnu system nss) #:use-module (gnu system locale) @@ -147,33 +148,11 @@ (define-module (gnu system) operating-system-boot-script operating-system-uuid - system-linux-image-file-name operating-system-with-gc-roots operating-system-with-provenance hurd-default-essential-services - boot-parameters - boot-parameters? - boot-parameters-label - boot-parameters-root-device - boot-parameters-bootloader-name - boot-parameters-bootloader-menu-entries - boot-parameters-store-crypto-devices - boot-parameters-store-device - boot-parameters-store-directory-prefix - boot-parameters-store-mount-point - boot-parameters-locale - boot-parameters-kernel - boot-parameters-kernel-arguments - boot-parameters-initrd - boot-parameters-multiboot-modules - boot-parameters-version - %boot-parameters-version - read-boot-parameters - read-boot-parameters-file - boot-parameters->menu-entry - local-host-aliases ;deprecated %root-account %default-privileged-programs @@ -195,29 +174,6 @@ (define-module (gnu system) ;;; ;;; Code: -(define* (bootable-kernel-arguments system root-device version) - "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE. -VERSION is the target version of the boot-parameters record." - ;; If the version is newer than 0, we use the new style initrd parameter - ;; names, otherwise we use the legacy ones. This is to maintain backward - ;; compatibility when producing bootloader configurations for older - ;; generations. - (define version>0? (> version 0)) - (let ((root (file-system-device->string root-device - #:uuid-type 'dce))) - (append - (if (string=? root "none") - '() ; Ignore the case where the root is "none" (typically tmpfs). - ;; Note: Always use the DCE format because that's what - ;; (gnu build linux-boot) expects for the 'root' - ;; kernel command-line option. - (list (string-append (if version>0? "root=" "--root=") root))) - (list #~(string-append (if #$version>0? "gnu.system=" "--system=") #$system) - #~(string-append (if #$version>0? "gnu.load=" "--load=") - #$system "/boot"))))) - -;; System-wide configuration. - (define-with-syntax-properties (warn-hosts-file-field-deprecation (value properties)) (when value @@ -361,236 +317,6 @@ (define* (operating-system-kernel-arguments (append (bootable-kernel-arguments os root-device version) (operating-system-user-kernel-arguments os))) - -;;; -;;; Boot parameters -;;; - -;;; Version 1 was introduced early 2022 to mark the departure from long option -;;; names such as '--load' to the more conventional initrd option names like -;;; 'gnu.load'. -;;; -;;; When bumping the boot-parameters version, increment it by one (1). -(define %boot-parameters-version 1) - -(define-record-type* - boot-parameters make-boot-parameters boot-parameters? - (label boot-parameters-label) - ;; Because we will use the 'store-device' to create the GRUB search command, - ;; the 'store-device' has slightly different semantics than 'root-device'. - ;; The 'store-device' can be a file system uuid, a file system label, or #f, - ;; but it cannot be a device file name such as "/dev/sda3", since GRUB would - ;; not understand that. The 'root-device', on the other hand, corresponds - ;; exactly to the device field of the object representing the - ;; OS's root file system, so it might be a device file name like - ;; "/dev/sda3". The 'store-directory-prefix' field contains #f or the store - ;; file name inside the 'store-device' as it is seen by GRUB, e.g. it would - ;; contain "/storefs" if the store is located in that subvolume of a btrfs - ;; partition. - (root-device boot-parameters-root-device) - (bootloader-name boot-parameters-bootloader-name) - (bootloader-menu-entries ;list of - boot-parameters-bootloader-menu-entries) - (store-device boot-parameters-store-device) - (store-mount-point boot-parameters-store-mount-point) - (store-directory-prefix boot-parameters-store-directory-prefix) - (store-crypto-devices boot-parameters-store-crypto-devices - (default '())) - (locale boot-parameters-locale) - (kernel boot-parameters-kernel) - (kernel-arguments boot-parameters-kernel-arguments) - (initrd boot-parameters-initrd) - (multiboot-modules boot-parameters-multiboot-modules) - (version boot-parameters-version ;positive integer - (default %boot-parameters-version))) - -(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 -file system labels." - (if (and (string? device) (string-prefix? "/" device)) - #f - device)) - -(define (read-boot-parameters port) - "Read boot parameters from PORT and return the corresponding - object. Raise an error if the format is unrecognized." - (define device-sexp->device - (match-lambda - (('uuid (? symbol? type) (? bytevector? bv)) - (bytevector->uuid bv type)) - (('file-system-label (? string? label)) - (file-system-label label)) - ((? bytevector? bv) ;old format - (bytevector->uuid bv 'dce)) - ((? string? device) - (if (string-contains device ":/") - device ; nfs-root - ;; It used to be that we would not distinguish between labels and - ;; device names. Try to infer the right thing here. - (if (string-prefix? "/" device) - device - (file-system-label device)))))) - (define uuid-sexp->uuid - (match-lambda - (('uuid (? symbol? type) (? bytevector? bv)) - (bytevector->uuid bv type)) - (x - (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port)) - #f))) - - ;; New versions are not backward-compatible, so only accept past and current - ;; versions, not future ones. - (define (version? n) - (member n (iota (1+ %boot-parameters-version)))) - - (match (read port) - (('boot-parameters ('version (? version? version)) - ('label label) ('root-device root) - ('kernel kernel) - rest ...) - (boot-parameters - (version version) - (label label) - (root-device (device-sexp->device root)) - - (bootloader-name - (match (assq 'bootloader-name rest) - ((_ args) args) - (#f 'grub))) ; for compatibility reasons. - - (bootloader-menu-entries - (match (assq 'bootloader-menu-entries rest) - ((_ entries) (map sexp->menu-entry entries)) - (#f '()))) - - ;; In the past, we would store the directory name of linux instead of - ;; the absolute file name of its image. Detect that and correct it. - (kernel (if (string=? kernel (direct-store-path kernel)) - (string-append kernel "/" - (system-linux-image-file-name)) - kernel)) - - (kernel-arguments - (match (assq 'kernel-arguments rest) - ((_ args) args) - (#f '()))) ;the old format - - (initrd - (match (assq 'initrd rest) - (('initrd ('string-append directory file)) ;the old format - (string-append directory file)) - (('initrd (? string? file)) - file) - (#f #f))) - - (multiboot-modules - (match (assq 'multiboot-modules rest) - ((_ args) args) - (#f '()))) - - (locale - (match (assq 'locale rest) - ((_ locale) locale) - (#f #f))) - - (store-device - ;; Linux device names like "/dev/sda1" are not suitable GRUB device - ;; identifiers, so we just filter them out. - (ensure-not-/dev - (match (assq 'store rest) - (('store ('device #f) _ ...) - root-device) - (('store ('device device) _ ...) - (device-sexp->device device)) - (_ ;the old format - root-device)))) - - (store-directory-prefix - (match (assq 'store rest) - (('store . store-data) - (match (assq 'directory-prefix store-data) - (('directory-prefix prefix) prefix) - ;; No directory-prefix found. - (_ #f))) - (_ - ;; No store found, old format. - #f))) - - (store-crypto-devices - (match (assq 'store rest) - (('store . store-data) - (match (assq 'crypto-devices store-data) - (('crypto-devices (devices ...)) - (map uuid-sexp->uuid devices)) - (('crypto-devices dev) - (warning (G_ "unrecognized crypto-devices ~S at '~a'~%") - dev (port-filename port)) - '()) - (_ - ;; No crypto-devices found. - '()))) - (_ - ;; No store found, old format. - '()))) - - (store-mount-point - (match (assq 'store rest) - (('store ('device _) ('mount-point mount-point) _ ...) - mount-point) - (_ ;the old format - "/"))))) - (x ;unsupported format - (raise - (make-compound-condition - (formatted-message - (G_ "unrecognized boot parameters at '~a'~%") - (port-filename port)) - (condition - (&fix-hint (hint (format #f (G_ "This probably means that this version -of Guix is older than the one that created @file{~a}. To address this, you -need to update Guix: - -@example -guix pull -@end example") - (port-filename port)))))))))) - -(define (read-boot-parameters-file system) - "Read boot parameters from SYSTEM's (system or generation) \"parameters\" -file and returns the corresponding object or #f if the -format is unrecognized. -The object has its kernel-arguments extended in order to make it bootable." - (let* ((file (string-append system "/parameters")) - (params (call-with-input-file file read-boot-parameters)) - (root (boot-parameters-root-device params)) - (version (boot-parameters-version params))) - (boot-parameters - (inherit params) - (kernel-arguments (append (bootable-kernel-arguments system root version) - (boot-parameters-kernel-arguments params)))))) - -(define (boot-parameters->menu-entry conf) - "Return a instance given CONF, a instance." - (let* ((kernel (boot-parameters-kernel conf)) - (multiboot-modules (boot-parameters-multiboot-modules conf)) - (multiboot? (pair? multiboot-modules))) - (menu-entry - (label (boot-parameters-label conf)) - (device (boot-parameters-store-device conf)) - (device-mount-point (boot-parameters-store-mount-point conf)) - (linux (and (not multiboot?) kernel)) - (linux-arguments (if (not multiboot?) - (boot-parameters-kernel-arguments conf) - '())) - (initrd (boot-parameters-initrd conf)) - (multiboot-kernel (and multiboot? kernel)) - (multiboot-arguments (if multiboot? - (boot-parameters-kernel-arguments conf) - '())) - (multiboot-modules (if multiboot? - (boot-parameters-multiboot-modules conf) - '()))))) ;;; @@ -731,17 +457,6 @@ (define (swap-services os) (map (compose swap-service filter-deps) (operating-system-swap-devices os))) -(define* (system-linux-image-file-name #:optional - (target (or (%current-target-system) - (%current-system)))) - "Return the basename of the kernel image file for TARGET." - (cond - ((string-prefix? "arm" target) "zImage") - ((string-prefix? "mips" target) "vmlinuz") - ((string-prefix? "aarch64" target) "Image") - ((string-prefix? "riscv64" target) "Image") - (else "bzImage"))) - (define (operating-system-kernel-file os) "Return an object representing the absolute file name of the kernel image of OS." diff --git a/gnu/system/boot.scm b/gnu/system/boot.scm new file mode 100644 index 0000000000..2c531e4ad5 --- /dev/null +++ b/gnu/system/boot.scm @@ -0,0 +1,335 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013-2022 Ludovic Courtès +;;; Copyright © 2016 Chris Marusich +;;; Copyright © 2017 David Craven +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas +;;; Copyright © 2020 Danny Milosavljevic +;;; Copyright © 2020 Stefan +;;; Copyright © 2020, 2022 Maxim Cournoyer +;;; Copyright © 2020 Janneke Nieuwenhuizen +;;; Copyright © 2020, 2022 Efraim Flashner +;;; Copyright © 2024 Nicolas Graves +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu system boot) + #:use-module (guix gexp) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (gnu bootloader) + #:use-module (gnu system file-systems) + #:use-module (gnu system uuid) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) + #:export (boot-parameters + boot-parameters? + boot-parameters-label + boot-parameters-root-device + boot-parameters-bootloader-name + boot-parameters-bootloader-menu-entries + boot-parameters-store-crypto-devices + boot-parameters-store-device + boot-parameters-store-directory-prefix + boot-parameters-store-mount-point + boot-parameters-locale + boot-parameters-kernel + boot-parameters-kernel-arguments + boot-parameters-initrd + boot-parameters-multiboot-modules + boot-parameters-version + %boot-parameters-version + + read-boot-parameters + read-boot-parameters-file + bootable-kernel-arguments + + boot-parameters->menu-entry + + ensure-not-/dev + system-linux-image-file-name)) + +;;; +;;; Boot parameters +;;; + +;;; Version 1 was introduced early 2022 to mark the departure from long option +;;; names such as '--load' to the more conventional initrd option names like +;;; 'gnu.load'. +;;; +;;; When bumping the boot-parameters version, increment it by one (1). +(define %boot-parameters-version 1) + +(define-record-type* + boot-parameters make-boot-parameters boot-parameters? + (label boot-parameters-label) + ;; Because we will use the 'store-device' to create the GRUB search command, + ;; the 'store-device' has slightly different semantics than 'root-device'. + ;; The 'store-device' can be a file system uuid, a file system label, or #f, + ;; but it cannot be a device file name such as "/dev/sda3", since GRUB would + ;; not understand that. The 'root-device', on the other hand, corresponds + ;; exactly to the device field of the object representing the + ;; OS's root file system, so it might be a device file name like + ;; "/dev/sda3". The 'store-directory-prefix' field contains #f or the store + ;; file name inside the 'store-device' as it is seen by GRUB, e.g. it would + ;; contain "/storefs" if the store is located in that subvolume of a btrfs + ;; partition. + (root-device boot-parameters-root-device) + (bootloader-name boot-parameters-bootloader-name) + (bootloader-menu-entries ;list of + boot-parameters-bootloader-menu-entries) + (store-device boot-parameters-store-device) + (store-mount-point boot-parameters-store-mount-point) + (store-directory-prefix boot-parameters-store-directory-prefix) + (store-crypto-devices boot-parameters-store-crypto-devices + (default '())) + (locale boot-parameters-locale) + (kernel boot-parameters-kernel) + (kernel-arguments boot-parameters-kernel-arguments) + (initrd boot-parameters-initrd) + (multiboot-modules boot-parameters-multiboot-modules) + (version boot-parameters-version ;positive integer + (default %boot-parameters-version))) + +(define (read-boot-parameters port) + "Read boot parameters from PORT and return the corresponding + object. Raise an error if the format is unrecognized." + (define device-sexp->device + (match-lambda + (('uuid (? symbol? type) (? bytevector? bv)) + (bytevector->uuid bv type)) + (('file-system-label (? string? label)) + (file-system-label label)) + ((? bytevector? bv) ;old format + (bytevector->uuid bv 'dce)) + ((? string? device) + (if (string-contains device ":/") + device ; nfs-root + ;; It used to be that we would not distinguish between labels and + ;; device names. Try to infer the right thing here. + (if (string-prefix? "/" device) + device + (file-system-label device)))))) + (define uuid-sexp->uuid + (match-lambda + (('uuid (? symbol? type) (? bytevector? bv)) + (bytevector->uuid bv type)) + (x + (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port)) + #f))) + + ;; New versions are not backward-compatible, so only accept past and current + ;; versions, not future ones. + (define (version? n) + (member n (iota (1+ %boot-parameters-version)))) + + (match (read port) + (('boot-parameters ('version (? version? version)) + ('label label) ('root-device root) + ('kernel kernel) + rest ...) + (boot-parameters + (version version) + (label label) + (root-device (device-sexp->device root)) + + (bootloader-name + (match (assq 'bootloader-name rest) + ((_ args) args) + (#f 'grub))) ; for compatibility reasons. + + (bootloader-menu-entries + (match (assq 'bootloader-menu-entries rest) + ((_ entries) (map sexp->menu-entry entries)) + (#f '()))) + + ;; In the past, we would store the directory name of linux instead of + ;; the absolute file name of its image. Detect that and correct it. + (kernel (if (string=? kernel (direct-store-path kernel)) + (string-append kernel "/" + (system-linux-image-file-name)) + kernel)) + + (kernel-arguments + (match (assq 'kernel-arguments rest) + ((_ args) args) + (#f '()))) ;the old format + + (initrd + (match (assq 'initrd rest) + (('initrd ('string-append directory file)) ;the old format + (string-append directory file)) + (('initrd (? string? file)) + file) + (#f #f))) + + (multiboot-modules + (match (assq 'multiboot-modules rest) + ((_ args) args) + (#f '()))) + + (locale + (match (assq 'locale rest) + ((_ locale) locale) + (#f #f))) + + (store-device + ;; Linux device names like "/dev/sda1" are not suitable GRUB device + ;; identifiers, so we just filter them out. + (ensure-not-/dev + (match (assq 'store rest) + (('store ('device #f) _ ...) + root-device) + (('store ('device device) _ ...) + (device-sexp->device device)) + (_ ;the old format + root-device)))) + + (store-directory-prefix + (match (assq 'store rest) + (('store . store-data) + (match (assq 'directory-prefix store-data) + (('directory-prefix prefix) prefix) + ;; No directory-prefix found. + (_ #f))) + (_ + ;; No store found, old format. + #f))) + + (store-crypto-devices + (match (assq 'store rest) + (('store . store-data) + (match (assq 'crypto-devices store-data) + (('crypto-devices (devices ...)) + (map uuid-sexp->uuid devices)) + (('crypto-devices dev) + (warning (G_ "unrecognized crypto-devices ~S at '~a'~%") + dev (port-filename port)) + '()) + (_ + ;; No crypto-devices found. + '()))) + (_ + ;; No store found, old format. + '()))) + + (store-mount-point + (match (assq 'store rest) + (('store ('device _) ('mount-point mount-point) _ ...) + mount-point) + (_ ;the old format + "/"))))) + (x ;unsupported format + (raise + (make-compound-condition + (formatted-message + (G_ "unrecognized boot parameters at '~a'~%") + (port-filename port)) + (condition + (&fix-hint (hint (format #f (G_ "This probably means that this version +of Guix is older than the one that created @file{~a}. To address this, you +need to update Guix: + +@example +guix pull +@end example") + (port-filename port)))))))))) + +(define (read-boot-parameters-file system) + "Read boot parameters from SYSTEM's (system or generation) \"parameters\" +file and returns the corresponding object or #f if the +format is unrecognized. +The object has its kernel-arguments extended in order to make it bootable." + (let* ((file (string-append system "/parameters")) + (params (call-with-input-file file read-boot-parameters)) + (root (boot-parameters-root-device params)) + (version (boot-parameters-version params))) + (boot-parameters + (inherit params) + (kernel-arguments (append (bootable-kernel-arguments system root version) + (boot-parameters-kernel-arguments params)))))) + +(define* (bootable-kernel-arguments system root-device version) + "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE. +VERSION is the target version of the boot-parameters record." + ;; If the version is newer than 0, we use the new style initrd parameter + ;; names, otherwise we use the legacy ones. This is to maintain backward + ;; compatibility when producing bootloader configurations for older + ;; generations. + (define version>0? (> version 0)) + (let ((root (file-system-device->string root-device + #:uuid-type 'dce))) + (append + (if (string=? root "none") + '() ; Ignore the case where the root is "none" (typically tmpfs). + ;; Note: Always use the DCE format because that's what + ;; (gnu build linux-boot) expects for the 'root' + ;; kernel command-line option. + (list (string-append (if version>0? "root=" "--root=") root))) + (list #~(string-append (if #$version>0? "gnu.system=" "--system=") #$system) + #~(string-append (if #$version>0? "gnu.load=" "--load=") + #$system "/boot"))))) + +(define (boot-parameters->menu-entry conf) + "Return a instance given CONF, a instance." + (let* ((kernel (boot-parameters-kernel conf)) + (multiboot-modules (boot-parameters-multiboot-modules conf)) + (multiboot? (pair? multiboot-modules))) + (menu-entry + (label (boot-parameters-label conf)) + (device (boot-parameters-store-device conf)) + (device-mount-point (boot-parameters-store-mount-point conf)) + (linux (and (not multiboot?) kernel)) + (linux-arguments (if (not multiboot?) + (boot-parameters-kernel-arguments conf) + '())) + (initrd (boot-parameters-initrd conf)) + (multiboot-kernel (and multiboot? kernel)) + (multiboot-arguments (if multiboot? + (boot-parameters-kernel-arguments conf) + '())) + (multiboot-modules (if multiboot? + (boot-parameters-multiboot-modules conf) + '()))))) + +(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 +file system labels." + (if (and (string? device) (string-prefix? "/" device)) + #f + device)) + +;; XXX: defined here instead of (gnu system) to prevent dependency loop +(define* (system-linux-image-file-name #:optional + (target (or (%current-target-system) + (%current-system)))) + "Return the basename of the kernel image file for TARGET." + (cond + ((string-prefix? "arm" target) "zImage") + ((string-prefix? "mips" target) "vmlinuz") + ((string-prefix? "aarch64" target) "Image") + ((string-prefix? "riscv64" target) "Image") + (else "bzImage"))) + +;;; boot.scm ends here diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 0305128763..7000c470ed 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -70,6 +70,7 @@ (define-module (guix scripts system) #:use-module (gnu image) #:use-module (gnu system) #:use-module (gnu bootloader) + #:use-module (gnu system boot) #:use-module (gnu system file-systems) #:use-module (gnu system image) #:use-module (gnu system mapped-devices) diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm index 03a1d01aff..2e7976aa6c 100644 --- a/tests/boot-parameters.scm +++ b/tests/boot-parameters.scm @@ -27,6 +27,7 @@ (define-module (test-boot-parameters) #:use-module (gnu bootloader) #:use-module (gnu bootloader grub) #:use-module (gnu system) + #:use-module (gnu system boot) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) #:use-module ((guix diagnostics) #:select (formatted-message?)) -- 2.45.2