guix system only recognizes the legitimacy of gnu/bootloader

1 files changed, 126 insertions, 0 deletions

diff --git a/gnu/bootloader/grub-copy.scm b/gnu/bootloader/grub-copy.scm
new file mode 100644
index 0000000..6f230bb
--- /dev/null
+++ b/gnu/bootloader/grub-copy.scm
@@ -0,0 +1,126 @@
+(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)
+                     (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 (@@ (gnu bootloader grub) install-grub-efi)))
+   (configuration-file-generator
+    grub-copy-configuration-file)))