[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

            %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
b09a8da4 MO	72
b09a8da4 MO	73	%bootloaders
74eeb11d S	74	lookup-bootloader-by-name
	75
	76	efi-bootloader-chain))
b09a8da4 MO	77
b09a8da4 MO	78	\f
8b22107e MO	79	;;;
	80	;;; Menu-entry record.
	81	;;;
	82
	83	(define-record-type* <menu-entry>
	84	menu-entry make-menu-entry
	85	menu-entry?
	86	(label menu-entry-label)
	87	(device menu-entry-device ; file system uuid, label, or #f
	88	(default #f))
1975c754 DM	89	(device-mount-point menu-entry-device-mount-point
1975c754 DM	90	(default #f))
21acd8d6 JN	91	(linux menu-entry-linux
21acd8d6 JN	92	(default #f))
8b22107e MO	93	(linux-arguments menu-entry-linux-arguments
8b22107e MO	94	(default '())) ; list of string-valued gexps
21acd8d6 JN	95	(initrd menu-entry-initrd ; file name of the initrd as a gexp
	96	(default #f))
	97	(multiboot-kernel menu-entry-multiboot-kernel
	98	(default #f))
	99	(multiboot-arguments menu-entry-multiboot-arguments
	100	(default '())) ; list of string-valued gexps
	101	(multiboot-modules menu-entry-multiboot-modules
	102	(default '()))) ; list of multiboot commands, where
	103	; a command is a list of <string>
8b22107e	104
a28cfee8 LC	105	(define (menu-entry->sexp entry)
	106	"Return ENTRY serialized as an sexp."
	107	(match entry
21acd8d6 JN	108	(($ <menu-entry> label device mount-point linux linux-arguments initrd #f
21acd8d6 JN	109	())
a28cfee8 LC	110	`(menu-entry (version 0)
	111	(label ,label)
	112	(device ,device)
	113	(device-mount-point ,mount-point)
	114	(linux ,linux)
	115	(linux-arguments ,linux-arguments)
21acd8d6 JN	116	(initrd ,initrd)))
	117	(($ <menu-entry> label device mount-point #f () #f
	118	multiboot-kernel multiboot-arguments multiboot-modules)
	119	`(menu-entry (version 0)
	120	(label ,label)
	121	(device ,device)
	122	(device-mount-point ,mount-point)
	123	(multiboot-kernel ,multiboot-kernel)
	124	(multiboot-arguments ,multiboot-arguments)
	125	(multiboot-modules ,multiboot-modules)))))
a28cfee8 LC	126
	127	(define (sexp->menu-entry sexp)
	128	"Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
	129	record."
	130	(match sexp
	131	(('menu-entry ('version 0)
	132	('label label) ('device device)
	133	('device-mount-point mount-point)
	134	('linux linux) ('linux-arguments linux-arguments)
	135	('initrd initrd) _ ...)
	136	(menu-entry
	137	(label label)
	138	(device device)
	139	(device-mount-point mount-point)
	140	(linux linux)
	141	(linux-arguments linux-arguments)
21acd8d6 JN	142	(initrd initrd)))
	143	(('menu-entry ('version 0)
	144	('label label) ('device device)
	145	('device-mount-point mount-point)
	146	('multiboot-kernel multiboot-kernel)
	147	('multiboot-arguments multiboot-arguments)
	148	('multiboot-modules multiboot-modules) _ ...)
	149	(menu-entry
	150	(label label)
	151	(device device)
	152	(device-mount-point mount-point)
	153	(multiboot-kernel multiboot-kernel)
	154	(multiboot-arguments multiboot-arguments)
	155	(multiboot-modules multiboot-modules)))))
a28cfee8	156
8b22107e	157	\f
b09a8da4 MO	158	;;;
	159	;;; Bootloader record.
	160	;;;
	161
	162	;; The <bootloader> record contains fields expressing how the bootloader
	163	;; should be installed. Every bootloader in gnu/bootloader/ directory
	164	;; has to be described by this record.
	165
	166	(define-record-type* <bootloader>
	167	bootloader make-bootloader
	168	bootloader?
	169	(name bootloader-name)
	170	(package bootloader-package)
	171	(installer bootloader-installer)
7feefb3b MO	172	(disk-image-installer bootloader-disk-image-installer
7feefb3b MO	173	(default #f))
b09a8da4 MO	174	(configuration-file bootloader-configuration-file)
	175	(configuration-file-generator bootloader-configuration-file-generator))
	176
	177	\f
	178	;;;
	179	;;; Bootloader configuration record.
	180	;;;
	181
	182	;; The <bootloader-configuration> record contains bootloader independant
	183	;; configuration used to fill bootloader configuration file.
	184
7c414262 JP	185	(define-with-syntax-properties (warn-target-field-deprecation
	186	(value properties))
	187	(when value
	188	(warning (source-properties->location properties)
	189	(G_ "the 'target' field is deprecated, please use 'targets' \
	190	instead~%")))
	191	value)
baf4272d	192
b09a8da4 MO	193	(define-record-type* <bootloader-configuration>
	194	bootloader-configuration make-bootloader-configuration
	195	bootloader-configuration?
91b6873b	196	(bootloader bootloader-configuration-bootloader) ;<bootloader>
2ca982ff MC	197	(targets %bootloader-configuration-targets ;list of strings
	198	(default #f))
	199	(target %bootloader-configuration-target ;deprecated
baf4272d	200	(default #f) (sanitize warn-target-field-deprecation))
ac9cd78e	201	(menu-entries bootloader-configuration-menu-entries ;list of <menu-entry>
91b6873b LC	202	(default '()))
	203	(default-entry bootloader-configuration-default-entry ;integer
	204	(default 0))
	205	(timeout bootloader-configuration-timeout ;seconds as integer
	206	(default 5))
8d058e7b LC	207	(keyboard-layout bootloader-configuration-keyboard-layout ;<keyboard-layout> \| #f
8d058e7b LC	208	(default #f))
91b6873b LC	209	(theme bootloader-configuration-theme ;bootloader-specific theme
	210	(default #f))
	211	(terminal-outputs bootloader-configuration-terminal-outputs ;list of symbols
	212	(default '(gfxterm)))
	213	(terminal-inputs bootloader-configuration-terminal-inputs ;list of symbols
	214	(default '()))
	215	(serial-unit bootloader-configuration-serial-unit ;integer \| #f
	216	(default #f))
	217	(serial-speed bootloader-configuration-serial-speed ;integer \| #f
	218	(default #f)))
b09a8da4	219
baf4272d LC	220	(define-deprecated (bootloader-configuration-target config)
baf4272d LC	221	bootloader-configuration-targets
2ca982ff MC	222	(%bootloader-configuration-target config))
	223
	224	(define (bootloader-configuration-targets config)
	225	(or (%bootloader-configuration-targets config)
	226	;; TODO: Remove after the deprecated 'target' field is removed.
baf4272d	227	(list (%bootloader-configuration-target config))
2ca982ff MC	228	;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
	229	;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
	230	;; hence the default value of '(#f) rather than '().
	231	(list #f)))
	232
b09a8da4 MO	233	\f
	234	;;;
	235	;;; Bootloaders.
	236	;;;
	237
	238	(define (bootloader-modules)
	239	"Return the list of bootloader modules."
	240	(all-modules (map (lambda (entry)
	241	`(,entry . "gnu/bootloader"))
3c0128b0 LC	242	%load-path)
3c0128b0 LC	243	#:warn warn-about-load-error))
b09a8da4 MO	244
	245	(define %bootloaders
	246	;; The list of publically-known bootloaders.
	247	(delay (fold-module-public-variables (lambda (obj result)
	248	(if (bootloader? obj)
	249	(cons obj result)
	250	result))
	251	'()
	252	(bootloader-modules))))
	253
	254	(define (lookup-bootloader-by-name name)
	255	"Return the bootloader called NAME."
	256	(or (find (lambda (bootloader)
	257	(eq? name (bootloader-name bootloader)))
	258	(force %bootloaders))
	259	(leave (G_ "~a: no such bootloader~%") name)))
74eeb11d	260
ede4117f	261	(define (efi-bootloader-profile files bootloader-package hooks)
74eeb11d S	262	"Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
	263	links to additional FILES from the store. This collection is meant to be used
	264	by the bootloader installer.
	265
	266	FILES is a list of file or directory names from the store, which will be
	267	symlinked into the collection/ directory. If a directory name ends with '/',
	268	then the directory content instead of the directory itself will be symlinked
	269	into the collection/ directory.
	270
	271	FILES may contain file like objects produced by functions like plain-file,
ede4117f S	272	local-file, etc., or package contents produced with file-append.
	273
	274	HOOKS lists additional hook functions to modify the profile."
74eeb11d S	275	(define (bootloader-collection manifest)
	276	(define build
	277	(with-imported-modules '((guix build utils)
	278	(ice-9 ftw)
	279	(srfi srfi-1)
	280	(srfi srfi-26))
	281	#~(begin
	282	(use-modules ((guix build utils)
	283	#:select (mkdir-p strip-store-file-name))
	284	((ice-9 ftw)
	285	#:select (scandir))
	286	((srfi srfi-1)
	287	#:select (append-map every remove))
	288	((srfi srfi-26)
	289	#:select (cut)))
	290	(define (symlink-to file directory transform)
	291	"Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
	292	(symlink file (string-append directory "/" (transform file))))
	293	(define (directory-content directory)
	294	"Creates a list of absolute path names inside DIRECTORY."
	295	(map (lambda (name)
	296	(string-append directory name))
	297	(or (scandir directory (lambda (name)
	298	(not (member name '("." "..")))))
	299	'())))
	300	(define name-ends-with-/? (cut string-suffix? "/" <>))
	301	(define (name-is-store-entry? name)
	302	"Return #t if NAME is a direct store entry and nothing inside."
	303	(not (string-index (strip-store-file-name name) #\/)))
	304	(let* ((collection (string-append #$output "/collection"))
	305	(files '#$files)
	306	(directories (filter name-ends-with-/? files))
	307	(names-from-directories
	308	(append-map (lambda (directory)
	309	(directory-content directory))
	310	directories))
	311	(names (append names-from-directories
	312	(remove name-ends-with-/? files))))
	313	(mkdir-p collection)
	314	(if (every file-exists? names)
	315	(begin
	316	(for-each (lambda (name)
	317	(symlink-to name collection
	318	(if (name-is-store-entry? name)
	319	strip-store-file-name
	320	basename)))
	321	names)
	322	#t)
	323	#f)))))
	324
	325	(gexp->derivation "bootloader-collection"
	326	build
	327	#:local-build? #t
	328	#:substitutable? #f
	329	#:properties
	330	`((type . profile-hook)
	331	(hook . bootloader-collection))))
	332
	333	(profile (content (packages->manifest (list bootloader-package)))
ede4117f S	334	(name "bootloader-profile")
ede4117f S	335	(hooks (append (list bootloader-collection) hooks))
74eeb11d S	336	(locales? #f)
	337	(allow-collisions? #f)
	338	(relative-symlinks? #f)))
	339
	340	(define* (efi-bootloader-chain files
	341	final-bootloader
	342	#:key
ede4117f	343	(hooks '())
74eeb11d S	344	installer)
	345	"Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
	346	certain directories and files from the store given in the list of FILES.
	347
	348	FILES may contain file like objects produced by functions like plain-file,
	349	local-file, etc., or package contents produced with file-append. They will be
	350	collected inside a directory collection/ inside a generated bootloader profile,
	351	which will be passed to the INSTALLER.
	352
	353	If a directory name in FILES ends with '/', then the directory content instead
	354	of the directory itself will be symlinked into the collection/ directory.
	355
ede4117f S	356	The procedures in the HOOKS list can be used to further modify the bootloader
ede4117f S	357	profile. It is possible to pass a single function instead of a list.
74eeb11d S	358
74eeb11d S	359	If the INSTALLER argument is used, then this function will be called to install
ede4117f	360	the bootloader. Otherwise the installer of the FINAL-BOOTLOADER will be called."
74eeb11d S	361	(let* ((final-installer (or installer
	362	(bootloader-installer final-bootloader)))
	363	(profile (efi-bootloader-profile files
	364	(bootloader-package final-bootloader)
ede4117f S	365	(if (list? hooks)
	366	hooks
	367	(list hooks)))))
74eeb11d S	368	(bootloader
	369	(inherit final-bootloader)
	370	(package profile)
	371	(installer
	372	#~(lambda (bootloader target mount-point)
	373	(#$final-installer bootloader target mount-point)
	374	(copy-recursively
	375	(string-append bootloader "/collection")
	376	(string-append mount-point target)
	377	#:follow-symlinks? #t
	378	#:log (%make-void-port "w")))))))