guix/gnu/bootloader/grub.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
;;; Copyright © 2022 Karl Hallsby <karl@hallsby.com>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu bootloader grub)
  #:use-module (gnu artwork)
  #:use-module (gnu bootloader)
  #:use-module (gnu packages bootloaders)
  #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
  #:autoload   (gnu packages xorg) (xkeyboard-config)
  #:use-module (gnu services configuration)
  #:use-module (gnu system boot)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system keyboard)
  #:use-module (gnu system locale)
  #:use-module (gnu system uuid)
  #:use-module (guix deprecation)
  #:use-module (guix diagnostics)
  #:use-module (guix gexp)
  #:use-module (guix i18n)
  #:use-module (guix records)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:export (grub-theme
            grub-theme?
            grub-theme-image
            grub-theme-resolution
            grub-theme-color-normal
            grub-theme-color-highlight
            grub-theme-gfxmode

            grub.dir ; for (gnu build image) iso9660 images
            grub-bootloader
            grub-minimal-bootloader
            grub-efi-bootloader
            ;; deprecated
            grub-efi-removable-bootloader
            grub-efi32-bootloader
            grub-efi-netboot-bootloader
            grub-efi-netboot-removable-bootloader))


;;;
;;; General utils.
;;;

(define (sanitize str)
  "In-G-exp procedure to sanitize a value for use in a GRUB script."
  #~(let ((glycerin (lambda (l r)
                      (if (pair? l) (append l r) (cons l r))))
          ;; In lieu of escaped-string from (guix read-print).
          (isopropyl (lambda (c)
                       (case c ((#\\ #\$ #\") '(#\\ ,c)) (else c)))))
      (use-modules (srfi srfi-1))
      (list->string (fold-right glycerin '()
                                (map isopropyl (string->list #$str))))))

;; Name of variable with GRUB search result for boot device.
(define %boot "boot")

;; TODO: Use device-mount-point and device-subvol.
(define (normalize-file file)
  #~(string-append "($" #$%boot ")" #$(sanitize file)))

(define* (search/target type targets var #:optional (port #f))
  "Returns a gexp of a GRUB search command for target TYPE, storing the
result in VAR.  Optionally outputs to the gexp PORT instead of returning
a string."
  (define (form name val)
    #~(format #$port "search.~a \"~a\" ~a~%" #$name #$val #$var))
  (with-targets targets
    ((type => (path :devpath) (device :device) (fs :fs)
              (label :label) (uuid :uuid))
     (cond ((member fs '("tftp" "nfs")) #~(format #$port "set ~a=tftp~%" #$var))
           (uuid (form "fs_uuid" (uuid->string uuid)))
           (label (form "fs_label" label))
           (else (form "file" (sanitize path)))))))

(define (when-list . xs) (filter identity xs))


;;;
;;; Theming.
;;;

(define-record-type* <grub-theme>
  ;; Default theme contributed by Felipe López.
  grub-theme make-grub-theme grub-theme?
  (image           grub-theme-image
                   (default (file-append %artwork-repository
                                         "/grub/GuixSD-fully-black-4-3.svg")))
  (resolution      grub-theme-resolution
                   (default '(1024 . 768)))
  (color-normal    grub-theme-color-normal
                   (default '((fg . light-gray) (bg . black))))
  (color-highlight grub-theme-color-highlight
                   (default '((fg . yellow) (bg . black))))
  (gfxmode         grub-theme-gfxmode
                   (default '("auto"))))          ;list of string

(define (grub-theme-png theme)
  "Return the GRUB background image defined in THEME.  If the suffix of
the image file is \".svg\", then it is converted into a PNG file with
the resolution provided in CONFIG.  Returns #f if no file is provided."
  (match-record theme <grub-theme> (image resolution)
    (match resolution
      (((? number? width) . (? number? height))
       (computed-file "grub-image.png"
         (with-imported-modules '((gnu build svg) (guix build utils))
           (with-extensions (list guile-rsvg guile-cairo)
             #~(begin (use-modules (gnu build svg) (guix build utils))
                      (if (png-file? #$image) (copy-file #$image #$output)
                        (svg->png #$image #$output
                                  #:width #$width
                                  #:height #$height)))))))
      (_ image))))

(define (serialize-grub-theme value install)
  (match-record value <grub-theme>
    (image color-normal color-highlight)
    (define (colors->str colors)
      (format #f "~a/~a" (assoc-ref colors 'fg) (assoc-ref colors 'bg)))
    (and image
         #~(format #f "insmod png
if background_image \"($root)~a/image.png\"; then
  set color_normal=~a
  set color_highlight=~a
else
  set menu_color_normal=cyan/blue
  set menu_color_highlight=white/blue
fi~%"
                   #$(sanitize install)
                   #$(colors->str color-normal)
                   #$(colors->str color-highlight)))))


;;;
;;; Core config.
;;; GRUB architecture works by having a bootstage load up a core.img,
;;; which then sets the root and prefix variables, allowing grub to load
;;; its main config and modules, and then enter normal mode.  On i386-pc
;;; systems a boot.img is flashed which loads the core.img from the MBR
;;; gap, but on efi systems the core.img is just a PE executable, able
;;; to be booted directly.  We set up a minimal core.img capable of
;;; finding the user-configured 'install target to load its config from
;;; there.
;;;

(define (core.cfg targets store-crypto-devices)
  "Returns a filelike object for a core configuration file good enough to
decrypt STORE-CRYPTO-DEVICES and boot to normal."
  (define (crypto-device->cryptomount dev)
    (and (uuid? dev) ; ignore non-uuids - warning given by os
         #~(format port "cryptomount -u ~a~%"
                   ;; cryptomount only accepts UUID without the hyphen.
                   #$(string-delete #\- (uuid->string dev)))))

  (and=>
    (with-targets targets
      (('install => (path :devpath))
       #~(call-with-output-file #$output
           (lambda (port)
             #$@(filter ->bool
                  (map crypto-device->cryptomount store-crypto-devices))
             #$(search/target 'install targets "root" #~port)
             (format port "set \"prefix=($root)~a\"~%" #$(sanitize path))))))
    (cut computed-file "core.cfg" <>)))

;; XXX: Would a FORMAT symbol instead of string be better?
(define (core.cfg->core.img grub format bootloader-config
                            store-crypto-devices cfg fs)
  "Return a G-exp for a GRUB core image configured with CFG, built for
FORMAT and the file system FS."
  (let* ((tftp? (or (string=? fs "tftp") (string=? fs "nfs")))
         (bios? (string-prefix? format "pc"))
         (efi? (string=? format "efi"))
         (32? (bootloader-configuration-32bit? bootloader-config))
         (grub-format
           (cond ((string-prefix? "pc" format) "i386")
                 ((target-x86-32?) "i386")
                 ((target-x86-64?) (if 32? "i386" "x86_64"))
                 ((target-arm32?) "arm")
                 ((target-aarch64?) (if 32? "arm" "arm64"))
                 ((target-powerpc?) "powerpc")
                 ((target-riscv64?) "riscv64")
                 (else (raise (formatted-message
                                (G_ "unrecognized target arch '~a'!")
                                (or (%current-target-system)
                                    (%current-system)))))))
         (format (string-append grub-format "-" format
                                (if (and bios? tftp?) "-pxe" ""))))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils) (ice-9 textual-ports)
                       (srfi srfi-1))
          (apply invoke #$(file-append grub "/bin/grub-mkimage")
            "--output" #$output
            "--config" #$cfg
            "--prefix" "none" ; we override this in cfg
            ;; bios pxe uses pxeboot instead of diskboot - diff format
            "--format" #$format
            "--compression" "auto"
            ;; modules
            "minicmd"
            (append
              ;; disk drivers
              '#$(if bios? '("biosdisk") '())
              ;; partmaps
              ;; TODO: detect which to use.
              '#$(if tftp? '() '("part_msdos" "part_gpt"))
              ;; file systems
              '#$(cond ((member fs '("ext2" "ext3" "ext4")) '("ext2"))
                       ((member fs '("vfat" "fat32")) '("fat"))
                       ((and tftp? efi?) '("efinet"))
                       ((and tftp? bios?) '("pxe"))
                       (else (list fs)))
              ;; store crypto devs
              '#$(if (any uuid? store-crypto-devices)
                   '("luks" "luks2" "cryptomount") '())
              ;; search module that cfg uses
              (call-with-input-file #$cfg
                (lambda (port)
                   (let* ((str (get-string-all port))
                          (use (lambda (s) (string-contains str s))))
                     (cond ((use "search.fs_uuid") '("search_fs_uuid"))
                           ((use "search.fs_label") '("search_label"))
                           ((use "search.file") '("search_fs_file"))
                           (else '())))))))))))

;; XXX: Do we need LVM support here?
(define* (core.img grub format #:key bootloader-config store-crypto-devices
                               #:allow-other-keys)
  "The core image for GRUB, built for FORMAT."
  (let* ((targets (bootloader-configuration-targets bootloader-config))
         (cfg (core.cfg targets store-crypto-devices)))
    (and=>
      (and cfg
           (with-targets targets
             (('install => (fs :fs))
              (core.cfg->core.img grub format bootloader-config
                                  store-crypto-devices cfg fs))))
      (cut computed-file "core.img" <>
           #:options '(#:local-build? #t #:substitutable? #f)))))


;;;
;;; Main config.
;;; This is what does the heavy lifting after core.img finds it.
;;;

(define (serialize-string value)
  (match value
    ((key value) #~(string-append #$key "=" #$value))
    ((? string?) #~#$value)
    (x x)))

(define-maybe string)

(define (serialize-file-like value)
  #~(format #f "  module ~s~%" #$(normalize-file value)))

(define (string-list? x)
  (and (list? x)
       (and-map (match-lambda
                  (((? string?) (? file-like?)) #t)
                  ;; TODO: Remove gexps from linux-arguments.
                  (x (or (string? x) (gexp? x))))
                x)))

(define (file-like-list? x)
  (and (list? x) (and-map file-like? x)))

(define (serialize-string-list value)
  #~(string-join (list #$@(map serialize-string value)) " "))

(define (serialize-file-like-list value)
  #~(string-concatenate (list #$@(map serialize-file-like value))))

(define (grub-device? x)
  (or (not x) (string? x) (uuid? x) (file-system-label? x)))

(define (serialize-grub-device device file)
  "Return the GRUB 'search' command to look for DEVICE, which contains
FILE, a gexp.  The result is a gexp that can be inserted in the
grub.cfg-generation code to set the variable VAR.  This procedure is
able to handle DEVICEs unmounted at evaltime."
  (define (host-prefix? device)
    (and (string? device) (string-contains device ":/")))
  (match device
    ;; Preferably refer to DEVICE by its UUID or label.  This is more
    ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
    ((? uuid?)
     #~(format #f "search.fs_uuid ~a ~a~%"
               #$(uuid->string device) #$%boot))
    ((? file-system-label?)
     #~(format #f "search.fs_label ~s ~a~%"
               #$(sanitize (file-system-label->string device)) #$%boot))
    ((? host-prefix?)
     ;; If the device is an NFS share, then we assume that the expected
     ;; file on that device (e.g. the GRUB background image or the kernel)
     ;; has to be loaded over the network.  Otherwise we would need an
     ;; additional device information for some local disk to look for that
     ;; file, which we do not have.
     ;;
     ;; TFTP is preferred to HTTP because it is used more widely and
     ;; specified in standards more widely--especially BOOTP/DHCPv4
     ;; defines a TFTP server for DHCP option 66, but not HTTP.
     ;;
     ;; Note: DHCPv6 specifies option 59 to contain a boot-file-url,
     ;; which can contain an HTTP or TFTP URL.
     ;;
     ;; Note: It is assumed that the file paths are of a similar
     ;; setup on both the TFTP server and the NFS server (it is
     ;; not possible to search for files on TFTP).
     ;;
     ;; TODO: Allow HTTP.
     #~(format #f "set ~a=tftp~%" #$%boot))
    ((or #f (? string?))
     #~(format #f "search.file ~s ~a~%" #$(sanitize file) #$%boot))))

(define-configuration linux-directive
  ;; XXX: Does normalize-file work on strings?
  (extra-initrd maybe-string "Path to out-of-store initrd with secrets.")
  (initrd file-like "The initial RAM disk to use.")
  (kernel file-like "The Linux kernel image to boot.")
  (arguments
   string-list
   "The list of extra Linux kernel command-line arguments."))

(define (serialize-linux-directive value normalize-file)
  (match-record value <linux-directive>
    (arguments extra-initrd initrd kernel)
    ;; TODO: Convert menu-entry-initrd to file-like.
    (let ((initrd #~(readlink #$initrd))
          (kernel #~(readlink #$kernel)))
      #~(format #f "  linux ~s ~a~%  initrd ~s~%"
                #$(normalize-file kernel)
                ;; GRUB passes the rest of the line _verbatim_.
                #$(serialize-string-list arguments)
                (if #$(maybe-value-set? extra-initrd)
                    ;; XXX: Do not normalize extra-initrd?
                    (string-append #$(normalize-file extra-initrd)
                                   "\" \"" #$(normalize-file initrd))
                    #$(normalize-file initrd))))))

(define-configuration multiboot-directive
  (kernel file-like "The Multiboot kernel image to boot.")
  (arguments
   (string-list '())
   "The list of Multiboot kernel command-line arguments.")
  (modules
   (file-like-list '())
   "The list of commands for loading Multiboot modules."))

(define (serialize-multiboot-directive value normalize-file)
  (match-record value <multiboot-directive>
    (arguments kernel modules)
    ;; Previously, this provided a (wrong) root= argument.
    ;; Just don't bother anymore; better less info than
    ;; wrong info.
    #~(format #f "  multiboot ~s ~a~%~a"
              #$(normalize-file kernel)
              #$(serialize-string-list arguments)
              #$(serialize-file-like-list modules))))

(define (directive-or-file-like? x)
  (or (linux-directive? x) (multiboot-directive? x) (file-like? x)))

(define (serialize-directive-or-file-like value)
  ;; TODO: Use mount-point and subvol to normalize file.
  (match value
    ((? linux-directive?)
     (serialize-linux-directive value normalize-file))
    ((? multiboot-directive?)
     (serialize-multiboot-directive value normalize-file))
    ((? file-like?)
     #~(format #f "  chainloader ~s~%" #$(normalize-file value)))))

(define-configuration grub-menu-entry
  (label string "Entry label with e.g. rank, kernel, and date.")
  (device
   grub-device
   ;; XXX: Is NFS exclusive to Linux?
   "Device UUID or label, NFS path, or block device path, with payload.")
  (device-mount-point maybe-string "Remove prefix from relevant paths.")
  (device-subvol maybe-string "Access files from this Btrfs subvolume.")
  (directive
   directive-or-file-like
   "Configuration for a Linux or Multiboot directive, or a file for the
chainloader directive."))

(define (menu-entry->grub-menu-entry entry extra-initrd)
  "Temporary compatibility function just for trying out a new thing."
  (match-menu-entry entry
    (label device device-mount-point device-subvol linux linux-arguments
     initrd multiboot-kernel multiboot-arguments multiboot-modules
     chain-loader)
    (grub-menu-entry
      (label label)
      (device device)
      (device-mount-point (or device-mount-point %unset-value))
      (device-subvol (or device-subvol %unset-value))
      ;; Prefer linux to multiboot to chainloader.
      (directive (cond
                   (linux
                     (linux-directive
                       (arguments linux-arguments)
                       (extra-initrd (or extra-initrd %unset-value))
                       ;; Refer to single file by (sym)link, not string.
                       ;; TODO: Convert menu-entry-initrd to file-like.
                       (initrd (computed-file "initrd.cpio.gz"
                                 #~(symlink #$initrd #$output)))
                       (kernel (computed-file "bzImage"
                                 #~(symlink #$linux #$output)))))
                   (multiboot-kernel
                     (multiboot-directive
                       (arguments multiboot-arguments)
                       (kernel multiboot-kernel)
                       (modules multiboot-modules)))
                   (chain-loader chain-loader))))))

(define (serialize-grub-menu-entry value)
  (let* ((directive (grub-menu-entry-directive value))
         (file (match directive
                 ((? linux-directive?)
                  (linux-directive-kernel directive))
                 ((? multiboot-directive?)
                  (multiboot-directive-kernel directive))
                 ((? file-like?) directive)))
         (device (grub-menu-entry-device value))
         ;; XXX: Decouple from directive (file).
         (search (serialize-grub-device device file))
         (label (grub-menu-entry-label value))
         (directive (serialize-directive-or-file-like directive)))
    #~(format #f "menuentry ~s {~%  ~a~a}~%"
              #$label #$search #$directive)))

;; E.g. build this file, appended with:
;; (mixed-text-file "grub-menu-entry.texi"
;;                  (generate-grub-menu-entry-documentation))
(define (generate-grub-menu-entry-documentation)
  (generate-documentation
   `((grub-menu-entry
      ,grub-menu-entry-fields
      (directive linux-directive)
      (directive multiboot-directive))
     (linux-directive ,linux-directive-fields)
     (multiboot-directive ,multiboot-directive-fields))
   'grub-menu-entry))

(define (make-grub.cfg bootloader-config locale install menu-entries
                       old-entries gfxterm? outputs inputs theme)
  (define (really-mixed-text-file . xs)
    "Ignores #f arguments and flattens list arguments."
    (apply mixed-text-file (flatten (filter identity xs))))
  (match-bootloader-configuration
    bootloader-config
    ;; XXX: Separate these fields into another record?
    (default-entry timeout serial-unit serial-speed)
    (really-mixed-text-file "grub.cfg" "\
# This file was generated from your Guix configuration. Any changes
# will be lost upon reconfiguration\n"
      ;; menu settings
      (format #f "~@[set default=~a~%~]" default-entry)
      (format #f "~@[set timeout=~a~%~]" timeout)
      ;; gfxterm setup
      (and gfxterm?
           (format #f "\
if loadfont unicode; then
  set gfxmode=~a
  insmod all_video
  insmod gfxterm
fi~%"
                   (string-join (grub-theme-gfxmode theme) ";")))
      ;; io
      (and (or serial-unit serial-speed)
           (format #f "serial~@[ --unit=~d~]~@[ --speed=~d~]~%"
                   serial-unit serial-speed))
      (format #f "~@[terminal_output ~a~%~]" outputs)
      (format #f "~@[terminal_input ~a~%~]" inputs)
      ;; locale
      (and locale
           #~(format #f "\
set locale_dir=\"($root)~a/locales\"
set lang=~a~%"
                     #$(sanitize install)
                     #$(locale-definition-source
                         (locale-name->definition locale))))
      ;; keyboard layout
      (and (bootloader-configuration-keyboard-layout bootloader-config)
           #~(format #f "\
insmod keylayouts
keymap \"($root)~a/keymap\"~%"
                     #$(sanitize install)))
      (serialize-grub-theme theme install)
      ;; menu entries
      menu-entries
      (and (pair? old-entries)
           (cons "submenu \"GNU system, old configurations...\" {\n"
                 ;; Do not indent: initrd line is >80 columns anyway.
                 (append old-entries (list "}\n"))))
      "\
if [ \"${grub_platform}\" == efi ]; then
  menuentry \"Firmware setup\" {
    fwsetup
  }
fi\n")))

(define* (grub.cfg #:key bootloader-config
                         current-boot-alternative
                         old-boot-alternatives
                         locale
                         store-directory-prefix
                   #:allow-other-keys)
  "Returns a valid GRUB config given installer inputs.  Keymap and theme
image are taken from BOOTLOADER-CONFIG, LOCALE is provided explicitly."
  (match-bootloader-configuration
    bootloader-config
    ;; Can't match keyboard-layout here, because it's bound to its struct.
    (menu-entries targets extra-initrd theme terminal-outputs
     terminal-inputs)
    (define (entries->gexp entries)
      (map (compose serialize-grub-menu-entry
                    (cut menu-entry->grub-menu-entry <> extra-initrd))
           entries))
    (define (terms->str terms)
      (and (pair? terms) (format #f "~{~a~^ ~}" terms)))
    (let* ((current-entry (boot-alternative->menu-entry
                            current-boot-alternative))
           (entries (entries->gexp (cons current-entry menu-entries)))
           (old-entries (entries->gexp (map boot-alternative->menu-entry
                                            old-boot-alternatives)))
           (gfxterm? (or (not terminal-outputs)
                         (memq 'gfxterm terminal-outputs)))
           ;; Use the values provided, or the defaults otherwise.
           (outputs (or (and=> terminal-outputs terms->str) "gfxterm"))
           (inputs (and=> terminal-inputs terms->str))
           (theme (or theme (grub-theme))))
      (with-targets targets
        (('install => (install :devpath))
         (make-grub.cfg bootloader-config locale install entries
                        old-entries gfxterm? outputs inputs theme))))))

(define (keyboard-layout-file layout grub)
  "Process the X keyboard layout description LAYOUT, a <keyboard-layout>
record, and return a file in the format for GRUB keymaps.  LAYOUT must be
present in the 'share/X11/xkb/symbols/' directory of 'xkeyboard-config'."
  (computed-file
    (string-append "grub-keymap."
                   (string-map (match-lambda (#\, #\-) (chr chr))
                               (keyboard-layout-name layout)))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))
          ;; 'grub-kbdcomp' passes all its arguments but '-o' to 'ckbcomp'
          ;; (from the 'console-setup' package).
          (invoke #+(file-append grub "/bin/grub-mklayout")
                  "-i" #+(keyboard-layout->console-keymap layout)
                  "-o" #$output)))))

(define* (grub.dir grub #:key bootloader-config locale
                        #:allow-other-keys . args)
  "Everything that should go in GRUB's prefix.  Includes fonts, modules,
locales, keymap, theme image, and grub.cfg."
  (let* ((theme (or (bootloader-configuration-theme bootloader-config)
                    (grub-theme)))
         (keyboard-layout (bootloader-configuration-keyboard-layout
                            bootloader-config))
         (lang (and=> locale (compose locale-definition-source
                                      locale-name->definition)))
         (lc-mesg (and lang (file-append grub "/share/locale" lang
                                         "/LC_MESSAGES/grub.mo"))))
    (computed-file "grub.dir"
      (with-imported-modules '((guix build utils))
        #~(begin
            (use-modules (guix build utils))
            (mkdir-p #$output)
            (chdir #$output)
            ;; grub files
            (copy-recursively #$(file-append grub "/lib/grub/") #$output
                              #:copy-file symlink)
            (mkdir "fonts")
            (symlink #$(file-append grub "/share/grub/unicode.pf2")
                     "fonts/unicode.pf2")
            ;; config file
            (symlink #$(apply grub.cfg args) "grub.cfg")
            ;; locales
            ;; XXX: Warn if missing?
            (when (and=> #$lc-mesg file-exists?)
              (mkdir "locales")
              (symlink #$lc-mesg
                       (string-append "locales/" #$lang ".mo")))
            ;; keymap
            #$@(when-list
                 (and keyboard-layout
                      #~(symlink #$(keyboard-layout-file keyboard-layout
                                                         grub)
                                 "keymap"))
            ;; image
                 (and (grub-theme-image theme)
                      #~(copy-file #$(grub-theme-png theme)
                                   "image.png")))))
      #:options '(#:local-build? #t #:substitutable? #f))))


;;;
;;; Installers.
;;;

(define* (install-grub.dir grub #:key bootloader-config
                                #:allow-other-keys . args)
  (with-targets (bootloader-configuration-targets bootloader-config)
    (('install => (path :path))
     #~(copy-recursively #$(apply grub.dir grub args) #$path
                         #:log (%make-void-port "w")
                         #:follow-symlinks? #t
                         #:copy-file atomic-copy))))

(define (install-grub-bios grub)
  "Returns an installer for the bios-bootable grub package GRUB."
  (lambda* (#:key bootloader-config #:allow-other-keys . args)
    (gbegin (apply install-grub.dir grub args)
      (with-targets (bootloader-configuration-targets bootloader-config)
        (('disk => (device :device))
         #~(invoke #$(file-append grub "/sbin/grub-bios-setup") "-v" "-v"
                   "--directory" "/" ; can't be blank
                   "--device-map" "" ; no dev map - need to specify
                   "--boot-image"
                   #$(file-append grub "/lib/grub/i386-pc/boot.img")
                   "--core-image" #$(apply core.img grub "pc" args)
                   "--root-device" #$(string-append "hostdisk/" device)
                   #$device))))))

(define* (install-grub-efi #:key bootloader-config
                           #:allow-other-keys . args)
  "Installs GRUB into the system's UEFI bootloader, taking into account
user-specified requirements for a 32-bit or fallback bootloader."
  (let* ((32? (bootloader-configuration-32bit? bootloader-config))
         (grub (if 32? grub-efi32 grub-efi))
         (core (apply core.img grub "efi" args))
         (copy #~(lambda (dest) (copy-file #$core dest))))
    (gbegin (apply install-grub.dir grub args)
      (install-efi bootloader-config
                   #~`((,#$copy "grub.efi" . "GNU GRUB"))))))


;;;
;;; Bootloaders.
;;;

(define %grub-default-targets
  (list (bootloader-target
          (type 'install)
          (offset 'root)
          (path "boot"))))

(define grub-bootloader
  (bootloader
    (name 'grub)
    (default-targets %grub-default-targets)
    (installer (install-grub-bios grub))))

(define grub-minimal-bootloader
  (bootloader
    (name 'grub)
    (default-targets %grub-default-targets)
    (installer (install-grub-bios grub-minimal))))

(define grub-efi-bootloader
  (bootloader
    (name 'grub-efi)
    (default-targets (list (bootloader-target
                             (type 'vendir)
                             (offset 'esp)
                             (path "EFI/Guix"))
                           (bootloader-target
                             (type 'install)
                             (offset 'esp)
                             (path "grub"))))
    (installer install-grub-efi)))


;;;
;;; Deprecated!  Use the bootloader-config flags instead.  Or, in the
;;; case of netboot, set your 'install (or parent thereof) target fs to
;;; be "tftp" or "nfs".
;;;

(define (deprecated-installer installer removable? 32?)
  "INSTALLER with overrides for its bootloader-config argument."
  (lambda args
    (apply installer (substitute-keyword-arguments args
                       ((#:bootloader-config conf)
                        (bootloader-configuration
                          (inherit conf)
                          (efi-removable? removable?)
                          (32bit? 32?)))))))

(define-deprecated grub-efi-removable-bootloader grub-efi-bootloader
  (bootloader
    (inherit grub-efi-bootloader)
    (installer (deprecated-installer install-grub-efi #t #f))))

(define-deprecated grub-efi32-bootloader grub-efi-bootloader
  (bootloader
    (inherit grub-efi-bootloader)
    (installer (deprecated-installer install-grub-efi #f #t))))

(define %netboot-targets
  (list (bootloader-target
          (type 'install)
          (offset 'root)
          (path "boot")
          (file-system "tftp"))
        (bootloader-target
          (type 'vendir)
          (offset 'esp)
          (path "EFI/Guix"))))

(define-deprecated grub-efi-netboot-bootloader
                   grub-efi-bootloader
  (bootloader
    (inherit grub-efi-bootloader)
    (default-targets %netboot-targets)))

(define-deprecated grub-efi-netboot-removable-bootloader
                   grub-efi-bootloader
  (bootloader
    (inherit grub-efi-bootloader)
    (default-targets %netboot-targets)
    (installer (deprecated-installer install-grub-efi #t #f))))