127 lines
4.7 KiB
Scheme
127 lines
4.7 KiB
Scheme
(define-module (gnu bootloader grub-copy)
|
|
#:use-module (guix gexp)
|
|
#:use-module (guix packages)
|
|
#:use-module (guix utils)
|
|
#:use-module (gnu bootloader)
|
|
#:use-module (gnu bootloader grub)
|
|
#:use-module (gnu packages bootloaders)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (ice-9 optargs)
|
|
|
|
#:export (grub-copy-bootloader
|
|
grub-efi-copy-bootloader))
|
|
|
|
;; The current grub-bootloader implementation demonstrates a remarkable
|
|
;; hostility to disk encryption, LVM, and PyGrub.
|
|
|
|
;; Thanks to Rutherther (https://github.com/Rutherther/guix-config/blob/main/modules/ruther/bootloader/grub.scm)
|
|
;; for most of the implementation.
|
|
|
|
(define* (grub-copy-configuration-file config entries . args)
|
|
(let-keywords
|
|
args #t ((locale #f)
|
|
(system (%current-system))
|
|
(old-entries '()))
|
|
|
|
(let* ((args (append args '(#:store-crypto-devices ())))
|
|
(grub (bootloader-package (bootloader-configuration-bootloader config)))
|
|
(image ((@@ (gnu bootloader grub) grub-background-image) config))
|
|
(layout (bootloader-configuration-keyboard-layout config))
|
|
(locales (and locale ((@@ (gnu bootloader grub) grub-locale-directory) grub)))
|
|
(keymap* (and layout ((@@ (gnu bootloader grub) keyboard-layout-file) layout #:grub grub)))
|
|
|
|
(menu-entry-needed-files
|
|
(lambda (menu-entry)
|
|
#~(list
|
|
#$(menu-entry-linux menu-entry)
|
|
#$(menu-entry-initrd menu-entry))))
|
|
|
|
(needed-files-gexps
|
|
#~(delete-duplicates
|
|
(cons*
|
|
#$image
|
|
#$locales
|
|
#$keymap*
|
|
(apply append (list #$@(map menu-entry-needed-files (append entries old-entries)))))))
|
|
|
|
(original-grub-cfg
|
|
(apply (@@ (gnu bootloader grub) grub-configuration-file) config entries args))
|
|
|
|
(builder
|
|
#~(call-with-output-file #$output
|
|
(lambda (port)
|
|
(use-modules (ice-9 textual-ports)
|
|
;; delete-duplicates in needed gexps
|
|
(srfi srfi-1))
|
|
|
|
;; This will probably never happen in the history of Guix.
|
|
(display "insmod lvm\n" port)
|
|
|
|
(display
|
|
(string-join
|
|
(filter
|
|
;; Let's get straight to the point.
|
|
(lambda (line)
|
|
(not (string-prefix? "search" (string-trim line))))
|
|
(string-split
|
|
(call-with-input-file #$original-grub-cfg get-string-all) #\newline))
|
|
"\n") port)
|
|
|
|
(display "\n\n" port)
|
|
|
|
(for-each
|
|
(lambda (file)
|
|
(if file
|
|
(display (string-append "# NEEDED FILE: " file "\n") port)))
|
|
#$needed-files-gexps)))))
|
|
|
|
(computed-file "grub.cfg" builder
|
|
#:options '(#:local-build? #t
|
|
#:substitutable? #f)))))
|
|
|
|
(define (install-grub-copy grub-installer)
|
|
#~(lambda (bootloader device mount-point)
|
|
(use-modules (guix build utils)
|
|
(ice-9 textual-ports)
|
|
(srfi srfi-1))
|
|
|
|
(let ((install-dir (string-append mount-point "/boot"))
|
|
(grub-cfg-lines (string-split
|
|
(call-with-input-file
|
|
(string-append mount-point #$(@@ (gnu bootloader grub) grub-cfg))
|
|
get-string-all) #\newline)))
|
|
|
|
(if (directory-exists? (string-append install-dir "/gnu"))
|
|
(delete-file-recursively (string-append install-dir "/gnu")))
|
|
|
|
(for-each
|
|
(lambda (file-line)
|
|
(let* ((source-file (string-trim-both (substring file-line (string-length "# NEEDED FILE: "))))
|
|
(dest-file (string-append install-dir source-file)))
|
|
(mkdir-p (dirname dest-file))
|
|
(copy-recursively source-file dest-file)))
|
|
(delete-duplicates (filter
|
|
(lambda (line) (string-prefix? "# NEEDED FILE: " line))
|
|
grub-cfg-lines))))
|
|
(#$grub-installer bootloader device mount-point)))
|
|
|
|
|
|
;; Maybe we could abstract grub-copy ?
|
|
|
|
(define grub-copy-bootloader
|
|
(bootloader
|
|
(inherit grub-bootloader)
|
|
(name 'grub-copy)
|
|
(installer
|
|
(install-grub-copy (@@ (gnu bootloader grub) install-grub)))
|
|
(configuration-file-generator
|
|
grub-copy-configuration-file)))
|
|
|
|
(define grub-efi-copy-bootloader
|
|
(bootloader
|
|
(inherit grub-efi-bootloader)
|
|
(name 'grub-efi-copy)
|
|
(installer
|
|
(install-grub-copy (make-grub-efi-installer)))
|
|
(configuration-file-generator
|
|
grub-copy-configuration-file)))
|