;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Leo Famulari ;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2019, 2020, 2023 Janneke Nieuwenhuizen ;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2020 Stefan ;;; Copyright © 2022 Karl Hallsby ;;; Copyright © 2022 Denis 'GNUtoo' Carikli ;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz> ;;; Copyright © 2024 Lilah Tascheter ;;; ;;; 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 . (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)) ;;; ;;; 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 . ((? 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)))) ;;; ;;; Theming. ;;; (define-record-type* ;; 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 (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)))) ;;; ;;; 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)))))) ;;; ;;; 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 (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 ;; 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 (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 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 ;; 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))))) ;;; ;;; 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 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))))