;;; 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>
;;;
;;; 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 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))

\f
;;;
;;; General utils.
;;;

;; in-gexp procedure to sanitize a value to be inserted into a GRUB script
(define (sanitize str)
  "Sanitize a value for use in a GRUB script."
  #~(let* ((glycerin (lambda (l r) (if (pair? l) (append l r) (cons l r))))
           (isopropyl (lambda (c) (case c ((#\\ #\$ #\") '(#\\ ,c)) (else c)))))
      (use-modules (srfi srfi-1))
      (list->string (fold-right glycerin '()
                      (map isopropyl (string->list #$str))))))



(define (grub-format type 32?)
  (string-append
    (cond ((string-prefix? "pc" type) "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))))))
    "-" type))



(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* (search/menu-entry device file var #:optional (port #f))
  "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."
  (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? idfk) ; calling idfk uuid here errors for some reason
     #~(format #$port "search.fs_uuid ~a ~a~%" #$(uuid->string device) #$var))
    ((? file-system-label? label)
     #~(format #$port "search.fs_label \"~a\" ~a~%"
               #$(sanitize (file-system-label->string label)) #$var))
    ((? (lambda (device)
          (and (string? device) (string-contains device ":/"))) nfs-uri)
     ;; 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 a 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 #$port "set ~a=tftp~%" #$var))
    ((or #f (? string?))
     #~(format #$port "search.file \"~a\" ~a~%" #$(sanitize file) #$var))))



\f
;;;
;;; 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))))



\f
;;;
;;; 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" <>)))



;; TODO: 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))
         (bios? (string-prefix? format "pc"))
         (efi? (string=? format "efi"))
         (32? (bootloader-configuration-32bit? bootloader-config))
         (cfg (core.cfg targets store-crypto-devices)))
    (and cfg
      (and=>
        (with-targets targets
          (('install => (fs :fs))
           (let ((tftp? (or (string=? fs "tftp") (string=? fs "nfs"))))
             (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" #$(string-append (grub-format format 32?)
                                    (if (and bios? tftp?) "-pxe" ""))
                     "--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 '()))))))))))))
        (cut computed-file "core.img" <>
             #:options '(#:local-build? #t #:substitutable? #f))))))



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

(define (menu-entry->gexp store extra-initrd port)
  (lambda (entry)
    (match-record entry <menu-entry>
      (label device linux linux-arguments initrd
       multiboot-kernel multiboot-arguments multiboot-modules chain-loader)
      (let ((norm (compose sanitize (cut normalize-file entry <>))))
        #~(begin
            (format #$port "menuentry ~s {~%  " #$label)
            #$(search/menu-entry
                device (or linux multiboot-kernel chain-loader) "boot" port)
            #$@(cond
                 (linux
                   (list #~(format #$port "  linux \"($boot)~a\" ~a~%"
                                   #$(norm linux)
                                   ;; grub passes rest of the line _verbatim_
                                   (string-join (list #$@linux-arguments)))
                         #~(format #$port "  initrd ~a \"($boot)~a\"~%"
                             (if #$extra-initrd (string-append "($boot)\""
                                                  (norm #$extra-initrd) "\"")
                                 "")
                             #$(norm initrd))))
                 ;; previously, this provided a (wrong) root= argument. just
                 ;; don't bother anymore. better less info than wrong info
                 (multiboot-kernel
                   (cons #~(format #$port "  multiboot \"($boot)~a\" ~a~%"
                                   #$(norm multiboot-kernel)
                                   (string-join (list #$@multiboot-arguments)))
                     (map (lambda (mod) #~(format port "  module \"($boot)~a\"~%"
                                                  #$(norm mod)))
                          multiboot-modules)))
                 (chain-loader
                   (list #~(format #$port "  chainloader \"~a\"~%"
                                   #$(norm chain-loader)))))
            (format #$port "}~%"))))))



(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. Expects locales, keymap,
and theme image at LOCALES-TARG, KEYMAP-TARG, and IMAGE-TARG, respectively."
  (match-record bootloader-config <bootloader-configuration>
    ;; can't match keyboard-layout here cause it's bound to its struct
    (targets menu-entries default-entry timeout extra-initrd
     theme terminal-outputs terminal-inputs serial-unit serial-speed)
    (let* ((entry->gexp (menu-entry->gexp store-directory-prefix
                                          extra-initrd #~port))
           (terms->str (compose string-join (cut map symbol->string <>)))
           (colors->str (lambda (c) (format #f "~a/~a" (assoc-ref c 'fg)
                                                       (assoc-ref c 'bg))))
           (outputs (or terminal-outputs '(gfxterm))) ; set default outs
           (inputs (or terminal-inputs '())) ; set default ins
           (theme (or theme (grub-theme))))
      (and=>
        (with-targets targets
          (('install => (install :devpath))
           #~(call-with-output-file #$output
               (lambda (port)
                 ;; preamble
                 (format port "\
# This file was generated from your Guix configuration. Any changes
# will be lost upon reconfiguration~%")
                 #$@(filter ->bool
                      (list
                 ;; menu settings
                        (and default-entry
                          #~(format port "set default=~a~%" #$default-entry))
                        (and timeout
                          #~(format port "set timeout=~a~%" #$timeout))
                 ;; gfxterm setup
                        (and (memq 'gfxterm outputs)
                          #~(format port "\
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 port "serial --unit=~a --speed=~a~%"
                              ;; documented defaults are unit 0 at 9600 baud.
                              #$(number->string (or serial-unit 0))
                              #$(number->string (or serial-speed 9600))))
                        (and (pair? outputs)
                          #~(format port "terminal_output ~a~%"
                                    #$(terms->str outputs)))
                        (and (pair? inputs)
                          #~(format port "terminal_input ~a~%"
                                    #$(terms->str inputs)))
                 ;; locale
                        (and locale
                          #~(format port "\
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 port "\
insmod keylayouts
keymap \"($root)~a/keymap~%\""      #$(sanitize install)))
                 ;; theme
                        (match-record theme <grub-theme>
                          (image color-normal color-highlight)
                          (and image
                            #~(format port "\
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))))))
                 ;; menu entries
                 #$(entry->gexp
                     (boot-alternative->menu-entry current-boot-alternative))
                 #$@(map entry->gexp menu-entries)
                 #$@(if (pair? old-boot-alternatives)
                      (append (list #~(format port "submenu ~s {~%"
                                        "GNU system, old configurations..."))
                              (map (compose entry->gexp
                                            boot-alternative->menu-entry)
                                   old-boot-alternatives)
                              (list #~(format port "}~%"))) '())
                 (format port "
if [ \"${grub_platform}\" == efi ]; then
  menuentry \"Firmware setup\" {
    fwsetup
  }
fi~%")))))
        (cut computed-file "grub.cfg" <>
             ;; Since this file is rather unique, there's no point in trying to
             ;; substitute it.
             #:options '(#:local-build? #t #:substitutable? #f))))))



(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 what should go in GRUB's prefix, including fonts, modules,
locales, keymap, theme image, and grub.cfg."
  (match-record bootloader-config <bootloader-configuration>
    ;; can't match for keyboard-layout: identifier bound in this scope
    (targets theme)
    (let* ((theme (or theme (grub-theme)))
           (keyboard-layout (bootloader-configuration-keyboard-layout
                              bootloader-config))
           (lang (and=> locale (compose locale-definition-source
                                        locale-name->definition)))
           (lc-mesg (and=> lang (cut file-append grub "/share/locale" <>
                                                 "/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
              (when (and=> #$lc-mesg file-exists?)
                (mkdir "locales")
                (symlink #$lc-mesg (string-append "locales/" #$lang ".mo")))
              ;; keymap
              #$@(filter ->bool
                   (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)))))



\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"))))))



\f
;;;
;;; 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)))



\f
;;;
;;; deprecated shit!
;;; 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?)
  (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))))