;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (gnu bootloader)
#:use-module (guix discovery)
+ #:use-module (guix gexp)
+ #:use-module (guix profiles)
#:use-module (guix records)
#:use-module (guix ui)
#:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
#:export (menu-entry
menu-entry?
menu-entry-label
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->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-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-additional-configuration
%bootloaders
- lookup-bootloader-by-name))
+ lookup-bootloader-by-name
+
+ efi-bootloader-chain))
\f
;;;
(default #f))
(device-mount-point menu-entry-device-mount-point
(default #f))
- (linux menu-entry-linux)
+ (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
+ (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>
+
+(define (menu-entry->sexp entry)
+ "Return ENTRY serialized as an sexp."
+ (match entry
+ (($ <menu-entry> label device mount-point linux linux-arguments initrd #f
+ ())
+ `(menu-entry (version 0)
+ (label ,label)
+ (device ,device)
+ (device-mount-point ,mount-point)
+ (linux ,linux)
+ (linux-arguments ,linux-arguments)
+ (initrd ,initrd)))
+ (($ <menu-entry> label device mount-point #f () #f
+ multiboot-kernel multiboot-arguments multiboot-modules)
+ `(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)))))
+
+(define (sexp->menu-entry sexp)
+ "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
+record."
+ (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 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 device)
+ (device-mount-point mount-point)
+ (multiboot-kernel multiboot-kernel)
+ (multiboot-arguments multiboot-arguments)
+ (multiboot-modules multiboot-modules)))))
\f
;;;
(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))
(define-record-type* <bootloader-configuration>
bootloader-configuration make-bootloader-configuration
bootloader-configuration?
- (bootloader bootloader-configuration-bootloader) ; <bootloader>
- (device bootloader-configuration-device ; string
- (default #f))
- (target %bootloader-configuration-target ; string
- (default #f))
- (menu-entries bootloader-configuration-menu-entries ; list of <boot-parameters>
- (default '()))
- (default-entry bootloader-configuration-default-entry ; integer
- (default 0))
- (timeout bootloader-configuration-timeout ; seconds as integer
- (default 5))
- (theme bootloader-configuration-theme ; bootloader-specific theme
- (default #f))
- (terminal-outputs bootloader-configuration-terminal-outputs ; list of symbols
- (default '(gfxterm)))
- (terminal-inputs bootloader-configuration-terminal-inputs ; list of symbols
- (default '()))
- (serial-unit bootloader-configuration-serial-unit ; integer | #f
- (default #f))
- (serial-speed bootloader-configuration-serial-speed ; integer | #f
- (default #f))
- (additional-configuration bootloader-configuration-additional-configuration ; record
- (default #f)))
-
-(define (bootloader-configuration-target config)
- (or (%bootloader-configuration-target config)
- (let ((device (bootloader-configuration-device config)))
- (when device
- (warning
- (G_ "The 'device' field of bootloader configurations is deprecated.~%"))
- (warning (G_ "Use 'target' instead.~%")))
- device)))
+ (bootloader bootloader-configuration-bootloader) ;<bootloader>
+ (target bootloader-configuration-target ;string
+ (default #f))
+ (menu-entries bootloader-configuration-menu-entries ;list of <menu-entry>
+ (default '()))
+ (default-entry bootloader-configuration-default-entry ;integer
+ (default 0))
+ (timeout bootloader-configuration-timeout ;seconds as integer
+ (default 5))
+ (keyboard-layout bootloader-configuration-keyboard-layout ;<keyboard-layout> | #f
+ (default #f))
+ (theme bootloader-configuration-theme ;bootloader-specific theme
+ (default #f))
+ (terminal-outputs bootloader-configuration-terminal-outputs ;list of symbols
+ (default '(gfxterm)))
+ (terminal-inputs bootloader-configuration-terminal-inputs ;list of symbols
+ (default '()))
+ (serial-unit bootloader-configuration-serial-unit ;integer | #f
+ (default #f))
+ (serial-speed bootloader-configuration-serial-speed ;integer | #f
+ (default #f)))
\f
;;;
(eq? name (bootloader-name bootloader)))
(force %bootloaders))
(leave (G_ "~a: no such bootloader~%") name)))
+
+(define (efi-bootloader-profile files bootloader-package hooks)
+ "Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
+links to additional FILES from the store. This collection 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 collection/ directory. If a directory name ends with '/',
+then the directory content instead of the directory itself will be symlinked
+into the collection/ directory.
+
+FILES may contain file like objects produced by functions like plain-file,
+local-file, etc., or package contents produced with file-append.
+
+HOOKS lists additional hook functions to modify the profile."
+ (define (bootloader-collection manifest)
+ (define build
+ (with-imported-modules '((guix build utils)
+ (ice-9 ftw)
+ (srfi srfi-1)
+ (srfi srfi-26))
+ #~(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* ((collection (string-append #$output "/collection"))
+ (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 collection)
+ (if (every file-exists? names)
+ (begin
+ (for-each (lambda (name)
+ (symlink-to name collection
+ (if (name-is-store-entry? name)
+ strip-store-file-name
+ basename)))
+ names)
+ #t)
+ #f)))))
+
+ (gexp->derivation "bootloader-collection"
+ build
+ #:local-build? #t
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . bootloader-collection))))
+
+ (profile (content (packages->manifest (list bootloader-package)))
+ (name "bootloader-profile")
+ (hooks (append (list bootloader-collection) hooks))
+ (locales? #f)
+ (allow-collisions? #f)
+ (relative-symlinks? #f)))
+
+(define* (efi-bootloader-chain files
+ final-bootloader
+ #:key
+ (hooks '())
+ installer)
+ "Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
+certain directories and files from the store given in the list of FILES.
+
+FILES may contain file like objects produced by functions like plain-file,
+local-file, etc., or package contents produced with file-append. They will be
+collected inside a directory collection/ inside a generated bootloader profile,
+which will be passed to the INSTALLER.
+
+If a directory name in FILES ends with '/', then the directory content instead
+of the directory itself will be symlinked into the collection/ directory.
+
+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 function will be called to install
+the bootloader. Otherwise the installer of the FINAL-BOOTLOADER will be called."
+ (let* ((final-installer (or installer
+ (bootloader-installer final-bootloader)))
+ (profile (efi-bootloader-profile files
+ (bootloader-package final-bootloader)
+ (if (list? hooks)
+ hooks
+ (list hooks)))))
+ (bootloader
+ (inherit final-bootloader)
+ (package profile)
+ (installer
+ #~(lambda (bootloader target mount-point)
+ (#$final-installer bootloader target mount-point)
+ (copy-recursively
+ (string-append bootloader "/collection")
+ (string-append mount-point target)
+ #:follow-symlinks? #t
+ #:log (%make-void-port "w")))))))