@@ -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))
@@ -70,6 +70,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)
@@ -143,31 +144,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
@@ -327,210 +308,6 @@ (define* (operating-system-kernel-arguments
;;; 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>
- 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 <file-system> 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 <menu-entry>
- 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
-<boot-parameters> 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 <boot-parameters> 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 <menu-entry> instance given CONF, a <boot-parameters> instance."
(let* ((kernel (boot-parameters-kernel conf))
@@ -692,17 +469,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."
new file mode 100644
@@ -0,0 +1,296 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
+;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
+;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
+;;; Copyright © 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <jannek@gnu.org>
+;;; Copyright © 2020, 2022 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
+;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
+;;; Copyright © 2023 Felix Lechner <felix.lechner@lease-up.com>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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
+
+ 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>
+ 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 <file-system> 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 <menu-entry>
+ 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
+<boot-parameters> 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 <boot-parameters> 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 (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
@@ -66,6 +66,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)
@@ -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?))
From: Felix Lechner <felix.lechner@lease-up.com> Required to avoid a missing dependency error on build-side. * gnu/system.scm (<boot-parameters>): Move this record, and... (system-linux-image-file-name, %boot-parameters-version, ensure-not-/dev, read-boot-parameters, read-boot-parameters-file): ...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. Change-Id: I6944ffd4c323c776005b0cef23218bffae59be23 --- gnu/machine/ssh.scm | 1 + gnu/system.scm | 236 +----------------------------- gnu/system/boot.scm | 296 ++++++++++++++++++++++++++++++++++++++ guix/scripts/system.scm | 1 + tests/boot-parameters.scm | 1 + 5 files changed, 300 insertions(+), 235 deletions(-) create mode 100644 gnu/system/boot.scm