ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: bootloader: grub: Define grub-menu-entry configuration.

Browse source 
* gnu/bootloader/grub.scm (serialize-grub-theme, serialize-string,
normalize-file, serialize-file-like, string-list?, file-like-list?,
serialize-string-list, serialize-file-like-list, grub-device?,
serialize-grub-device, serialize-linux-directive,
serialize-multiboot-directive, directive-or-file-like?,
serialize-directive-or-file-like, menu-entry->grub-menu-entry,
serialize-grub-menu-entry): Add procedures.
(make-grub.cfg): Use really-mixed-text-file to reduce indentation.
(%boot): Add variable.  Define maybe-string.
(linux-directive, multiboot-directive, grub-menu-entry): Add records.

Change-Id: Ie1e56e04d5c8ae7ab07741ef7b6909f306398f28
This commit is contained in:
Herman Rimm 2024-09-21 20:17:22 +02:00 committed by Ryan Schanzenbacher
parent fd4e074d61
commit 38cb6dee66
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
1 changed files with 277 additions and 167 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

444
gnu/bootloader/grub.scm
View file

@ -34,6 +34,7 @@ (define-module (gnu bootloader grub)
#:use-module (gnu packages bootloaders) #:use-module (gnu packages bootloaders)
#:autoload (gnu packages gtk) (guile-cairo guile-rsvg) #:autoload (gnu packages gtk) (guile-cairo guile-rsvg)
#:autoload (gnu packages xorg) (xkeyboard-config) #:autoload (gnu packages xorg) (xkeyboard-config)
#:use-module (gnu services configuration)
#:use-module (gnu system boot) #:use-module (gnu system boot)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:use-module (gnu system keyboard) #:use-module (gnu system keyboard)
@ -83,6 +84,13 @@ (define (sanitize str)
(list->string (fold-right glycerin '() (list->string (fold-right glycerin '()
(map isopropyl (string->list #$str)))))) (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)) (define* (search/target type targets var #:optional (port #f))
"Returns a gexp of a GRUB search command for target TYPE, storing the "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 result in VAR. Optionally outputs to the gexp PORT instead of returning
@ -97,43 +105,6 @@ (define (form name val)
(label (form "fs_label" label)) (label (form "fs_label" label))
(else (form "file" (sanitize path))))))) (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))))
(define (when-list . xs) (filter identity xs)) (define (when-list . xs) (filter identity xs))
@ -173,6 +144,24 @@ (define (grub-theme-png theme)
#:height #$height))))))) #:height #$height)))))))
(_ image)))) (_ 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. ;;; Core config.
@ -288,140 +277,263 @@ (define* (core.img grub format #:key bootloader-config store-crypto-devices
;;; This is what does the heavy lifting after core.img finds it. ;;; This is what does the heavy lifting after core.img finds it.
;;; ;;;
;; TODO: use define-configuration. (define (serialize-string value)
(define (menu-entry->gexp entry extra-initrd port) (match value
(match-menu-entry ((key value) #~(string-append #$key "=" #$value))
entry ((? string?) #~#$value)
(label device linux linux-arguments initrd multiboot-kernel (x x)))
multiboot-arguments multiboot-modules chain-loader)
(let ((normalize-file (define-maybe string)
(compose sanitize (cut normalize-file entry <>))))
#~(begin (define (serialize-file-like value)
(format #$port "menuentry ~s {~% " #$label) #~(format #f " module ~s~%" #$(normalize-file value)))
#$(search/menu-entry
device (or linux multiboot-kernel chain-loader) "boot" port) (define (string-list? x)
#$@(cond (and (list? x)
(linux (and-map (match-lambda
(list #~(format (((? string?) (? file-like?)) #t)
#$port " linux \"($boot)~a\" ~a~%" ;; TODO: Remove gexps from linux-arguments.
#$(normalize-file linux) (x (or (string? x) (gexp? x))))
;; GRUB passes rest of the line _verbatim_. x)))
(string-join (list #$@linux-arguments)))
#~(format #$port " initrd ~a \"($boot)~a\"~%" (define (file-like-list? x)
(if #$extra-initrd (and (list? x) (and-map file-like? x)))
(string-append "($boot)\""
(normalize-file (define (serialize-string-list value)
#$extra-initrd) #~(string-join (list #$@(map serialize-string value)) " "))
"\"")
"") (define (serialize-file-like-list value)
#$(normalize-file initrd)))) #~(string-concatenate (list #$@(map serialize-file-like value))))
;; Previously, this provided a (wrong) root= argument.
;; Just don't bother anymore; better less info than (define (grub-device? x)
;; wrong info. (or (not x) (string? x) (uuid? x) (file-system-label? x)))
(multiboot-kernel
(cons (define (serialize-grub-device device file)
#~(format #$port " multiboot \"($boot)~a\" ~a~%" "Return the GRUB 'search' command to look for DEVICE, which contains
#$(normalize-file multiboot-kernel) FILE, a gexp. The result is a gexp that can be inserted in the
(string-join (list #$@multiboot-arguments))) grub.cfg-generation code to set the variable VAR. This procedure is
(map (lambda (mod) able to handle DEVICEs unmounted at evaltime."
#~(format port " module \"($boot)~a\"~%" (define (host-prefix? device)
#$(normalize-file mod))) (and (string? device) (string-contains device ":/")))
multiboot-modules))) (match device
(chain-loader ;; Preferably refer to DEVICE by its UUID or label. This is more
(list #~(format #$port " chainloader \"~a\"~%" ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
#$(normalize-file chain-loader))))) ((? uuid?)
(format #$port "}~%"))))) #~(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))
;; TODO: use define-configuration.
(define (make-grub.cfg bootloader-config locale install menu-entries (define (make-grub.cfg bootloader-config locale install menu-entries
old-entries terms->str outputs inputs theme) old-entries gfxterm? outputs inputs theme)
(define (colors->str c) (define (really-mixed-text-file . xs)
(format #f "~a/~a" (assoc-ref c 'fg) (assoc-ref c 'bg))) "Ignores #f arguments and flattens list arguments."
(apply mixed-text-file (flatten (filter identity xs))))
(match-bootloader-configuration (match-bootloader-configuration
bootloader-config bootloader-config
;; XXX: Separate these fields into another record? ;; XXX: Separate these fields into another record?
(default-entry timeout serial-unit serial-speed) (default-entry timeout serial-unit serial-speed)
#~(call-with-output-file #$output (really-mixed-text-file "grub.cfg" "\
(lambda (port)
;; preamble
(format port "\
# This file was generated from your Guix configuration. Any changes # This file was generated from your Guix configuration. Any changes
# will be lost upon reconfiguration~%") # will be lost upon reconfiguration\n"
#$@(when-list ;; menu settings
;; menu settings (format #f "~@[set default=~a~%~]" default-entry)
(and default-entry (format #f "~@[set timeout=~a~%~]" timeout)
#~(format port "set default=~a~%" #$default-entry)) ;; gfxterm setup
(and timeout (and gfxterm?
#~(format port "set timeout=~a~%" #$timeout)) (format #f "\
;; gfxterm setup
(and (memq 'gfxterm outputs)
#~(format
port "\
if loadfont unicode; then if loadfont unicode; then
set gfxmode=~a set gfxmode=~a
insmod all_video insmod all_video
insmod gfxterm insmod gfxterm
fi~%" fi~%"
#$(string-join (grub-theme-gfxmode theme) ";"))) (string-join (grub-theme-gfxmode theme) ";")))
;; io ;; io
(and (or serial-unit serial-speed) (and (or serial-unit serial-speed)
#~(format (format #f "serial~@[ --unit=~d~]~@[ --speed=~d~]~%"
port "serial --unit=~a --speed=~a~%" serial-unit serial-speed))
;; Documented defaults are unit 0 at 9600 baud. (format #f "~@[terminal_output ~a~%~]" outputs)
#$(number->string (or serial-unit 0)) (format #f "~@[terminal_input ~a~%~]" inputs)
#$(number->string (or serial-speed 9600)))) ;; locale
(and (pair? outputs) (and locale
#~(format port "terminal_output ~a~%" #~(format #f "\
#$(terms->str outputs))) set locale_dir=\"($root)~a/locales\"
(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~%" set lang=~a~%"
#$(sanitize install) #$(sanitize install)
#$(locale-definition-source #$(locale-definition-source
(locale-name->definition locale)))) (locale-name->definition locale))))
;; keyboard layout ;; keyboard layout
(and (bootloader-configuration-keyboard-layout (and (bootloader-configuration-keyboard-layout bootloader-config)
bootloader-config) #~(format #f "\
#~(format port "\
insmod keylayouts insmod keylayouts
keymap \"($root)~a/keymap~%\"" keymap \"($root)~a/keymap\"~%"
#$(sanitize install))) #$(sanitize install)))
;; theme (serialize-grub-theme theme install)
(match-record theme <grub-theme> ;; menu entries
(image color-normal color-highlight) menu-entries
(and image (and (pair? old-entries)
#~(format port "\ (cons "submenu \"GNU system, old configurations...\" {\n"
insmod png ;; Do not indent: initrd line is >80 columns anyway.
if background_image \"($root)~a/image.png\"; then (append old-entries (list "}\n"))))
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
#$@menu-entries
#$@(if (pair? old-entries)
(append (list #~(format
port "submenu ~s {~%"
"GNU system, old configurations..."))
old-entries
(list #~(format port "}~%")))
'())
(format port "\
if [ \"${grub_platform}\" == efi ]; then if [ \"${grub_platform}\" == efi ]; then
menuentry \"Firmware setup\" { menuentry \"Firmware setup\" {
fwsetup fwsetup
} }
fi~%"))))) fi\n")))
(define* (grub.cfg #:key bootloader-config (define* (grub.cfg #:key bootloader-config
current-boot-alternative current-boot-alternative
@ -437,28 +549,26 @@ (define* (grub.cfg #:key bootloader-config
(menu-entries targets extra-initrd theme terminal-outputs (menu-entries targets extra-initrd theme terminal-outputs
terminal-inputs) terminal-inputs)
(define (entries->gexp entries) (define (entries->gexp entries)
(map (cut menu-entry->gexp <> extra-initrd #~port) (map (compose serialize-grub-menu-entry
(cut menu-entry->grub-menu-entry <> extra-initrd))
entries)) entries))
(define (terms->str terms)
(and (pair? terms) (format #f "~{~a~^ ~}" terms)))
(let* ((current-entry (boot-alternative->menu-entry (let* ((current-entry (boot-alternative->menu-entry
current-boot-alternative)) current-boot-alternative))
(entries (entries->gexp (cons current-entry menu-entries))) (entries (entries->gexp (cons current-entry menu-entries)))
(old-entries (entries->gexp (map boot-alternative->menu-entry (old-entries (entries->gexp (map boot-alternative->menu-entry
old-boot-alternatives))) old-boot-alternatives)))
(terms->str (compose string-join (cut map symbol->string <>))) (gfxterm? (or (not terminal-outputs)
(memq 'gfxterm terminal-outputs)))
;; Use the values provided, or the defaults otherwise. ;; Use the values provided, or the defaults otherwise.
(outputs (or terminal-outputs '(gfxterm))) (outputs (or (and=> terminal-outputs terms->str) "gfxterm"))
(inputs (or terminal-inputs '())) (inputs (and=> terminal-inputs terms->str))
(theme (or theme (grub-theme)))) (theme (or theme (grub-theme))))
(and=> (with-targets targets
(with-targets targets (('install => (install :devpath))
(('install => (install :devpath)) (make-grub.cfg bootloader-config locale install entries
(make-grub.cfg bootloader-config locale install entries old-entries gfxterm? outputs inputs theme))))))
old-entries terms->str outputs inputs theme)))
(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) (define (keyboard-layout-file layout grub)
"Process the X keyboard layout description LAYOUT, a <keyboard-layout> "Process the X keyboard layout description LAYOUT, a <keyboard-layout>