gnu: bootloader: Support chain loading to an EFI bootloader.

* gnu/bootloader.scm (efi-bootloader-profile): New function.
(efi-bootloader-chain): New function.

Signed-off-by: Danny Milosavljevic <dannym@scratchpost.org>

gnu/bootloader.scm

@@ -22,6 +22,8 @@
 
 (define-module (gnu bootloader)
   #:use-module (guix discovery)
+  #:use-module (guix gexp)
+  #:use-module (guix profiles)
   #:use-module (guix records)
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
@@ -66,7 +68,9 @@
             bootloader-configuration-additional-configuration
 
             %bootloaders
-            lookup-bootloader-by-name))
+            lookup-bootloader-by-name
+
+            efi-bootloader-chain))
 
 
 ;;;
@@ -227,3 +231,122 @@ record."
               (eq? name (bootloader-name bootloader)))
             (force %bootloaders))
       (leave (G_ "~a: no such bootloader~%") name)))
+
+(define (efi-bootloader-profile files bootloader-package hook)
+  "Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
+links to additional FILES from the store.  This collection is meant to be used
+by the bootloader installer.
+
+FILES is a list of file or directory names from the store, which will be
+symlinked into the collection/ directory.  If a directory name ends with '/',
+then the directory content instead of the directory itself will be symlinked
+into the collection/ directory.
+
+FILES may contain file like objects produced by functions like plain-file,
+local-file, etc., or package contents produced with file-append."
+  (define (bootloader-collection manifest)
+    (define build
+        (with-imported-modules '((guix build utils)
+                                 (ice-9 ftw)
+                                 (srfi srfi-1)
+                                 (srfi srfi-26))
+          #~(begin
+            (use-modules ((guix build utils)
+                          #:select (mkdir-p strip-store-file-name))
+                         ((ice-9 ftw)
+                          #:select (scandir))
+                         ((srfi srfi-1)
+                          #:select (append-map every remove))
+                         ((srfi srfi-26)
+                          #:select (cut)))
+            (define (symlink-to file directory transform)
+              "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
+              (symlink file (string-append directory "/" (transform file))))
+            (define (directory-content directory)
+              "Creates a list of absolute path names inside DIRECTORY."
+              (map (lambda (name)
+                     (string-append directory name))
+                   (or (scandir directory (lambda (name)
+                                            (not (member name '("." "..")))))
+                       '())))
+            (define name-ends-with-/? (cut string-suffix? "/" <>))
+            (define (name-is-store-entry? name)
+              "Return #t if NAME is a direct store entry and nothing inside."
+              (not (string-index (strip-store-file-name name) #\/)))
+            (let* ((collection (string-append #$output "/collection"))
+                   (files '#$files)
+                   (directories (filter name-ends-with-/? files))
+                   (names-from-directories
+                    (append-map (lambda (directory)
+                                  (directory-content directory))
+                                directories))
+                   (names (append names-from-directories
+                                  (remove name-ends-with-/? files))))
+              (mkdir-p collection)
+              (if (every file-exists? names)
+                  (begin
+                    (for-each (lambda (name)
+                               (symlink-to name collection
+                                            (if (name-is-store-entry? name)
+                                                strip-store-file-name
+                                                basename)))
+                              names)
+                    #t)
+                  #f)))))
+
+    (gexp->derivation "bootloader-collection"
+                      build
+                      #:local-build? #t
+                      #:substitutable? #f
+                      #:properties
+                      `((type . profile-hook)
+                        (hook . bootloader-collection))))
+
+  (profile (content (packages->manifest (list bootloader-package)))
+           (name "efi-bootloader-profile")
+           (hooks (append (list bootloader-collection)
+                          (or hook '())))
+           (locales? #f)
+           (allow-collisions? #f)
+           (relative-symlinks? #f)))
+
+(define* (efi-bootloader-chain files
+                               final-bootloader
+                               #:key
+                               hook
+                               installer)
+  "Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
+certain directories and files from the store given in the list of FILES.
+
+FILES may contain file like objects produced by functions like plain-file,
+local-file, etc., or package contents produced with file-append.  They will be
+collected inside a directory collection/ inside a generated bootloader profile,
+which will be passed to the INSTALLER.
+
+If a directory name in FILES ends with '/', then the directory content instead
+of the directory itself will be symlinked into the collection/ directory.
+
+The PROFILE-HOOK function can be used to further modify the bootloader profile.
+
+If the INSTALLER argument is used, then this function will be called to install
+the bootloader.  Otherwise the installer of the FINAL-BOOTLOADER will be called.
+
+Independent of the INSTALLER argument, all files in the mentioned collection/
+directory of the bootloader profile will be copied into the bootloader target
+directory after the actual bootloader installer has been called."
+  (let* ((final-installer (or installer
+                              (bootloader-installer final-bootloader)))
+         (profile (efi-bootloader-profile files
+                                          (bootloader-package final-bootloader)
+                                          hook)))
+    (bootloader
+     (inherit final-bootloader)
+     (package profile)
+     (installer
+      #~(lambda (bootloader target mount-point)
+          (#$final-installer bootloader target mount-point)
+          (copy-recursively
+           (string-append bootloader "/collection")
+           (string-append mount-point target)
+           #:follow-symlinks? #t
+           #:log (%make-void-port "w")))))))