projects/guix·blob wip-postfix · refs

443 lines · 17.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017 David Craven <[email protected]>
3;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <[email protected]>
4;;; Copyright © 2017 Leo Famulari <[email protected]>
5;;; Copyright © 2019, 2021 Ludovic Courtès <[email protected]>
6;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email protected]>
7;;; Copyright © 2022 Josselin Poiret <[email protected]>
8;;; Copyright © 2022 Reza Alizadeh Majd <[email protected]>
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)
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)
40 #:export (menu-entry
41 menu-entry?
42 menu-entry-label
43 menu-entry-device
44 menu-entry-linux
45 menu-entry-linux-arguments
46 menu-entry-initrd
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
52
53 menu-entry->sexp
54 sexp->menu-entry
55
56 bootloader
57 bootloader?
58 bootloader-name
59 bootloader-package
60 bootloader-installer
61 bootloader-disk-image-installer
62 bootloader-configuration-file
63 bootloader-configuration-file-generator
64
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?
80
81 %bootloaders
82 lookup-bootloader-by-name
83
84 efi-bootloader-chain))
85
86
87;;;
88;;; Menu-entry record.
89;;;
90
91(define-record-type* <menu-entry>
92 menu-entry make-menu-entry
93 menu-entry?
94 (label menu-entry-label)
95 (device menu-entry-device ; file system uuid, label, or #f
96 (default #f))
97 (device-mount-point menu-entry-device-mount-point
98 (default #f))
99 (linux menu-entry-linux
100 (default #f))
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
104 (default #f))
105 (multiboot-kernel menu-entry-multiboot-kernel
106 (default #f))
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
114
115(define (report-menu-entry-error menu-entry)
116 (raise
117 (condition
118 (&message
119 (message
120 (format #f (G_ "invalid menu-entry: ~a") menu-entry)))
121 (&fix-hint
122 (hint
123 (G_ "Please chose only one of:
124@enumerate
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"))))))
131
132(define (menu-entry->sexp entry)
133 "Return ENTRY serialized as an sexp."
134 (define (device->sexp device)
135 (match device
136 ((? uuid? uuid)
137 `(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
138 ((? file-system-label? label)
139 `(label ,(file-system-label->string label)))
140 (_ device)))
141 (match entry
142 (($ <menu-entry> label device mount-point
143 (? identity linux) linux-arguments (? identity initrd)
144 #f () () #f)
145 `(menu-entry (version 0)
146 (label ,label)
147 (device ,(device->sexp device))
148 (device-mount-point ,mount-point)
149 (linux ,linux)
150 (linux-arguments ,linux-arguments)
151 (initrd ,initrd)))
152 (($ <menu-entry> label device mount-point #f () #f
153 (? identity multiboot-kernel) multiboot-arguments
154 multiboot-modules #f)
155 `(menu-entry (version 0)
156 (label ,label)
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)
165 (label ,label)
166 (device ,(device->sexp device))
167 (device-mount-point ,mount-point)
168 (chain-loader ,chain-loader)))
169 (_ (report-menu-entry-error entry))))
170
171(define (sexp->menu-entry sexp)
172 "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
173record."
174 (define (sexp->device device-sexp)
175 (match device-sexp
176 (('uuid type uuid-string)
177 (uuid uuid-string type))
178 (('label label)
179 (file-system-label label))
180 (_ device-sexp)))
181 (match sexp
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) _ ...)
187 (menu-entry
188 (label label)
189 (device (sexp->device device))
190 (device-mount-point mount-point)
191 (linux linux)
192 (linux-arguments linux-arguments)
193 (initrd initrd)))
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) _ ...)
200 (menu-entry
201 (label label)
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) _ ...)
211 (menu-entry
212 (label label)
213 (device (sexp->device device))
214 (device-mount-point mount-point)
215 (chain-loader chain-loader)))))
216
217
218;;;
219;;; Bootloader record.
220;;;
221
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.
225
226(define-record-type* <bootloader>
227 bootloader make-bootloader
228 bootloader?
229 (name bootloader-name)
230 (package bootloader-package)
231 (installer bootloader-installer)
232 (disk-image-installer bootloader-disk-image-installer
233 (default #f))
234 (configuration-file bootloader-configuration-file)
235 (configuration-file-generator bootloader-configuration-file-generator))
236
237
238;;;
239;;; Bootloader configuration record.
240;;;
241
242;; The <bootloader-configuration> record contains bootloader independant
243;; configuration used to fill bootloader configuration file.
244
245(define-with-syntax-properties (warn-target-field-deprecation
246 (value properties))
247 (when value
248 (warning (source-properties->location properties)
249 (G_ "the 'target' field is deprecated, please use 'targets' \
250instead~%")))
251 value)
252
253(define-record-type* <bootloader-configuration>
254 bootloader-configuration make-bootloader-configuration
255 bootloader-configuration?
256 (bootloader
257 bootloader-configuration-bootloader) ;<bootloader>
258 (targets %bootloader-configuration-targets
259 (default #f)) ;list of strings
260 (target %bootloader-configuration-target ;deprecated
261 (default #f)
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
283
284(define-deprecated (bootloader-configuration-target config)
285 bootloader-configuration-targets
286 (%bootloader-configuration-target config))
287
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 '().
295 (list #f)))
296
297
298;;;
299;;; Bootloaders.
300;;;
301
302(define (bootloader-modules)
303 "Return the list of bootloader modules."
304 (all-modules (map (lambda (entry)
305 `(,entry . "gnu/bootloader"))
306 %load-path)
307 #:warn warn-about-load-error))
308
309(define %bootloaders
310 ;; The list of publically-known bootloaders.
311 (delay (fold-module-public-variables (lambda (obj result)
312 (if (bootloader? obj)
313 (cons obj result)
314 result))
315 '()
316 (bootloader-modules))))
317
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)))
324
325(define (efi-bootloader-profile packages files hooks)
326 "Creates a profile from the lists of PACKAGES and FILES from the store.
327This profile is meant to be used by the bootloader-installer.
328
329FILES is a list of file or directory names from the store, which will be
330symlinked into the profile. If a directory name ends with '/', then the
331directory content instead of the directory itself will be symlinked into the
332profile.
333
334FILES may contain file like objects produced by procedures like plain-file,
335local-file, etc., or package contents produced with file-append.
336
337HOOKS lists additional hook functions to modify the profile."
338 (define (efi-bootloader-profile-hook manifest)
339 (define build
340 (with-imported-modules '((guix build utils))
341 #~(begin
342 (use-modules ((guix build utils)
343 #:select (mkdir-p strip-store-file-name))
344 ((ice-9 ftw)
345 #:select (scandir))
346 ((srfi srfi-1)
347 #:select (append-map every remove))
348 ((srfi srfi-26)
349 #:select (cut)))
350 (define (symlink-to file directory transform)
351 "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
352 (symlink file (string-append directory "/" (transform file))))
353 (define (directory-content directory)
354 "Creates a list of absolute path names inside DIRECTORY."
355 (map (lambda (name)
356 (string-append directory name))
357 (or (scandir directory (lambda (name)
358 (not (member name '("." "..")))))
359 '())))
360 (define name-ends-with-/? (cut string-suffix? "/" <>))
361 (define (name-is-store-entry? name)
362 "Return #t if NAME is a direct store entry and nothing inside."
363 (not (string-index (strip-store-file-name name) #\/)))
364 (let* ((files '#$files)
365 (directories (filter name-ends-with-/? files))
366 (names-from-directories
367 (append-map (lambda (directory)
368 (directory-content directory))
369 directories))
370 (names (append names-from-directories
371 (remove name-ends-with-/? files))))
372 (mkdir-p #$output)
373 (if (every file-exists? names)
374 (begin
375 (for-each (lambda (name)
376 (symlink-to name #$output
377 (if (name-is-store-entry? name)
378 strip-store-file-name
379 basename)))
380 names)
381 #t)
382 #f)))))
383
384 (gexp->derivation "efi-bootloader-profile"
385 build
386 #:local-build? #t
387 #:substitutable? #f
388 #:properties
389 `((type . profile-hook)
390 (hook . efi-bootloader-profile-hook))))
391
392 (profile (content (packages->manifest packages))
393 (name "efi-bootloader-profile")
394 (hooks (cons efi-bootloader-profile-hook hooks))
395 (locales? #f)
396 (allow-collisions? #f)
397 (relative-symlinks? #f)))
398
399(define* (efi-bootloader-chain final-bootloader
400 #:key
401 (packages '())
402 (files '())
403 (hooks '())
404 installer
405 disk-image-installer)
406 "Define a chain of bootloaders with the FINAL-BOOTLOADER, optional PACKAGES,
407and optional directories and files from the store given in the list of FILES.
408
409The package of the FINAL-BOOTLOADER and all PACKAGES and FILES will be placed
410in an efi-bootloader-profile, which will be passed to the INSTALLER.
411
412FILES may contain file-like objects produced by procedures like plain-file,
413local-file, etc., or package contents produced with file-append.
414
415If a directory name in FILES ends with '/', then the directory content instead
416of the directory itself will be symlinked into the efi-bootloader-profile.
417
418The procedures in the HOOKS list can be used to further modify the bootloader
419profile. It is possible to pass a single function instead of a list.
420
421If the INSTALLER argument is used, then this gexp procedure will be called to
422install the efi-bootloader-profile. Otherwise the installer of the
423FINAL-BOOTLOADER will be called.
424
425If the DISK-IMAGE-INSTALLER is used, then this gexp procedure will be called
426to install the efi-bootloader-profile into a disk image. Otherwise the
427disk-image-installer of the FINAL-BOOTLOADER will be called."
428 (bootloader
429 (inherit final-bootloader)
430 (name "efi-bootloader-chain")
431 (package
432 (efi-bootloader-profile (cons (bootloader-package final-bootloader)
433 packages)
434 files
435 (if (list? hooks)
436 hooks
437 (list hooks))))
438 (installer
439 (or installer
440 (bootloader-installer final-bootloader)))
441 (disk-image-installer
442 (or disk-image-installer
443 (bootloader-disk-image-installer final-bootloader)))))