(define-module (sigils bootloader grub)
  #: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)))