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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu bootloader)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system uuid)
  #:use-module (guix discovery)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #:use-module (guix records)
  #:use-module (guix deprecation)
  #:use-module ((guix ui) #:select (warn-about-load-error))
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (menu-entry
            menu-entry?
            menu-entry-label
            menu-entry-device
            menu-entry-linux
            menu-entry-linux-arguments
            menu-entry-initrd
            menu-entry-device-mount-point
            menu-entry-multiboot-kernel
            menu-entry-multiboot-arguments
            menu-entry-multiboot-modules
            menu-entry-chain-loader

            menu-entry->sexp
            sexp->menu-entry

            bootloader
            bootloader?
            bootloader-name
            bootloader-package
            bootloader-installer
            bootloader-disk-image-installer
            bootloader-configuration-file
            bootloader-configuration-file-generator

            bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            bootloader-configuration-target ;deprecated
            bootloader-configuration-targets
            bootloader-configuration-menu-entries
            bootloader-configuration-default-entry
            bootloader-configuration-timeout
            bootloader-configuration-keyboard-layout
            bootloader-configuration-theme
            bootloader-configuration-terminal-outputs
            bootloader-configuration-terminal-inputs
            bootloader-configuration-serial-unit
            bootloader-configuration-serial-speed
            bootloader-configuration-device-tree-support?

            %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>
  (chain-loader     menu-entry-chain-loader
                    (default #f)))         ; string, path of efi file

(define (menu-entry->sexp entry)
  "Return ENTRY serialized as an sexp."
  (define (device->sexp device)
    (match device
      ((? uuid? uuid)
       `(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
      ((? file-system-label? label)
       `(label ,(file-system-label->string label)))
      (_ device)))
  (match entry
    (($ <menu-entry> label device mount-point
                     (? identity linux) linux-arguments (? identity initrd)
                     #f () () #f)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (linux ,linux)
                  (linux-arguments ,linux-arguments)
                  (initrd ,initrd)))
    (($ <menu-entry> label device mount-point #f () #f
                     (? identity multiboot-kernel) multiboot-arguments
                     multiboot-modules #f)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (multiboot-kernel ,multiboot-kernel)
                  (multiboot-arguments ,multiboot-arguments)
                  (multiboot-modules ,multiboot-modules)))
    (($ <menu-entry> label device mount-point #f () #f #f () ()
                     (? identity chain-loader))
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (chain-loader ,chain-loader)))))

(define (sexp->menu-entry sexp)
  "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
  (define (sexp->device device-sexp)
    (match device-sexp
      (('uuid type uuid-string)
       (uuid uuid-string type))
      (('label label)
       (file-system-label label))
      (_ device-sexp)))
  (match sexp
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('linux linux) ('linux-arguments linux-arguments)
                  ('initrd initrd) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (linux linux)
      (linux-arguments linux-arguments)
      (initrd initrd)))
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('multiboot-kernel multiboot-kernel)
                  ('multiboot-arguments multiboot-arguments)
                  ('multiboot-modules multiboot-modules) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (multiboot-kernel multiboot-kernel)
      (multiboot-arguments multiboot-arguments)
      (multiboot-modules multiboot-modules)))
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('chain-loader chain-loader) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (chain-loader chain-loader)))))

\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
                         (default #f))     ;list of strings
  (target                %bootloader-configuration-target ;deprecated
                         (default #f)
                         (sanitize warn-target-field-deprecation))
  (menu-entries          bootloader-configuration-menu-entries
                         (default '()))   ;list of <menu-entry>
  (default-entry         bootloader-configuration-default-entry
                         (default 0))     ;integer
  (timeout               bootloader-configuration-timeout
                         (default 5))     ;seconds as integer
  (keyboard-layout       bootloader-configuration-keyboard-layout
                         (default #f))    ;<keyboard-layout> | #f
  (theme                 bootloader-configuration-theme
                         (default #f))    ;bootloader-specific theme
  (terminal-outputs      bootloader-configuration-terminal-outputs
                         (default '(gfxterm)))   ;list of symbols
  (terminal-inputs       bootloader-configuration-terminal-inputs
                         (default '()))   ;list of symbols
  (serial-unit           bootloader-configuration-serial-unit
                         (default #f))    ;integer | #f
  (serial-speed          bootloader-configuration-serial-speed
                         (default #f))    ;integer | #f
  (device-tree-support?  bootloader-configuration-device-tree-support?
                         (default #t)))   ;boolean

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