guix-dotfiles/modules/ryan-components/uki.scm

;; Taken from https://paste.sr.ht/~hako/62bb15503290273e869520e12466718ebb82e000
;; Based off various things related to https://issues.guix.gnu.org/68524

(define-module (ryan-components uki)
  #:use-module (gnu bootloader)
  #:use-module (gnu packages bootloaders)
  #:use-module (gnu packages linux)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:export (uefi-uki-bootloader
            uefi-uki-signed-bootloader))

(define vendor "Guix")
(define script-path "/boot/install-uki.scm")

(define* (uefi-uki-configuration-file #:optional cert privkey)
  (lambda* (config entries #:key (old-entries '()) #:allow-other-keys)

    (define all-entries
      (append entries old-entries))

    (define (menu-entry->ukify-args entry)
      (let* ((label     (menu-entry-label entry))
             (linux     (menu-entry-linux entry))
             (initrd    (menu-entry-initrd entry))
             (arguments (menu-entry-linux-arguments entry))
             (boot (bootloader-configuration-bootloader config))
             (stub (bootloader-package boot)))
        #~(list "--os-release" #$label
                "--linux" #$linux
                "--initrd" #$initrd
                "--cmdline" (string-join (list #$@arguments))
                "--stub" #$(file-append stub "/libexec/" (systemd-stub-name))
                #$@(if cert #~("--secureboot-certificate" #$cert) '())
                #$@(if privkey #~("--secureboot-private-key" #$privkey) '()))))

    (define (enumerate-uki-filenames entries)
      (map (lambda (n)
             (string-append (number->string n) ".efi"))
           (iota (length entries))))

    (program-file
     "install-uki"
     (with-imported-modules (source-module-closure
                             '((guix build syscalls)
                               (guix build utils)
                               (guix diagnostics)
                               (guix i18n)))
       #~(begin
           (use-modules (guix build syscalls)
                        (guix build utils)
                        (guix diagnostics)
                        (guix i18n)
                        (ice-9 string-fun)
                        (rnrs io ports)
                        (srfi srfi-1))
           (let* ((target (second (command-line)))
                  (vendor-directory (string-append target "/EFI/" #$vendor))
                  (schema (string-append vendor-directory "/boot.mgr"))
                  (efibootmgr #$(file-append efibootmgr "/sbin/efibootmgr"))
                  (ukify #$(file-append ukify "/bin/ukify")))
             (define (uki-install-path name)
               (string-append vendor-directory "/" name))

             (define (uki-efi-path name)
               (string-replace-substring
                (string-drop (uki-install-path name) (string-length target))
                "/"
                "\\"))

             (define target/trimmed
               (let* ((not-slash (char-set-complement (char-set #\/)))
                      (components (string-tokenize target not-slash)))
                 (string-join components "/" 'prefix)))

             (define disk
               (let ((target-mount
                      (find (lambda (mount)
                              (string=? (mount-point mount) target/trimmed))
                            (mounts))))
                 (if target-mount
                     (mount-source target-mount)
                     (leave (G_ "target '~a' not mounted!~%") target/trimmed))))

             ;; Delete all boot entries and files we control.
             (when (file-exists? schema)
              (call-with-input-file schema
                (lambda (port)
                  (for-each (lambda (line)
                              (unless (string-null? line)
                                (false-if-exception
                                 (invoke/quiet
                                  efibootmgr
                                  "--delete-bootnum"
                                  "--label" line))))
                            (string-split (get-string-all port) #\newline)))))
             (when (file-exists? vendor-directory)
               (delete-file-recursively vendor-directory))
             (mkdir-p vendor-directory)

             (define (install-uki port)
               (lambda (args label name boot?)
                 "Install NAME, an unified kernel image to be built with ARGS,
to vendor-directory, add it to UEFI boot entries with LABEL, and append LABEL to
PORT.  If BOOT? is #t, also add the created boot entry to boot order."
                 (define image
                   (uki-install-path name))

                 (define (out-of-space-handler . _)
                   (when (file-exists? image)
                     (delete-file image))
                   (unless (file-exists? (uki-install-path "0.efi"))
                     (leave
                      (G_ "no bootloader installed due to insuffcient space \
either in '~a' or UEFI NVRAM.  Please DO NOT turn off your computer until a \
bootloader is properly installed.~%")
                      target/trimmed))
                   (exit))

                 (with-exception-handler out-of-space-handler
                   (lambda ()
                     (let ((minbytes (* 2 (stat:size (stat #$script-path)))))
                       (apply invoke/quiet
                              ukify
                              "build"
                              "--output" image
                              args)
                       ;; Although ‘install-uki.scm’ may not reside on the EFI
                       ;; system partition, this test can still be utilized to
                       ;; ensure there's space left for writing to the schema
                       ;; file.
                       (when (< (free-disk-space vendor-directory) minbytes)
                         (raise-exception 'insuffcient-disk-space))
                       ;; Fails when no space left in NVRAM.
                       (invoke/quiet efibootmgr
                                     (if boot? "--create" "--create-only")
                                     "--label" label
                                     "--disk" disk
                                     "--loader" (uki-efi-path name))
                       ;; This part is harder to discard, so put it to the last
                       ;; where all errors are handled.
                       (put-string port label)
                       (put-char port #\newline))))))

             (call-with-output-file schema
               (lambda (port)
                 (for-each
                  (install-uki port)
                  (list #$@(map-in-order menu-entry->ukify-args all-entries))
                  '#$(map-in-order menu-entry-label all-entries)
                  '#$(enumerate-uki-filenames all-entries)
                  '#$(append
                      (map (const #t) entries)
                      (map (const #f) old-entries)))))))))))

(define install-uefi-uki
  #~(lambda (bootloader target mount-point)
      (invoke (string-append mount-point #$script-path)
              (string-append mount-point target))))

;; ‘configuration-file’ here is actually an activation script to be invoked by
;; ‘installer’.
;; FIXME: Not expected by ‘reinstall-bootloader’ in (guix scripts system).
(define uefi-uki-bootloader
  (bootloader
   (name 'uefi-uki)
   (package systemd-stub)
   (installer install-uefi-uki)
   (disk-image-installer #f)
   (configuration-file script-path)
   (configuration-file-generator (uefi-uki-configuration-file))))

;; FIXME: Breaks ‘reinstall-bootloader’.
;; ‘cert’ and ‘privkey’ are not provided to boot parameters.
(define (uefi-uki-signed-bootloader cert privkey)
  (bootloader
   (inherit uefi-uki-bootloader)
   (name 'uefi-uki-signed)
   (configuration-file-generator (uefi-uki-configuration-file cert privkey))))