gnu/bootloader/grub.scm

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