TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
guix/gnu/bootloader.scm

449 lines
18 KiB
Scheme
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
;;;
;;; 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 bootloader)
#: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)
#:use-module (guix deprecation)
#:use-module ((guix ui) #:select (warn-about-load-error))
#:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:export (menu-entry
menu-entry?
menu-entry-label
menu-entry-device
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
menu-entry->sexp
sexp->menu-entry
bootloader
bootloader?
bootloader-name
bootloader-package
bootloader-installer
bootloader-disk-image-installer
bootloader-configuration-file
bootloader-configuration-file-generator
bootloader-configuration
bootloader-configuration?
bootloader-configuration-bootloader
bootloader-configuration-target ;deprecated
bootloader-configuration-targets
bootloader-configuration-menu-entries
bootloader-configuration-default-entry
bootloader-configuration-timeout
bootloader-configuration-keyboard-layout
bootloader-configuration-theme
bootloader-configuration-terminal-outputs
bootloader-configuration-terminal-inputs
bootloader-configuration-serial-unit
bootloader-configuration-serial-speed
bootloader-configuration-device-tree-support?
bootloader-configuration-extra-initrd
%bootloaders
lookup-bootloader-by-name
efi-bootloader-chain))
;;;
;;; Menu-entry record.
;;;
(define-record-type* <menu-entry>
menu-entry make-menu-entry
menu-entry?
(label menu-entry-label)
(device menu-entry-device ; file system uuid, label, or #f
(default #f))
(device-mount-point menu-entry-device-mount-point
(default #f))
(linux menu-entry-linux
(default #f))
(linux-arguments menu-entry-linux-arguments
(default '())) ; list of string-valued gexps
(initrd menu-entry-initrd ; file name of the initrd as a gexp
(default #f))
(multiboot-kernel menu-entry-multiboot-kernel
(default #f))
(multiboot-arguments menu-entry-multiboot-arguments
(default '())) ; list of string-valued gexps
(multiboot-modules menu-entry-multiboot-modules
(default '())) ; list of multiboot commands, where
; a command is a list of <string>
(chain-loader menu-entry-chain-loader
(default #f))) ; string, path of efi file
(define (report-menu-entry-error menu-entry)
(raise
(condition
(&message
(message
(format #f (G_ "invalid menu-entry: ~a") menu-entry)))
(&fix-hint
(hint
(G_ "Please chose only one of:
@enumerate
@item direct boot by specifying fields @code{linux},
@code{linux-arguments} and @code{linux-modules},
@item multiboot by specifying fields @code{multiboot-kernel},
@code{multiboot-arguments} and @code{multiboot-modules},
@item chain-loader by specifying field @code{chain-loader}.
@end enumerate"))))))
(define (menu-entry->sexp entry)
"Return ENTRY serialized as an sexp."
(define (device->sexp device)
(match device
((? uuid? uuid)
`(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
((? file-system-label? label)
`(label ,(file-system-label->string label)))
(_ device)))
(match entry
(($ <menu-entry> label device mount-point
(? identity linux) linux-arguments (? identity initrd)
#f () () #f)
`(menu-entry (version 0)
(label ,label)
(device ,(device->sexp device))
(device-mount-point ,mount-point)
(linux ,linux)
(linux-arguments ,linux-arguments)
(initrd ,initrd)))
(($ <menu-entry> label device mount-point #f () #f
(? identity multiboot-kernel) multiboot-arguments
multiboot-modules #f)
`(menu-entry (version 0)
(label ,label)
(device ,(device->sexp device))
(device-mount-point ,mount-point)
(multiboot-kernel ,multiboot-kernel)
(multiboot-arguments ,multiboot-arguments)
(multiboot-modules ,multiboot-modules)))
(($ <menu-entry> label device mount-point #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)))
(_ (report-menu-entry-error entry))))
(define (sexp->menu-entry sexp)
"Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
(define (sexp->device device-sexp)
(match device-sexp
(('uuid type uuid-string)
(uuid uuid-string type))
(('label label)
(file-system-label label))
(_ device-sexp)))
(match sexp
(('menu-entry ('version 0)
('label label) ('device device)
('device-mount-point mount-point)
('linux linux) ('linux-arguments linux-arguments)
('initrd initrd) _ ...)
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
(linux linux)
(linux-arguments linux-arguments)
(initrd initrd)))
(('menu-entry ('version 0)
('label label) ('device device)
('device-mount-point mount-point)
('multiboot-kernel multiboot-kernel)
('multiboot-arguments multiboot-arguments)
('multiboot-modules multiboot-modules) _ ...)
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
(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) _ ...)
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
(chain-loader chain-loader)))))
;;;
;;; Bootloader record.
;;;
;; The <bootloader> record contains fields expressing how the bootloader
;; should be installed. Every bootloader in gnu/bootloader/ directory
;; has to be described by this record.
(define-record-type* <bootloader>
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 configuration record.
;;;
;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.
(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-record-type* <bootloader-configuration>
bootloader-configuration make-bootloader-configuration
bootloader-configuration?
(bootloader
bootloader-configuration-bootloader) ;<bootloader>
(targets %bootloader-configuration-targets
(default #f)) ;list of strings
(target %bootloader-configuration-target ;deprecated
(default #f)
(sanitize warn-target-field-deprecation))
(menu-entries bootloader-configuration-menu-entries
(default '())) ;list of <menu-entry>
(default-entry bootloader-configuration-default-entry
(default 0)) ;integer
(timeout bootloader-configuration-timeout
(default 5)) ;seconds as integer
(keyboard-layout bootloader-configuration-keyboard-layout
(default #f)) ;<keyboard-layout> | #f
(theme bootloader-configuration-theme
(default #f)) ;bootloader-specific theme
(terminal-outputs bootloader-configuration-terminal-outputs
(default '(gfxterm))) ;list of symbols
(terminal-inputs bootloader-configuration-terminal-inputs
(default '())) ;list of symbols
(serial-unit bootloader-configuration-serial-unit
(default #f)) ;integer | #f
(serial-speed bootloader-configuration-serial-speed
(default #f)) ;integer | #f
(device-tree-support? bootloader-configuration-device-tree-support?
(default #t)) ;boolean
(extra-initrd bootloader-configuration-extra-initrd
(default #f))) ;string | #f
(define-deprecated (bootloader-configuration-target config)
bootloader-configuration-targets
(%bootloader-configuration-target config))
(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 DEVICE is #f,
;; hence the default value of '(#f) rather than '().
(list #f)))
;;;
;;; Bootloaders.
;;;
(define (bootloader-modules)
"Return the list of bootloader modules."
(all-modules (map (lambda (entry)
`(,entry . "gnu/bootloader"))
%load-path)
#:warn warn-about-load-error))
(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 the
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 DIRECTORY."
(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 inside."
(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 PACKAGES,
and optional directories and files from the store given in the list of FILES.
The package of the FINAL-BOOTLOADER and all PACKAGES and FILES will be placed
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 instead
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 bootloader
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 called
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)))))
Reference in New Issue View Git Blame Copy Permalink