1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2017 David Craven <david@craven.ch>
3 ;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
4 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
5 ;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org>
6 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
7 ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
8 ;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
10 ;;; This file is part of GNU Guix.
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.
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.
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/>.
25 (define-module (gnu bootloader)
26 #:use-module (gnu system file-systems)
27 #:use-module (gnu system uuid)
28 #:use-module (guix discovery)
29 #:use-module (guix gexp)
30 #:use-module (guix profiles)
31 #:use-module (guix records)
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)
36 #:use-module (srfi srfi-1)
37 #:use-module (srfi srfi-34)
38 #:use-module (srfi srfi-35)
39 #:use-module (ice-9 match)
45 menu-entry-linux-arguments
47 menu-entry-device-mount-point
48 menu-entry-multiboot-kernel
49 menu-entry-multiboot-arguments
50 menu-entry-multiboot-modules
51 menu-entry-chain-loader
61 bootloader-disk-image-installer
62 bootloader-configuration-file
63 bootloader-configuration-file-generator
65 bootloader-configuration
66 bootloader-configuration?
67 bootloader-configuration-bootloader
68 bootloader-configuration-target ;deprecated
69 bootloader-configuration-targets
70 bootloader-configuration-menu-entries
71 bootloader-configuration-default-entry
72 bootloader-configuration-timeout
73 bootloader-configuration-keyboard-layout
74 bootloader-configuration-theme
75 bootloader-configuration-terminal-outputs
76 bootloader-configuration-terminal-inputs
77 bootloader-configuration-serial-unit
78 bootloader-configuration-serial-speed
79 bootloader-configuration-device-tree-support?
82 lookup-bootloader-by-name
84 efi-bootloader-chain))
88 ;;; Menu-entry record.
91 (define-record-type* <menu-entry>
92 menu-entry make-menu-entry
94 (label menu-entry-label)
95 (device menu-entry-device ; file system uuid, label, or #f
97 (device-mount-point menu-entry-device-mount-point
99 (linux menu-entry-linux
101 (linux-arguments menu-entry-linux-arguments
102 (default '())) ; list of string-valued gexps
103 (initrd menu-entry-initrd ; file name of the initrd as a gexp
105 (multiboot-kernel menu-entry-multiboot-kernel
107 (multiboot-arguments menu-entry-multiboot-arguments
108 (default '())) ; list of string-valued gexps
109 (multiboot-modules menu-entry-multiboot-modules
110 (default '())) ; list of multiboot commands, where
111 ; a command is a list of <string>
112 (chain-loader menu-entry-chain-loader
113 (default #f))) ; string, path of efi file
115 (define (report-menu-entry-error menu-entry)
120 (format #f (G_ "invalid menu-entry: ~a") menu-entry)))
123 (G_ "Please chose only one of:
125 @item direct boot by specifying fields @code{linux},
126 @code{linux-arguments} and @code{linux-modules},
127 @item multiboot by specifying fields @code{multiboot-kernel},
128 @code{multiboot-arguments} and @code{multiboot-modules},
129 @item chain-loader by specifying field @code{chain-loader}.
130 @end enumerate"))))))
132 (define (menu-entry->sexp entry)
133 "Return ENTRY serialized as an sexp."
134 (define (device->sexp device)
137 `(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
138 ((? file-system-label? label)
139 `(label ,(file-system-label->string label)))
142 (($ <menu-entry> label device mount-point
143 (? identity linux) linux-arguments (? identity initrd)
145 `(menu-entry (version 0)
147 (device ,(device->sexp device))
148 (device-mount-point ,mount-point)
150 (linux-arguments ,linux-arguments)
152 (($ <menu-entry> label device mount-point #f () #f
153 (? identity multiboot-kernel) multiboot-arguments
154 multiboot-modules #f)
155 `(menu-entry (version 0)
157 (device ,(device->sexp device))
158 (device-mount-point ,mount-point)
159 (multiboot-kernel ,multiboot-kernel)
160 (multiboot-arguments ,multiboot-arguments)
161 (multiboot-modules ,multiboot-modules)))
162 (($ <menu-entry> label device mount-point #f () #f #f () ()
163 (? identity chain-loader))
164 `(menu-entry (version 0)
166 (device ,(device->sexp device))
167 (device-mount-point ,mount-point)
168 (chain-loader ,chain-loader)))
169 (_ (report-menu-entry-error entry))))
171 (define (sexp->menu-entry sexp)
172 "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
174 (define (sexp->device device-sexp)
176 (('uuid type uuid-string)
177 (uuid uuid-string type))
179 (file-system-label label))
182 (('menu-entry ('version 0)
183 ('label label) ('device device)
184 ('device-mount-point mount-point)
185 ('linux linux) ('linux-arguments linux-arguments)
186 ('initrd initrd) _ ...)
189 (device (sexp->device device))
190 (device-mount-point mount-point)
192 (linux-arguments linux-arguments)
194 (('menu-entry ('version 0)
195 ('label label) ('device device)
196 ('device-mount-point mount-point)
197 ('multiboot-kernel multiboot-kernel)
198 ('multiboot-arguments multiboot-arguments)
199 ('multiboot-modules multiboot-modules) _ ...)
202 (device (sexp->device device))
203 (device-mount-point mount-point)
204 (multiboot-kernel multiboot-kernel)
205 (multiboot-arguments multiboot-arguments)
206 (multiboot-modules multiboot-modules)))
207 (('menu-entry ('version 0)
208 ('label label) ('device device)
209 ('device-mount-point mount-point)
210 ('chain-loader chain-loader) _ ...)
213 (device (sexp->device device))
214 (device-mount-point mount-point)
215 (chain-loader chain-loader)))))
219 ;;; Bootloader record.
222 ;; The <bootloader> record contains fields expressing how the bootloader
223 ;; should be installed. Every bootloader in gnu/bootloader/ directory
224 ;; has to be described by this record.
226 (define-record-type* <bootloader>
227 bootloader make-bootloader
229 (name bootloader-name)
230 (package bootloader-package)
231 (installer bootloader-installer)
232 (disk-image-installer bootloader-disk-image-installer
234 (configuration-file bootloader-configuration-file)
235 (configuration-file-generator bootloader-configuration-file-generator))
239 ;;; Bootloader configuration record.
242 ;; The <bootloader-configuration> record contains bootloader independant
243 ;; configuration used to fill bootloader configuration file.
245 (define-with-syntax-properties (warn-target-field-deprecation
248 (warning (source-properties->location properties)
249 (G_ "the 'target' field is deprecated, please use 'targets' \
253 (define-record-type* <bootloader-configuration>
254 bootloader-configuration make-bootloader-configuration
255 bootloader-configuration?
257 bootloader-configuration-bootloader) ;<bootloader>
258 (targets %bootloader-configuration-targets
259 (default #f)) ;list of strings
260 (target %bootloader-configuration-target ;deprecated
262 (sanitize warn-target-field-deprecation))
263 (menu-entries bootloader-configuration-menu-entries
264 (default '())) ;list of <menu-entry>
265 (default-entry bootloader-configuration-default-entry
266 (default 0)) ;integer
267 (timeout bootloader-configuration-timeout
268 (default 5)) ;seconds as integer
269 (keyboard-layout bootloader-configuration-keyboard-layout
270 (default #f)) ;<keyboard-layout> | #f
271 (theme bootloader-configuration-theme
272 (default #f)) ;bootloader-specific theme
273 (terminal-outputs bootloader-configuration-terminal-outputs
274 (default '(gfxterm))) ;list of symbols
275 (terminal-inputs bootloader-configuration-terminal-inputs
276 (default '())) ;list of symbols
277 (serial-unit bootloader-configuration-serial-unit
278 (default #f)) ;integer | #f
279 (serial-speed bootloader-configuration-serial-speed
280 (default #f)) ;integer | #f
281 (device-tree-support? bootloader-configuration-device-tree-support?
282 (default #t))) ;boolean
284 (define-deprecated (bootloader-configuration-target config)
285 bootloader-configuration-targets
286 (%bootloader-configuration-target config))
288 (define (bootloader-configuration-targets config)
289 (or (%bootloader-configuration-targets config)
290 ;; TODO: Remove after the deprecated 'target' field is removed.
291 (list (%bootloader-configuration-target config))
292 ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
293 ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
294 ;; hence the default value of '(#f) rather than '().
302 (define (bootloader-modules)
303 "Return the list of bootloader modules."
304 (all-modules (map (lambda (entry)
305 `(,entry . "gnu/bootloader"))
307 #:warn warn-about-load-error))
310 ;; The list of publically-known bootloaders.
311 (delay (fold-module-public-variables (lambda (obj result)
312 (if (bootloader? obj)
316 (bootloader-modules))))
318 (define (lookup-bootloader-by-name name)
319 "Return the bootloader called NAME."
320 (or (find (lambda (bootloader)
321 (eq? name (bootloader-name bootloader)))
322 (force %bootloaders))
323 (leave (G_ "~a: no such bootloader~%") name)))
325 (define (efi-bootloader-profile files bootloader-package hooks)
326 "Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
327 links to additional FILES from the store. This collection is meant to be used
328 by the bootloader installer.
330 FILES is a list of file or directory names from the store, which will be
331 symlinked into the collection/ directory. If a directory name ends with '/',
332 then the directory content instead of the directory itself will be symlinked
333 into the collection/ directory.
335 FILES may contain file like objects produced by functions like plain-file,
336 local-file, etc., or package contents produced with file-append.
338 HOOKS lists additional hook functions to modify the profile."
339 (define (bootloader-collection manifest)
341 (with-imported-modules '((guix build utils)
346 (use-modules ((guix build utils)
347 #:select (mkdir-p strip-store-file-name))
351 #:select (append-map every remove))
354 (define (symlink-to file directory transform)
355 "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
356 (symlink file (string-append directory "/" (transform file))))
357 (define (directory-content directory)
358 "Creates a list of absolute path names inside DIRECTORY."
360 (string-append directory name))
361 (or (scandir directory (lambda (name)
362 (not (member name '("." "..")))))
364 (define name-ends-with-/? (cut string-suffix? "/" <>))
365 (define (name-is-store-entry? name)
366 "Return #t if NAME is a direct store entry and nothing inside."
367 (not (string-index (strip-store-file-name name) #\/)))
368 (let* ((collection (string-append #$output "/collection"))
370 (directories (filter name-ends-with-/? files))
371 (names-from-directories
372 (append-map (lambda (directory)
373 (directory-content directory))
375 (names (append names-from-directories
376 (remove name-ends-with-/? files))))
378 (if (every file-exists? names)
380 (for-each (lambda (name)
381 (symlink-to name collection
382 (if (name-is-store-entry? name)
383 strip-store-file-name
389 (gexp->derivation "bootloader-collection"
394 `((type . profile-hook)
395 (hook . bootloader-collection))))
397 (profile (content (packages->manifest (list bootloader-package)))
398 (name "bootloader-profile")
399 (hooks (append (list bootloader-collection) hooks))
401 (allow-collisions? #f)
402 (relative-symlinks? #f)))
404 (define* (efi-bootloader-chain files
409 "Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
410 certain directories and files from the store given in the list of FILES.
412 FILES may contain file like objects produced by functions like plain-file,
413 local-file, etc., or package contents produced with file-append. They will be
414 collected inside a directory collection/ inside a generated bootloader profile,
415 which will be passed to the INSTALLER.
417 If a directory name in FILES ends with '/', then the directory content instead
418 of the directory itself will be symlinked into the collection/ directory.
420 The procedures in the HOOKS list can be used to further modify the bootloader
421 profile. It is possible to pass a single function instead of a list.
423 If the INSTALLER argument is used, then this function will be called to install
424 the bootloader. Otherwise the installer of the FINAL-BOOTLOADER will be called."
425 (let* ((final-installer (or installer
426 (bootloader-installer final-bootloader)))
427 (profile (efi-bootloader-profile files
428 (bootloader-package final-bootloader)
433 (inherit final-bootloader)
436 #~(lambda (bootloader target mount-point)
437 (#$final-installer bootloader target mount-point)
439 (string-append bootloader "/collection")
440 (string-append mount-point target)
441 #:follow-symlinks? #t
442 #:log (%make-void-port "w")))))))