projects/guix·blob javascript-team · refs

919 lines · 37.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016 Chris Marusich <[email protected]>
4;;; Copyright © 2017 Leo Famulari <[email protected]>
5;;; Copyright © 2017, 2020 Mathieu Othacehe <[email protected]>
6;;; Copyright © 2019, 2020, 2023, 2024, 2026 Janneke Nieuwenhuizen <[email protected]>
7;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <[email protected]>
8;;; Copyright © 2020 Maxim Cournoyer <[email protected]>
9;;; Copyright © 2020 Stefan <[email protected]>
10;;; Copyright © 2022 Karl Hallsby <[email protected]>
11;;; Copyright © 2022 Denis 'GNUtoo' Carikli <[email protected]>
12;;; Copyright © 2024 Tomas Volf <[email protected]>
13;;; Copyright © 2024 Herman Rimm <[email protected]>
14;;;
15;;; This file is part of GNU Guix.
16;;;
17;;; GNU Guix is free software; you can redistribute it and/or modify it
18;;; under the terms of the GNU General Public License as published by
19;;; the Free Software Foundation; either version 3 of the License, or (at
20;;; your option) any later version.
21;;;
22;;; GNU Guix is distributed in the hope that it will be useful, but
23;;; WITHOUT ANY WARRANTY; without even the implied warranty of
24;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25;;; GNU General Public License for more details.
26;;;
27;;; You should have received a copy of the GNU General Public License
28;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
29
30;;; Commentary:
31;;;
32;;; Configuration of GNU GRUB.
33;;;
34;;; Code:
35
36(define-module (gnu bootloader grub)
37 #:use-module (guix build union)
38 #:use-module (guix deprecation)
39 #:use-module (guix records)
40 #:use-module (guix store)
41 #:use-module (guix utils)
42 #:use-module (guix gexp)
43 #:use-module (gnu artwork)
44 #:use-module (gnu bootloader)
45 #:use-module (gnu build file-systems)
46 #:use-module (gnu system uuid)
47 #:use-module (gnu system file-systems)
48 #:use-module (gnu system keyboard)
49 #:use-module (gnu system locale)
50 #:use-module (gnu packages bootloaders)
51 #:autoload (gnu packages gtk) (guile-cairo guile-rsvg)
52 #:autoload (gnu packages xorg) (xkeyboard-config)
53 #:use-module (ice-9 match)
54 #:use-module (ice-9 regex)
55 #:use-module (srfi srfi-1)
56 #:use-module (srfi srfi-2)
57 #:use-module (srfi srfi-26)
58 #:export (grub-theme
59 grub-theme?
60 grub-theme-image
61 grub-theme-resolution
62 grub-theme-color-normal
63 grub-theme-color-highlight
64 grub-theme-gfxmode
65
66 install-grub-efi-removable
67 make-grub-efi-installer
68 make-grub-efi-netboot-installer
69
70 grub-bootloader
71 grub-efi-bootloader
72 grub-efi-removable-bootloader
73 grub-efi32-bootloader
74 grub-efi32-removable-bootloader
75 grub-efi-netboot-bootloader
76 grub-efi-netboot-removable-bootloader
77 grub-mkrescue-bootloader
78 grub-minimal-bootloader
79
80 grub-configuration))
81
82(define* (normalize-file file mount-point store-directory-prefix)
83 "Strip MOUNT-POINT and prepend STORE-DIRECTORY-PREFIX, if any, to FILE, a
84G-expression or other lowerable object denoting a file name."
85
86 (define (strip-mount-point mount-point file)
87 (if mount-point
88 (if (string=? mount-point "/")
89 file
90 #~(let ((file #$file))
91 (if (string-prefix? #$mount-point file)
92 (substring #$file #$(string-length mount-point))
93 file)))
94 file))
95
96 (define (prepend-store-directory-prefix store-directory-prefix file)
97 (if store-directory-prefix
98 #~(string-append #$store-directory-prefix #$file)
99 file))
100
101 (prepend-store-directory-prefix store-directory-prefix
102 (strip-mount-point mount-point file)))
103
104
105
106(define-record-type* <grub-theme>
107 ;; Default theme contributed by Felipe López.
108 grub-theme make-grub-theme
109 grub-theme?
110 (image grub-theme-image
111 (default (file-append %artwork-repository
112 "/grub/GuixSD-fully-black-4-3.svg")))
113 (resolution grub-theme-resolution
114 (default '(1024 . 768)))
115 (color-normal grub-theme-color-normal
116 (default '((fg . light-gray) (bg . black))))
117 (color-highlight grub-theme-color-highlight
118 (default '((fg . yellow) (bg . black))))
119 (gfxmode grub-theme-gfxmode
120 (default '("auto")))) ;list of string
121
122
123;;;
124;;; Background image & themes.
125;;;
126
127(define (bootloader-theme config)
128 "Return user defined theme in CONFIG if defined or a default theme
129otherwise."
130 (or (bootloader-configuration-theme config) (grub-theme)))
131
132(define* (image->png image #:key width height)
133 "Build a PNG of HEIGHT x WIDTH from IMAGE if its file suffix is \".svg\".
134Otherwise the picture in IMAGE is just copied."
135 (computed-file "grub-image.png"
136 (with-imported-modules '((gnu build svg))
137 (with-extensions (list guile-rsvg guile-cairo)
138 #~(if (string-suffix? ".svg" #+image)
139 (begin
140 (use-modules (gnu build svg))
141 (svg->png #+image #$output
142 #:width #$width
143 #:height #$height))
144 (copy-file #+image #$output))))
145 ;; Work around a bug in grafts where different versions of
146 ;; guile-cairo are loaded from (gnu build svg).
147 ;; As seen in https://issues.guix.gnu.org/47115#23 and
148 ;; in https://issues.guix.gnu.org/75510.
149 #:options '(#:graft? #f)))
150
151(define* (grub-background-image config)
152 "Return the GRUB background image defined in CONFIG or #f if none was found.
153If the suffix of the image file is \".svg\", then it is converted into a PNG
154file with the resolution provided in CONFIG."
155 (let* ((theme (bootloader-theme config))
156 (image (grub-theme-image theme)))
157 (and image
158 (match (grub-theme-resolution theme)
159 (((? number? width) . (? number? height))
160 (image->png image #:width width #:height height))
161 (_ #f)))))
162
163(define (grub-locale-directory grub)
164 "Generate a directory with the locales from GRUB."
165 (define builder
166 #~(begin
167 (use-modules (ice-9 ftw))
168 (let ((locale (string-append #$grub "/share/locale"))
169 (out #$output))
170 (mkdir out)
171 (chdir out)
172 (for-each (lambda (lang)
173 (let ((file (string-append locale "/" lang
174 "/LC_MESSAGES/grub.mo"))
175 (dest (string-append lang ".mo")))
176 (when (file-exists? file)
177 (copy-file file dest))))
178 (scandir locale)))))
179 (computed-file "grub-locales" builder))
180
181(define* (eye-candy config store-device store-mount-point
182 #:key store-directory-prefix port)
183 "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
184concerned with graphics mode, background images, colors, and all that.
185STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POINT is
186its mount point; these are used to determine where the background image and
187fonts must be searched for. STORE-DIRECTORY-PREFIX is a directory prefix to
188prepend to any store file name."
189 (define (setup-gfxterm config)
190 (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
191 #~(format #f "
192if loadfont unicode; then
193 set gfxmode=~s
194 insmod all_video
195 insmod gfxterm
196fi~%"
197 #$(string-join
198 (grub-theme-gfxmode (bootloader-theme config))
199 ";"))
200 ""))
201
202 (define (theme-colors type)
203 (let* ((theme (bootloader-theme config))
204 (colors (type theme)))
205 (string-append (symbol->string (assoc-ref colors 'fg)) "/"
206 (symbol->string (assoc-ref colors 'bg)))))
207
208 (define image
209 (normalize-file (grub-background-image config)
210 store-mount-point
211 store-directory-prefix))
212
213 (and image
214 #~(format #$port "
215# Set 'root' to the partition that contains /gnu/store.
216~a
217
218~a
219~a
220
221insmod png
222if background_image ~a; then
223 set color_normal=~a
224 set color_highlight=~a
225else
226 set menu_color_normal=cyan/blue
227 set menu_color_highlight=white/blue
228fi~%"
229 #$(grub-root-search store-device image)
230 #$(setup-gfxterm config)
231 #$(grub-setup-io config)
232
233 #$image
234 #$(theme-colors grub-theme-color-normal)
235 #$(theme-colors grub-theme-color-highlight))))
236
237
238;;;
239;;; Configuration file.
240;;;
241
242(define* (keyboard-layout-file layout
243 #:key
244 (grub grub))
245 "Process the X keyboard layout description LAYOUT, a <keyboard-layout> record,
246and return a file in the format for GRUB keymaps. LAYOUT must be present in
247the 'share/X11/xkb/symbols/' directory of 'xkeyboard-config'."
248 (define builder
249 (with-imported-modules '((guix build utils))
250 #~(begin
251 (use-modules (guix build utils))
252
253 ;; 'grub-kbdcomp' passes all its arguments but '-o' to 'ckbcomp'
254 ;; (from the 'console-setup' package).
255 (invoke #+(file-append grub "/bin/grub-mklayout")
256 "-i" #+(keyboard-layout->console-keymap layout)
257 "-o" #$output))))
258
259 (computed-file (string-append "grub-keymap."
260 (string-map (match-lambda
261 (#\, #\-)
262 (chr chr))
263 (keyboard-layout-name layout)))
264 builder))
265
266(define (grub-setup-io config)
267 "Return GRUB commands to configure the input / output interfaces. The result
268is a string that can be inserted in grub.cfg."
269 (let* ((symbols->string (lambda (list)
270 (string-join (map symbol->string list) " ")))
271 (outputs (bootloader-configuration-terminal-outputs config))
272 (inputs (bootloader-configuration-terminal-inputs config))
273 (unit (bootloader-configuration-serial-unit config))
274 (speed (bootloader-configuration-serial-speed config))
275
276 ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT,
277 ;; as documented in GRUB manual section "Simple Configuration
278 ;; Handling".
279 (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3
280 gfxterm vga_text mda_text morse spkmodem))
281 (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3
282 at_keyboard usb_keyboard))
283
284 (io (string-append
285 ;; UNIT and SPEED are arguments to the same GRUB command
286 ;; ("serial"), so we process them together.
287 (if (or unit speed)
288 (string-append
289 "serial"
290 (if unit
291 ;; COM ports 1 through 4
292 (if (and (exact-integer? unit) (<= unit 3) (>= unit 0))
293 (string-append " --unit=" (number->string unit))
294 #f)
295 "")
296 (if speed
297 (if (exact-integer? speed)
298 (string-append " --speed=" (number->string speed))
299 #f)
300 "")
301 "\n")
302 "")
303 (if (null? inputs)
304 ""
305 (string-append
306 "terminal_input "
307 (symbols->string
308 (map
309 (lambda (input)
310 (if (memq input valid-inputs) input #f)) inputs))
311 "\n"))
312 "terminal_output "
313 (symbols->string
314 (map
315 (lambda (output)
316 (if (memq output valid-outputs) output #f)) outputs)))))
317 (format #f "~a" io)))
318
319(define (grub-root-search device file)
320 "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
321a gexp. The result is a gexp that can be inserted in the grub.cfg-generation
322code."
323 ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
324 ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of
325 ;; custom menu entries. In the latter case, don't emit a 'search' command.
326 (if (and (string? file) (not (string-prefix? "/" file)))
327 ""
328 (match device
329 ;; Preferably refer to DEVICE by its UUID or label. This is more
330 ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
331 ((? uuid? uuid)
332 (format #f "search --fs-uuid --set ~a"
333 (uuid->string device)))
334 ((? file-system-label? label)
335 (format #f "search --label --set ~a"
336 (file-system-label->string label)))
337 ((? (lambda (device)
338 (and (string? device) (string-contains device ":/"))) nfs-uri)
339 ;; If the device is an NFS share, then we assume that the expected
340 ;; file on that device (e.g. the GRUB background image or the kernel)
341 ;; has to be loaded over the network. Otherwise we would need an
342 ;; additional device information for some local disk to look for that
343 ;; file, which we do not have.
344 ;;
345 ;; We explicitly set "root=(tftp)" here even though if grub.cfg
346 ;; had been loaded via TFTP, Grub would have set "root=(tftp)"
347 ;; automatically anyway. The reason is if you have a system that
348 ;; used to be on NFS but now is local, root would be set to local
349 ;; disk. If you then selected an older system generation that is
350 ;; supposed to boot from network in the Grub boot menu, Grub still
351 ;; wouldn't load those files from network otherwise.
352 ;;
353 ;; TFTP is preferred to HTTP because it is used more widely and
354 ;; specified in standards more widely--especially BOOTP/DHCPv4
355 ;; defines a TFTP server for DHCP option 66, but not HTTP.
356 ;;
357 ;; Note: DHCPv6 specifies option 59 to contain a boot-file-url,
358 ;; which can contain a HTTP or TFTP URL.
359 ;;
360 ;; Note: It is assumed that the file paths are of a similar
361 ;; setup on both the TFTP server and the NFS server (it is
362 ;; not possible to search for files on TFTP).
363 ;;
364 ;; TODO: Allow HTTP.
365 "set root=(tftp)")
366 ((or #f (? string?))
367 #~(format #f "search --file --set ~a" #$file)))))
368
369(define* (device->hurd-device-name device-spec #:key (disk "w"))
370 "Return DEVICE as a Hurd name spec: part:PART-NUMBER:device:DISKdDISK-INDEX."
371 (let ((device-name (canonicalize-device-spec device-spec)))
372 (device-name->hurd-device-name device-name #:disk disk)))
373
374(define* (make-grub-configuration grub config entries
375 #:key
376 (locale #f)
377 (system (%current-system))
378 (old-entries '())
379 (store-crypto-devices '())
380 store-directory-prefix)
381 "Return the GRUB configuration file corresponding to CONFIG, a
382<bootloader-configuration> object, and where the store is available at
383STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu
384entries corresponding to old generations of the system.
385STORE-CRYPTO-DEVICES contain the UUIDs of the encrypted units that must
386be unlocked to access the store contents.
387STORE-DIRECTORY-PREFIX may be used to specify a store prefix, as is required
388when booting a root file system on a Btrfs subvolume."
389 (define all-entries
390 (append entries (bootloader-configuration-menu-entries config)))
391 (define (menu-entry->gexp entry)
392 (let ((label (menu-entry-label entry))
393 (linux (menu-entry-linux entry))
394 (device (menu-entry-device entry))
395 (device-mount-point (menu-entry-device-mount-point entry))
396 (multiboot-kernel (menu-entry-multiboot-kernel entry))
397 (chain-loader (menu-entry-chain-loader entry)))
398 (cond
399 (linux
400 (let ((arguments (menu-entry-linux-arguments entry))
401 (linux (normalize-file linux
402 device-mount-point
403 store-directory-prefix))
404 (initrd (normalize-file (menu-entry-initrd entry)
405 device-mount-point
406 store-directory-prefix))
407 (extra-initrd (bootloader-configuration-extra-initrd config))
408 (luks-script-initrd
409 (and (pair? store-crypto-devices)
410 "newc:etc/luks_script:(proc)/luks_script")))
411 ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
412 ;; Use the right file names for LINUX and INITRD in case
413 ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
414 ;; separate partition.
415
416 ;; When STORE-DIRECTORY-PREFIX is defined, prepend it the linux and
417 ;; initrd paths, to allow booting from a Btrfs subvolume.
418
419 ;; When the store is on an encrypted device, inject GRUB's
420 ;; (proc)/luks_script into the initrd as /etc/luks_script so the
421 ;; initrd can use the already-decrypted master key to open LUKS
422 ;; volumes without prompting for the password a second time.
423 #~(format port "menuentry ~s {
424 ~a
425 linux ~a ~a
426 initrd ~a ~a ~a
427}~%"
428 #$label
429 #$(grub-root-search device linux)
430 #$linux (string-join (list #$@arguments))
431 (or #$luks-script-initrd "")
432 (or #$extra-initrd "")
433 #$initrd)))
434 (multiboot-kernel
435 (let* ((kernel (menu-entry-multiboot-kernel entry))
436 (arguments (menu-entry-multiboot-arguments entry))
437 ;; Choose between device names as understood by Mach's built-in
438 ;; IDE driver ("hdX") and those understood by rumpdisk ("wdX"
439 ;; in the "noide" case). There are no IDE drivers in Mach for
440 ;; hurd64, so always use rumpdisk there.
441 (rumpdisk? (or (target-hurd64?)
442 (member "noide" arguments)))
443 (disk (if rumpdisk? "w" "h"))
444 (device-spec (and=> device file-system-device->string))
445 (device-name (and=> device-spec device-spec->device-name))
446 (modules (menu-entry-multiboot-modules entry)))
447 #~(format port "
448menuentry ~s {
449 ~a
450 multiboot ~a root=~a~a~a
451}~%"
452 #$label
453 #$(grub-root-search device kernel)
454 #$kernel
455 #$(device-name->hurd-device-name device-name #:disk disk)
456 (string-join (list #$@arguments) " " 'prefix)
457 (string-join (map string-join '#$modules)
458 "\n module " 'prefix))))
459 (chain-loader
460 #~(format port "
461menuentry ~s {
462 ~a
463 chainloader ~a
464}~%"
465 #$label
466 #$(grub-root-search device chain-loader)
467 #$chain-loader)))))
468
469 (define (crypto-devices)
470 (define (crypto-device->cryptomount dev)
471 (if (uuid? dev)
472 #~(format port "cryptomount -u ~a~%"
473 ;; cryptomount only accepts UUID without the hypen.
474 #$(string-delete #\- (uuid->string dev)))
475 ;; Other type of devices aren't implemented.
476 #~()))
477 (let ((devices (map crypto-device->cryptomount store-crypto-devices))
478 (modules #~(format port "insmod procfs~%insmod luks~%insmod luks2~%")))
479 (if (null? devices)
480 devices
481 (cons modules devices))))
482
483 (define (sugar)
484 (let* ((entry (first all-entries))
485 (device (menu-entry-device entry))
486 (mount-point (menu-entry-device-mount-point entry)))
487 (eye-candy config
488 device
489 mount-point
490 #:store-directory-prefix store-directory-prefix
491 #:port #~port)))
492
493 (define locale-config
494 (let* ((entry (first all-entries))
495 (device (menu-entry-device entry))
496 (mount-point (menu-entry-device-mount-point entry)))
497 #~(let ((locale #$(and locale
498 (locale-definition-source
499 (locale-name->definition locale))))
500 (locales #$(and locale
501 (normalize-file (grub-locale-directory grub)
502 mount-point
503 store-directory-prefix))))
504 (when locale
505 (format port "\
506# Localization configuration.
507~asearch --file --set ~a/[email protected]
508set locale_dir=~a
509set lang=~a~%"
510 ;; Skip the search if there is an image, as it has already
511 ;; been performed by eye-candy and traversing the store is
512 ;; an expensive operation.
513 #$(if (grub-theme-image (bootloader-theme config))
514 "# "
515 "")
516 locales
517 locales
518 locale)))))
519
520 (define keyboard-layout-config
521 (let* ((layout (bootloader-configuration-keyboard-layout config))
522 (keymap* (and layout
523 (keyboard-layout-file layout #:grub grub)))
524 (entry (first all-entries))
525 (device (menu-entry-device entry))
526 (mount-point (menu-entry-device-mount-point entry))
527 (keymap (and keymap*
528 (normalize-file keymap* mount-point
529 store-directory-prefix))))
530 #~(when #$keymap
531 (format port "\
532insmod keylayouts
533keymap ~a~%" #$keymap))))
534
535 (define builder
536 #~(call-with-output-file #$output
537 (lambda (port)
538 (format port
539 "# This file was generated from your Guix configuration. Any changes
540# will be lost upon reconfiguration.
541")
542 #$@(crypto-devices)
543 #$(sugar)
544 #$locale-config
545 #$keyboard-layout-config
546 (format port "
547set default=~a
548set timeout=~a~%"
549 #$(bootloader-configuration-default-entry config)
550 #$(bootloader-configuration-timeout config))
551 #$@(map menu-entry->gexp all-entries)
552
553 #$@(if (pair? old-entries)
554 #~((format port "
555submenu \"GNU system, old configurations...\" {~%")
556 #$@(map menu-entry->gexp old-entries)
557 (format port "}~%"))
558 #~())
559 (format port "
560if [ \"${grub_platform}\" == efi ]; then
561 menuentry \"Firmware setup\" {
562 fwsetup
563 }
564fi~%"))))
565
566 ;; Since this file is rather unique, there's no point in trying to
567 ;; substitute it.
568 (computed-file "grub.cfg" builder
569 #:options '(#:local-build? #t
570 #:substitutable? #f)))
571
572(define (grub-configuration-file config . args)
573 (let* ((bootloader (bootloader-configuration-bootloader config))
574 (grub (bootloader-package bootloader)))
575 (apply make-grub-configuration grub config args)))
576
577(define (grub-efi-configuration-file . args)
578 (apply make-grub-configuration grub-efi args))
579
580(define grub-cfg "/boot/grub/grub.cfg")
581
582
583
584;;;
585;;; Install procedures.
586;;;
587
588(define install-grub
589 #~(lambda (bootloader device mount-point)
590 (let ((grub (string-append bootloader "/sbin/grub-install"))
591 (install-dir (string-append mount-point "/boot")))
592 ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. If DEVICE
593 ;; is #f, then we populate the disk-image rooted at MOUNT-POINT.
594 (if device
595 (begin
596 ;; Tell 'grub-install' that there might be a LUKS-encrypted
597 ;; /boot or root partition.
598 (setenv "GRUB_ENABLE_CRYPTODISK" "y")
599
600 ;; Hide potentially confusing messages from the user, such as
601 ;; "Installing for i386-pc platform."
602 (invoke/quiet grub "--no-floppy" "--target=i386-pc"
603 "--boot-directory" install-dir
604 device))
605 ;; When creating a disk-image, only install a font and GRUB modules.
606 (let* ((fonts (string-append install-dir "/grub/fonts")))
607 (mkdir-p fonts)
608 (copy-file (string-append bootloader "/share/grub/unicode.pf2")
609 (string-append fonts "/unicode.pf2"))
610 (copy-recursively (string-append bootloader "/lib/")
611 install-dir))))))
612
613(define install-grub-disk-image
614 #~(lambda (bootloader root-index image)
615 ;; Install GRUB on the given IMAGE. The root partition index is
616 ;; ROOT-INDEX.
617 (let ((grub-mkimage
618 (string-append bootloader "/bin/grub-mkimage"))
619 (modules '("biosdisk" "part_msdos" "fat" "ext2"))
620 (grub-bios-setup
621 (string-append bootloader "/sbin/grub-bios-setup"))
622 (root-device (format #f "hd0,msdos~a" root-index))
623 (boot-img (string-append bootloader "/lib/grub/i386-pc/boot.img"))
624 (device-map "device.map"))
625
626 ;; Create a minimal, standalone GRUB image that will be written
627 ;; directly in the MBR-GAP (space between the end of the MBR and the
628 ;; first partition).
629 (apply invoke grub-mkimage
630 "-O" "i386-pc"
631 "-o" "core.img"
632 "-p" (format #f "(~a)/boot/grub" root-device)
633 modules)
634
635 ;; Create a device mapping file.
636 (call-with-output-file device-map
637 (lambda (port)
638 (format port "(hd0) ~a~%" image)))
639
640 ;; Copy the default boot.img, that will be written on the MBR sector
641 ;; by GRUB-BIOS-SETUP.
642 (copy-file boot-img "boot.img")
643
644 ;; Install both the "boot.img" and the "core.img" files on the given
645 ;; IMAGE. On boot, the MBR sector will execute the minimal GRUB
646 ;; written in the MBR-GAP. GRUB configuration and missing modules will
647 ;; be read from ROOT-DEVICE.
648 (invoke grub-bios-setup
649 "-m" device-map
650 "-r" root-device
651 "-d" "."
652 image))))
653
654(define* (make-grub-efi-installer #:key efi32? removable?)
655 "Return a G-expression of a procedure for installing GRUB on a UEFI
656system. If EFI32? is #t, then a 32-bit target will be used. If
657REMOVABLE? is #t, GRUB will be installed for Removable Media Boot."
658 (define extra-args
659 (list (and efi32?
660 #~(cond ((target-x86?) "--target=i386-efi")
661 ((target-arm?) "--target=arm-efi")))
662 ;; This does not update UEFI boot entries, like --no-nvram.
663 (and removable? "--removable")))
664 #~(lambda (bootloader efi-dir mount-point)
665 ;; There is nothing useful to do when called in the context of a disk
666 ;; image generation.
667 (when efi-dir
668 ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
669 ;; system whose root is mounted at MOUNT-POINT.
670 (let ((grub-install (string-append bootloader "/sbin/grub-install"))
671 (install-dir (string-append mount-point "/boot"))
672 ;; When installing Guix, it's common to mount EFI-DIR below
673 ;; MOUNT-POINT rather than /boot/efi on the live image.
674 (target-esp (if (file-exists? (string-append mount-point efi-dir))
675 (string-append mount-point efi-dir)
676 efi-dir)))
677 ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
678 ;; root partition.
679 (setenv "GRUB_ENABLE_CRYPTODISK" "y")
680 (invoke/quiet grub-install "--bootloader-id=Guix"
681 "--boot-directory" install-dir
682 "--efi-directory" target-esp
683 #$@(filter identity extra-args))))))
684
685(define* (make-grub-efi-netboot-installer grub-efi grub-cfg subdir)
686 "Make a bootloader-installer for a grub-efi-netboot bootloader, which expects
687its files in SUBDIR and its configuration file in GRUB-CFG.
688
689As a grub-efi-netboot package is already pre-installed by 'grub-mknetdir', the
690installer basically copies all files from the bootloader-package (or profile)
691into the bootloader-target directory.
692
693Additionally for network booting over TFTP, two relative symlinks to the store
694and to the GRUB-CFG file are necessary. Due to this a TFTP root directory must
695not be located on a FAT file-system.
696
697If the bootloader-target does not support symlinks, then it is assumed to be a
698kind of EFI System Partition (ESP). In this case an intermediate configuration
699file is created with the help of GRUB-EFI to load the GRUB-CFG.
700
701The installer is usable for any efi-bootloader-chain, which prepares the
702bootloader-profile in a way ready for copying.
703
704The installer does not manipulate the system's 'UEFI Boot Manager'.
705
706The returned installer accepts the BOOTLOADER, TARGET and MOUNT-POINT
707arguments. Its job is to copy the BOOTLOADER, which must be a pre-installed
708grub-efi-netboot package with a SUBDIR like efi/boot or efi/Guix, below the
709directory TARGET for the system whose root is mounted at MOUNT-POINT.
710
711MOUNT-POINT is the last argument in 'guix system init /etc/config.scm mnt/point'
712or '/' for other 'guix system' commands.
713
714Where TARGET comes from the targets argument given to the
715bootloader-configuration in:
716
717(operating-system
718 (bootloader (bootloader-configuration
719 (targets '(\"/boot/efi\"))
720 …))
721 …)
722
723TARGET is required to be an absolute directory name, usually mounted via NFS,
724and finally needs to be provided by a TFTP server as
725the TFTP root directory.
726
727Usually the installer will be used to prepare network booting over TFTP. Then
728GRUB will load tftp://server/SUBDIR/grub.cfg and this file will instruct it to
729load more files from the store like tftp://server/gnu/store/…-linux…/Image.
730
731To make this possible two symlinks are created. The first symlink points
732relatively form MOUNT-POINT/TARGET/SUBDIR/grub.cfg to
733MOUNT-POINT/boot/grub/grub.cfg, and the second symlink points relatively from
734MOUNT-POINT/TARGET/%store-prefix to MOUNT-POINT/%store-prefix.
735
736It is important to note that these symlinks need to be relative, as the absolute
737paths on the TFTP server side are unknown.
738
739It is also important to note that both symlinks will point outside the TFTP root
740directory and that the TARGET/%store-prefix symlink makes the whole store
741accessible via TFTP. Possibly the TFTP server must be configured to allow
742accesses outside its TFTP root directory. This all may need to be considered
743for security aspects. It is advised to disable any TFTP write access!
744
745The installer can also be used to prepare booting from local storage, if the
746underlying file-system, like FAT on an EFI System Partition (ESP), does not
747support symlinks. In this case the MOUNT-POINT/TARGET/SUBDIR/grub.cfg will be
748created with the help of GRUB-EFI to load the /boot/grub/grub.cfg file. A
749symlink to the store is not needed in this case."
750 (with-imported-modules '((guix build union))
751 #~(lambda (bootloader target mount-point)
752 ;; In context of a disk image creation TARGET will be #f and an
753 ;; installer is expected to do necessary installations on MOUNT-POINT,
754 ;; which will become the root file system. If TARGET is #f, this
755 ;; installer has nothing to do, as it only cares about the EFI System
756 ;; Partition (ESP).
757 (when target
758 (use-modules ((guix build union) #:select (symlink-relative))
759 (ice-9 popen)
760 (ice-9 rdelim))
761 (let* ((mount-point/target (string-append mount-point target "/"))
762 ;; When installing Guix, it is common to mount TARGET below
763 ;; MOUNT-POINT rather than the root directory.
764 (bootloader-target (if (file-exists? mount-point/target)
765 mount-point/target
766 target))
767 (store (string-append mount-point (%store-prefix)))
768 (store-link (string-append bootloader-target (%store-prefix)))
769 (grub-cfg (string-append mount-point #$grub-cfg))
770 (grub-cfg-link (string-append bootloader-target
771 #$subdir "/"
772 (basename grub-cfg))))
773 ;; Copy the bootloader into the bootloader-target directory.
774 ;; Should we beforehand recursively delete any existing file?
775 (copy-recursively bootloader bootloader-target
776 #:follow-symlinks? #t
777 #:log (%make-void-port "w"))
778 ;; For TFTP we need to install additional relative symlinks.
779 ;; If we install on an EFI System Partition (ESP) or some other FAT
780 ;; file-system, then symlinks cannot be created and are not needed.
781 ;; Therefore we ignore exceptions when trying.
782 ;; Prepare the symlink to the grub.cfg.
783 (mkdir-p (dirname grub-cfg-link))
784 (false-if-exception (delete-file grub-cfg-link))
785 (if (unspecified?
786 (false-if-exception (symlink-relative grub-cfg grub-cfg-link)))
787 ;; Symlinks are supported.
788 (begin
789 ;; Prepare the symlink to the store.
790 (mkdir-p (dirname store-link))
791 (false-if-exception (delete-file store-link))
792 (symlink-relative store store-link))
793 ;; Creating symlinks does not seem to be supported. Probably
794 ;; an ESP is used. Add a script to search and load the actual
795 ;; grub.cfg.
796 (let* ((probe #$(file-append grub-efi "/sbin/grub-probe"))
797 (port (open-pipe* OPEN_READ probe "--target=fs_uuid"
798 grub-cfg))
799 (search-root
800 (match (read-line port)
801 ((? eof-object?)
802 ;; There is no UUID available. As a fallback search
803 ;; everywhere for the grub.cfg.
804 (string-append "search --file --set " #$grub-cfg))
805 (fs-uuid
806 ;; The UUID to load the grub.cfg from is known.
807 (string-append "search --fs-uuid --set " fs-uuid))))
808 (load-grub-cfg (string-append "configfile " #$grub-cfg)))
809 (close-pipe port)
810 (with-output-to-file grub-cfg-link
811 (lambda ()
812 (display (string-join (list search-root
813 load-grub-cfg)
814 "\n")))))))))))
815
816
817
818;;;
819;;; Bootloader definitions.
820;;;
821;;; For all these grub-bootloader variables the path to /boot/grub/grub.cfg
822;;; is fixed. Inheriting and overwriting the field 'configuration-file' will
823;;; break 'guix system delete-generations', 'guix system switch-generation',
824;;; and 'guix system roll-back'.
825
826(define grub-bootloader
827 (bootloader
828 (name 'grub)
829 (package grub)
830 (installer install-grub)
831 (disk-image-installer install-grub-disk-image)
832 (configuration-file grub-cfg)
833 (configuration-file-generator grub-configuration-file)))
834
835(define grub-minimal-bootloader
836 (bootloader
837 (inherit grub-bootloader)
838 (package grub-minimal)))
839
840(define grub-efi-bootloader
841 (bootloader
842 (name 'grub-efi)
843 (package grub-efi)
844 (installer (make-grub-efi-installer))
845 (disk-image-installer #f)
846 (configuration-file grub-cfg)
847 (configuration-file-generator grub-configuration-file)))
848
849(define grub-efi-removable-bootloader
850 (bootloader
851 (inherit grub-efi-bootloader)
852 (name 'grub-efi-removable-bootloader)
853 (installer (make-grub-efi-installer #:removable? #t))))
854
855(define grub-efi32-bootloader
856 (bootloader
857 (inherit grub-efi-bootloader)
858 (installer (make-grub-efi-installer #:efi32? #t))
859 (name 'grub-efi32)
860 (package grub-efi32)))
861
862(define grub-efi32-removable-bootloader
863 (bootloader
864 (inherit grub-efi32-bootloader)
865 (name 'grub-efi32-removable-bootloader)
866 (installer (make-grub-efi-installer #:removable? #t
867 #:efi32? #t))))
868
869(define (make-grub-efi-netboot-bootloader name subdir)
870 (bootloader
871 (name name)
872 (package (make-grub-efi-netboot (symbol->string name) subdir))
873 (installer (make-grub-efi-netboot-installer grub-efi grub-cfg subdir))
874 (disk-image-installer #f)
875 (configuration-file grub-cfg)
876 (configuration-file-generator grub-efi-configuration-file)))
877
878(define grub-efi-netboot-bootloader
879 (make-grub-efi-netboot-bootloader 'grub-efi-netboot-bootloader
880 "efi/Guix"))
881
882(define grub-efi-netboot-removable-bootloader
883 (make-grub-efi-netboot-bootloader 'grub-efi-netboot-removable-bootloader
884 "efi/boot"))
885
886(define grub-mkrescue-bootloader
887 (bootloader
888 (inherit grub-efi-bootloader)
889 (package grub-hybrid)))
890
891
892;;;
893;;; Compatibility macros.
894;;;
895
896(define-syntax grub-configuration
897 (syntax-rules (grub)
898 ((_ (grub package) fields ...)
899 (if (eq? package grub)
900 (bootloader-configuration
901 (bootloader grub-bootloader)
902 fields ...)
903 (bootloader-configuration
904 (bootloader grub-efi-bootloader)
905 fields ...)))
906 ((_ fields ...)
907 (bootloader-configuration
908 (bootloader grub-bootloader)
909 fields ...))))
910
911
912;;;
913;;; Deprecated bootloader and installer variables.
914;;;
915
916(define-deprecated/alias install-grub-efi-removable
917 (make-grub-efi-installer #:removable? #t))
918
919;;; grub.scm ends here