[jackhill/guix/guix.git] / gnu / bootloader.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 (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 (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->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-additional-configuration

            %bootloaders
            lookup-bootloader-by-name

            efi-bootloader-chain))

\f
;;;
;;; 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>

(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
;;;
;;; 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))

\f
;;;
;;; Bootloader configuration record.
;;;

;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.

(define-syntax-rule (warn-target-field-deprecation value)
  (%warn-target-field-deprecation value (current-source-location)))

(define-record-type* <bootloader-configuration>
  bootloader-configuration make-bootloader-configuration
  bootloader-configuration?
  (bootloader         bootloader-configuration-bootloader) ;<bootloader>
  (targets            %bootloader-configuration-targets    ;list of strings
                      (default #f))
  (target             %bootloader-configuration-target ;deprecated
                      (default #f) (sanitize warn-target-field-deprecation))
  (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)))

(define (%warn-target-field-deprecation value location)
  (when value
    (warning (source-properties->location location)
             (G_ "the 'target' field is deprecated, please use 'targets' \
instead~%")))
  value)

(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)))

\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 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")))))))
Commit	Line	Data
b09a8da4 MO	1	;;; GNU Guix --- Functional package management for GNU
b09a8da4 MO	2	;;; Copyright © 2017 David Craven <david@craven.ch>
7feefb3b	3	;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
b09a8da4	4	;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
baf4272d	5	;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
21acd8d6	6	;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
b09a8da4 MO	7	;;;
	8	;;; This file is part of GNU Guix.
	9	;;;
	10	;;; GNU Guix is free software; you can redistribute it and/or modify it
	11	;;; under the terms of the GNU General Public License as published by
	12	;;; the Free Software Foundation; either version 3 of the License, or (at
	13	;;; your option) any later version.
	14	;;;
	15	;;; GNU Guix is distributed in the hope that it will be useful, but
	16	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;;; GNU General Public License for more details.
	19	;;;
	20	;;; You should have received a copy of the GNU General Public License
	21	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	22
	23	(define-module (gnu bootloader)
	24	#:use-module (guix discovery)
74eeb11d S	25	#:use-module (guix gexp)
74eeb11d S	26	#:use-module (guix profiles)
b09a8da4	27	#:use-module (guix records)
baf4272d LC	28	#:use-module (guix deprecation)
	29	#:use-module ((guix ui) #:select (warn-about-load-error))
	30	#:use-module (guix diagnostics)
	31	#:use-module (guix i18n)
b09a8da4	32	#:use-module (srfi srfi-1)
a28cfee8	33	#:use-module (ice-9 match)
8b22107e MO	34	#:export (menu-entry
	35	menu-entry?
	36	menu-entry-label
	37	menu-entry-device
	38	menu-entry-linux
	39	menu-entry-linux-arguments
	40	menu-entry-initrd
1975c754	41	menu-entry-device-mount-point
21acd8d6 JN	42	menu-entry-multiboot-kernel
	43	menu-entry-multiboot-arguments
	44	menu-entry-multiboot-modules
8b22107e	45
a28cfee8 LC	46	menu-entry->sexp
	47	sexp->menu-entry
	48
8b22107e	49	bootloader
b09a8da4 MO	50	bootloader?
	51	bootloader-name
	52	bootloader-package
	53	bootloader-installer
7feefb3b	54	bootloader-disk-image-installer
b09a8da4 MO	55	bootloader-configuration-file
	56	bootloader-configuration-file-generator
	57
	58	bootloader-configuration
	59	bootloader-configuration?
	60	bootloader-configuration-bootloader
2ca982ff MC	61	bootloader-configuration-target ;deprecated
2ca982ff MC	62	bootloader-configuration-targets
b09a8da4 MO	63	bootloader-configuration-menu-entries
	64	bootloader-configuration-default-entry
	65	bootloader-configuration-timeout
8d058e7b	66	bootloader-configuration-keyboard-layout
b09a8da4 MO	67	bootloader-configuration-theme
	68	bootloader-configuration-terminal-outputs
	69	bootloader-configuration-terminal-inputs
	70	bootloader-configuration-serial-unit
	71	bootloader-configuration-serial-speed
	72	bootloader-configuration-additional-configuration
	73
	74	%bootloaders
74eeb11d S	75	lookup-bootloader-by-name
	76
	77	efi-bootloader-chain))
b09a8da4 MO	78
b09a8da4 MO	79	\f
8b22107e MO	80	;;;
	81	;;; Menu-entry record.
	82	;;;
	83
	84	(define-record-type* <menu-entry>
	85	menu-entry make-menu-entry
	86	menu-entry?
	87	(label menu-entry-label)
	88	(device menu-entry-device ; file system uuid, label, or #f
	89	(default #f))
1975c754 DM	90	(device-mount-point menu-entry-device-mount-point
1975c754 DM	91	(default #f))
21acd8d6 JN	92	(linux menu-entry-linux
21acd8d6 JN	93	(default #f))
8b22107e MO	94	(linux-arguments menu-entry-linux-arguments
8b22107e MO	95	(default '())) ; list of string-valued gexps
21acd8d6 JN	96	(initrd menu-entry-initrd ; file name of the initrd as a gexp
	97	(default #f))
	98	(multiboot-kernel menu-entry-multiboot-kernel
	99	(default #f))
	100	(multiboot-arguments menu-entry-multiboot-arguments
	101	(default '())) ; list of string-valued gexps
	102	(multiboot-modules menu-entry-multiboot-modules
	103	(default '()))) ; list of multiboot commands, where
	104	; a command is a list of <string>
8b22107e	105
a28cfee8 LC	106	(define (menu-entry->sexp entry)
	107	"Return ENTRY serialized as an sexp."
	108	(match entry
21acd8d6 JN	109	(($ <menu-entry> label device mount-point linux linux-arguments initrd #f
21acd8d6 JN	110	())
a28cfee8 LC	111	`(menu-entry (version 0)
	112	(label ,label)
	113	(device ,device)
	114	(device-mount-point ,mount-point)
	115	(linux ,linux)
	116	(linux-arguments ,linux-arguments)
21acd8d6 JN	117	(initrd ,initrd)))
	118	(($ <menu-entry> label device mount-point #f () #f
	119	multiboot-kernel multiboot-arguments multiboot-modules)
	120	`(menu-entry (version 0)
	121	(label ,label)
	122	(device ,device)
	123	(device-mount-point ,mount-point)
	124	(multiboot-kernel ,multiboot-kernel)
	125	(multiboot-arguments ,multiboot-arguments)
	126	(multiboot-modules ,multiboot-modules)))))
a28cfee8 LC	127
	128	(define (sexp->menu-entry sexp)
	129	"Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
	130	record."
	131	(match sexp
	132	(('menu-entry ('version 0)
	133	('label label) ('device device)
	134	('device-mount-point mount-point)
	135	('linux linux) ('linux-arguments linux-arguments)
	136	('initrd initrd) _ ...)
	137	(menu-entry
	138	(label label)
	139	(device device)
	140	(device-mount-point mount-point)
	141	(linux linux)
	142	(linux-arguments linux-arguments)
21acd8d6 JN	143	(initrd initrd)))
	144	(('menu-entry ('version 0)
	145	('label label) ('device device)
	146	('device-mount-point mount-point)
	147	('multiboot-kernel multiboot-kernel)
	148	('multiboot-arguments multiboot-arguments)
	149	('multiboot-modules multiboot-modules) _ ...)
	150	(menu-entry
	151	(label label)
	152	(device device)
	153	(device-mount-point mount-point)
	154	(multiboot-kernel multiboot-kernel)
	155	(multiboot-arguments multiboot-arguments)
	156	(multiboot-modules multiboot-modules)))))
a28cfee8	157
8b22107e	158	\f
b09a8da4 MO	159	;;;
	160	;;; Bootloader record.
	161	;;;
	162
	163	;; The <bootloader> record contains fields expressing how the bootloader
	164	;; should be installed. Every bootloader in gnu/bootloader/ directory
	165	;; has to be described by this record.
	166
	167	(define-record-type* <bootloader>
	168	bootloader make-bootloader
	169	bootloader?
	170	(name bootloader-name)
	171	(package bootloader-package)
	172	(installer bootloader-installer)
7feefb3b MO	173	(disk-image-installer bootloader-disk-image-installer
7feefb3b MO	174	(default #f))
b09a8da4 MO	175	(configuration-file bootloader-configuration-file)
	176	(configuration-file-generator bootloader-configuration-file-generator))
	177
	178	\f
	179	;;;
	180	;;; Bootloader configuration record.
	181	;;;
	182
	183	;; The <bootloader-configuration> record contains bootloader independant
	184	;; configuration used to fill bootloader configuration file.
	185
baf4272d LC	186	(define-syntax-rule (warn-target-field-deprecation value)
	187	(%warn-target-field-deprecation value (current-source-location)))
	188
b09a8da4 MO	189	(define-record-type* <bootloader-configuration>
	190	bootloader-configuration make-bootloader-configuration
	191	bootloader-configuration?
91b6873b	192	(bootloader bootloader-configuration-bootloader) ;<bootloader>
2ca982ff MC	193	(targets %bootloader-configuration-targets ;list of strings
	194	(default #f))
	195	(target %bootloader-configuration-target ;deprecated
baf4272d	196	(default #f) (sanitize warn-target-field-deprecation))
ac9cd78e	197	(menu-entries bootloader-configuration-menu-entries ;list of <menu-entry>
91b6873b LC	198	(default '()))
	199	(default-entry bootloader-configuration-default-entry ;integer
	200	(default 0))
	201	(timeout bootloader-configuration-timeout ;seconds as integer
	202	(default 5))
8d058e7b LC	203	(keyboard-layout bootloader-configuration-keyboard-layout ;<keyboard-layout> \| #f
8d058e7b LC	204	(default #f))
91b6873b LC	205	(theme bootloader-configuration-theme ;bootloader-specific theme
	206	(default #f))
	207	(terminal-outputs bootloader-configuration-terminal-outputs ;list of symbols
	208	(default '(gfxterm)))
	209	(terminal-inputs bootloader-configuration-terminal-inputs ;list of symbols
	210	(default '()))
	211	(serial-unit bootloader-configuration-serial-unit ;integer \| #f
	212	(default #f))
	213	(serial-speed bootloader-configuration-serial-speed ;integer \| #f
	214	(default #f)))
b09a8da4	215
baf4272d LC	216	(define (%warn-target-field-deprecation value location)
	217	(when value
	218	(warning (source-properties->location location)
	219	(G_ "the 'target' field is deprecated, please use 'targets' \
	220	instead~%")))
	221	value)
	222
	223	(define-deprecated (bootloader-configuration-target config)
	224	bootloader-configuration-targets
2ca982ff MC	225	(%bootloader-configuration-target config))
	226
	227	(define (bootloader-configuration-targets config)
	228	(or (%bootloader-configuration-targets config)
	229	;; TODO: Remove after the deprecated 'target' field is removed.
baf4272d	230	(list (%bootloader-configuration-target config))
2ca982ff MC	231	;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
	232	;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
	233	;; hence the default value of '(#f) rather than '().
	234	(list #f)))
	235
b09a8da4 MO	236	\f
	237	;;;
	238	;;; Bootloaders.
	239	;;;
	240
	241	(define (bootloader-modules)
	242	"Return the list of bootloader modules."
	243	(all-modules (map (lambda (entry)
	244	`(,entry . "gnu/bootloader"))
3c0128b0 LC	245	%load-path)
3c0128b0 LC	246	#:warn warn-about-load-error))
b09a8da4 MO	247
	248	(define %bootloaders
	249	;; The list of publically-known bootloaders.
	250	(delay (fold-module-public-variables (lambda (obj result)
	251	(if (bootloader? obj)
	252	(cons obj result)
	253	result))
	254	'()
	255	(bootloader-modules))))
	256
	257	(define (lookup-bootloader-by-name name)
	258	"Return the bootloader called NAME."
	259	(or (find (lambda (bootloader)
	260	(eq? name (bootloader-name bootloader)))
	261	(force %bootloaders))
	262	(leave (G_ "~a: no such bootloader~%") name)))
74eeb11d	263
ede4117f	264	(define (efi-bootloader-profile files bootloader-package hooks)
74eeb11d S	265	"Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
	266	links to additional FILES from the store. This collection is meant to be used
	267	by the bootloader installer.
	268
	269	FILES is a list of file or directory names from the store, which will be
	270	symlinked into the collection/ directory. If a directory name ends with '/',
	271	then the directory content instead of the directory itself will be symlinked
	272	into the collection/ directory.
	273
	274	FILES may contain file like objects produced by functions like plain-file,
ede4117f S	275	local-file, etc., or package contents produced with file-append.
	276
	277	HOOKS lists additional hook functions to modify the profile."
74eeb11d S	278	(define (bootloader-collection manifest)
	279	(define build
	280	(with-imported-modules '((guix build utils)
	281	(ice-9 ftw)
	282	(srfi srfi-1)
	283	(srfi srfi-26))
	284	#~(begin
	285	(use-modules ((guix build utils)
	286	#:select (mkdir-p strip-store-file-name))
	287	((ice-9 ftw)
	288	#:select (scandir))
	289	((srfi srfi-1)
	290	#:select (append-map every remove))
	291	((srfi srfi-26)
	292	#:select (cut)))
	293	(define (symlink-to file directory transform)
	294	"Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
	295	(symlink file (string-append directory "/" (transform file))))
	296	(define (directory-content directory)
	297	"Creates a list of absolute path names inside DIRECTORY."
	298	(map (lambda (name)
	299	(string-append directory name))
	300	(or (scandir directory (lambda (name)
	301	(not (member name '("." "..")))))
	302	'())))
	303	(define name-ends-with-/? (cut string-suffix? "/" <>))
	304	(define (name-is-store-entry? name)
	305	"Return #t if NAME is a direct store entry and nothing inside."
	306	(not (string-index (strip-store-file-name name) #\/)))
	307	(let* ((collection (string-append #$output "/collection"))
	308	(files '#$files)
	309	(directories (filter name-ends-with-/? files))
	310	(names-from-directories
	311	(append-map (lambda (directory)
	312	(directory-content directory))
	313	directories))
	314	(names (append names-from-directories
	315	(remove name-ends-with-/? files))))
	316	(mkdir-p collection)
	317	(if (every file-exists? names)
	318	(begin
	319	(for-each (lambda (name)
	320	(symlink-to name collection
	321	(if (name-is-store-entry? name)
	322	strip-store-file-name
	323	basename)))
	324	names)
	325	#t)
	326	#f)))))
	327
	328	(gexp->derivation "bootloader-collection"
	329	build
	330	#:local-build? #t
	331	#:substitutable? #f
	332	#:properties
	333	`((type . profile-hook)
	334	(hook . bootloader-collection))))
	335
	336	(profile (content (packages->manifest (list bootloader-package)))
ede4117f S	337	(name "bootloader-profile")
ede4117f S	338	(hooks (append (list bootloader-collection) hooks))
74eeb11d S	339	(locales? #f)
	340	(allow-collisions? #f)
	341	(relative-symlinks? #f)))
	342
	343	(define* (efi-bootloader-chain files
	344	final-bootloader
	345	#:key
ede4117f	346	(hooks '())
74eeb11d S	347	installer)
	348	"Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
	349	certain directories and files from the store given in the list of FILES.
	350
	351	FILES may contain file like objects produced by functions like plain-file,
	352	local-file, etc., or package contents produced with file-append. They will be
	353	collected inside a directory collection/ inside a generated bootloader profile,
	354	which will be passed to the INSTALLER.
	355
	356	If a directory name in FILES ends with '/', then the directory content instead
	357	of the directory itself will be symlinked into the collection/ directory.
	358
ede4117f S	359	The procedures in the HOOKS list can be used to further modify the bootloader
ede4117f S	360	profile. It is possible to pass a single function instead of a list.
74eeb11d S	361
74eeb11d S	362	If the INSTALLER argument is used, then this function will be called to install
ede4117f	363	the bootloader. Otherwise the installer of the FINAL-BOOTLOADER will be called."
74eeb11d S	364	(let* ((final-installer (or installer
	365	(bootloader-installer final-bootloader)))
	366	(profile (efi-bootloader-profile files
	367	(bootloader-package final-bootloader)
ede4117f S	368	(if (list? hooks)
	369	hooks
	370	(list hooks)))))
74eeb11d S	371	(bootloader
	372	(inherit final-bootloader)
	373	(package profile)
	374	(installer
	375	#~(lambda (bootloader target mount-point)
	376	(#$final-installer bootloader target mount-point)
	377	(copy-recursively
	378	(string-append bootloader "/collection")
	379	(string-append mount-point target)
	380	#:follow-symlinks? #t
	381	#:log (%make-void-port "w")))))))