[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-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    ;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-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
7c414262 JP	186	(define-with-syntax-properties (warn-target-field-deprecation
	187	(value properties))
	188	(when value
	189	(warning (source-properties->location properties)
	190	(G_ "the 'target' field is deprecated, please use 'targets' \
	191	instead~%")))
	192	value)
baf4272d	193
b09a8da4 MO	194	(define-record-type* <bootloader-configuration>
	195	bootloader-configuration make-bootloader-configuration
	196	bootloader-configuration?
91b6873b	197	(bootloader bootloader-configuration-bootloader) ;<bootloader>
2ca982ff MC	198	(targets %bootloader-configuration-targets ;list of strings
	199	(default #f))
	200	(target %bootloader-configuration-target ;deprecated
baf4272d	201	(default #f) (sanitize warn-target-field-deprecation))
ac9cd78e	202	(menu-entries bootloader-configuration-menu-entries ;list of <menu-entry>
91b6873b LC	203	(default '()))
	204	(default-entry bootloader-configuration-default-entry ;integer
	205	(default 0))
	206	(timeout bootloader-configuration-timeout ;seconds as integer
	207	(default 5))
8d058e7b LC	208	(keyboard-layout bootloader-configuration-keyboard-layout ;<keyboard-layout> \| #f
8d058e7b LC	209	(default #f))
91b6873b LC	210	(theme bootloader-configuration-theme ;bootloader-specific theme
	211	(default #f))
	212	(terminal-outputs bootloader-configuration-terminal-outputs ;list of symbols
	213	(default '(gfxterm)))
	214	(terminal-inputs bootloader-configuration-terminal-inputs ;list of symbols
	215	(default '()))
	216	(serial-unit bootloader-configuration-serial-unit ;integer \| #f
	217	(default #f))
	218	(serial-speed bootloader-configuration-serial-speed ;integer \| #f
	219	(default #f)))
b09a8da4	220
baf4272d LC	221	(define-deprecated (bootloader-configuration-target config)
baf4272d LC	222	bootloader-configuration-targets
2ca982ff MC	223	(%bootloader-configuration-target config))
	224
	225	(define (bootloader-configuration-targets config)
	226	(or (%bootloader-configuration-targets config)
	227	;; TODO: Remove after the deprecated 'target' field is removed.
baf4272d	228	(list (%bootloader-configuration-target config))
2ca982ff MC	229	;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
	230	;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
	231	;; hence the default value of '(#f) rather than '().
	232	(list #f)))
	233
b09a8da4 MO	234	\f
	235	;;;
	236	;;; Bootloaders.
	237	;;;
	238
	239	(define (bootloader-modules)
	240	"Return the list of bootloader modules."
	241	(all-modules (map (lambda (entry)
	242	`(,entry . "gnu/bootloader"))
3c0128b0 LC	243	%load-path)
3c0128b0 LC	244	#:warn warn-about-load-error))
b09a8da4 MO	245
	246	(define %bootloaders
	247	;; The list of publically-known bootloaders.
	248	(delay (fold-module-public-variables (lambda (obj result)
	249	(if (bootloader? obj)
	250	(cons obj result)
	251	result))
	252	'()
	253	(bootloader-modules))))
	254
	255	(define (lookup-bootloader-by-name name)
	256	"Return the bootloader called NAME."
	257	(or (find (lambda (bootloader)
	258	(eq? name (bootloader-name bootloader)))
	259	(force %bootloaders))
	260	(leave (G_ "~a: no such bootloader~%") name)))
74eeb11d	261
ede4117f	262	(define (efi-bootloader-profile files bootloader-package hooks)
74eeb11d S	263	"Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
	264	links to additional FILES from the store. This collection is meant to be used
	265	by the bootloader installer.
	266
	267	FILES is a list of file or directory names from the store, which will be
	268	symlinked into the collection/ directory. If a directory name ends with '/',
	269	then the directory content instead of the directory itself will be symlinked
	270	into the collection/ directory.
	271
	272	FILES may contain file like objects produced by functions like plain-file,
ede4117f S	273	local-file, etc., or package contents produced with file-append.
	274
	275	HOOKS lists additional hook functions to modify the profile."
74eeb11d S	276	(define (bootloader-collection manifest)
	277	(define build
	278	(with-imported-modules '((guix build utils)
	279	(ice-9 ftw)
	280	(srfi srfi-1)
	281	(srfi srfi-26))
	282	#~(begin
	283	(use-modules ((guix build utils)
	284	#:select (mkdir-p strip-store-file-name))
	285	((ice-9 ftw)
	286	#:select (scandir))
	287	((srfi srfi-1)
	288	#:select (append-map every remove))
	289	((srfi srfi-26)
	290	#:select (cut)))
	291	(define (symlink-to file directory transform)
	292	"Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
	293	(symlink file (string-append directory "/" (transform file))))
	294	(define (directory-content directory)
	295	"Creates a list of absolute path names inside DIRECTORY."
	296	(map (lambda (name)
	297	(string-append directory name))
	298	(or (scandir directory (lambda (name)
	299	(not (member name '("." "..")))))
	300	'())))
	301	(define name-ends-with-/? (cut string-suffix? "/" <>))
	302	(define (name-is-store-entry? name)
	303	"Return #t if NAME is a direct store entry and nothing inside."
	304	(not (string-index (strip-store-file-name name) #\/)))
	305	(let* ((collection (string-append #$output "/collection"))
	306	(files '#$files)
	307	(directories (filter name-ends-with-/? files))
	308	(names-from-directories
	309	(append-map (lambda (directory)
	310	(directory-content directory))
	311	directories))
	312	(names (append names-from-directories
	313	(remove name-ends-with-/? files))))
	314	(mkdir-p collection)
	315	(if (every file-exists? names)
	316	(begin
	317	(for-each (lambda (name)
	318	(symlink-to name collection
	319	(if (name-is-store-entry? name)
	320	strip-store-file-name
	321	basename)))
	322	names)
	323	#t)
	324	#f)))))
	325
	326	(gexp->derivation "bootloader-collection"
	327	build
	328	#:local-build? #t
	329	#:substitutable? #f
	330	#:properties
	331	`((type . profile-hook)
	332	(hook . bootloader-collection))))
	333
	334	(profile (content (packages->manifest (list bootloader-package)))
ede4117f S	335	(name "bootloader-profile")
ede4117f S	336	(hooks (append (list bootloader-collection) hooks))
74eeb11d S	337	(locales? #f)
	338	(allow-collisions? #f)
	339	(relative-symlinks? #f)))
	340
	341	(define* (efi-bootloader-chain files
	342	final-bootloader
	343	#:key
ede4117f	344	(hooks '())
74eeb11d S	345	installer)
	346	"Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
	347	certain directories and files from the store given in the list of FILES.
	348
	349	FILES may contain file like objects produced by functions like plain-file,
	350	local-file, etc., or package contents produced with file-append. They will be
	351	collected inside a directory collection/ inside a generated bootloader profile,
	352	which will be passed to the INSTALLER.
	353
	354	If a directory name in FILES ends with '/', then the directory content instead
	355	of the directory itself will be symlinked into the collection/ directory.
	356
ede4117f S	357	The procedures in the HOOKS list can be used to further modify the bootloader
ede4117f S	358	profile. It is possible to pass a single function instead of a list.
74eeb11d S	359
74eeb11d S	360	If the INSTALLER argument is used, then this function will be called to install
ede4117f	361	the bootloader. Otherwise the installer of the FINAL-BOOTLOADER will be called."
74eeb11d S	362	(let* ((final-installer (or installer
	363	(bootloader-installer final-bootloader)))
	364	(profile (efi-bootloader-profile files
	365	(bootloader-package final-bootloader)
ede4117f S	366	(if (list? hooks)
	367	hooks
	368	(list hooks)))))
74eeb11d S	369	(bootloader
	370	(inherit final-bootloader)
	371	(package profile)
	372	(installer
	373	#~(lambda (bootloader target mount-point)
	374	(#$final-installer bootloader target mount-point)
	375	(copy-recursively
	376	(string-append bootloader "/collection")
	377	(string-append mount-point target)
	378	#:follow-symlinks? #t
	379	#:log (%make-void-port "w")))))))