[bug#41066] [PATCH] gnu: bootloader: Support for chain loading.

[Stefan <stefan-guix@vodafonemail.de>]

* gnu/bootloader.scm (bootloader-profile): New internal function to build a
profile from packages and files with a collection of contents to install.
(bootloader-chain): New function to chain a bootloader with contents of
additional bootloader or other packages and additional files like configuration
files or device-trees.

This allows to chain GRUB with U-Boot, device-tree-files, plain configuration
files, etc. mainly for single-board-computers like this:

(operating-system
  (bootloader
    (bootloader-configurationa
      (bootloader
        (bootloader-chain grub-efi-netboot-bootloader
                          (list u-boot-my-scb
                                firmware)
                          '("libexec/u-boot.bin"
                            "firmware/")
                          (list (plain-file "config.txt"
                                            "kernel=u-boot.bin"))
                          #:installer (install-grub-efi-netboot "efi/boot"))
        (target "/boot"))))
  …)
---
 gnu/bootloader.scm | 143 ++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 142 insertions(+), 1 deletion(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 2eebb8e9d9..e9d80bf45a 100644
--- a/gnu/bootloader.scm
+++ b/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
+
+            bootloader-chain))
 
 ^L
 ;;;
@@ -227,3 +231,140 @@ record."
               (eq? name (bootloader-name bootloader)))
             (force %bootloaders))
       (leave (G_ "~a: no such bootloader~%") name)))
+
+(define (bootloader-profile packages package-contents files)
+  "Creates a profile with PACKAGES and additional FILES.  The new profile will
+contain a directory collection/ with links to selected PACKAGE-CONTENTS and
+FILES.  This collection is meant to be used by the bootloader installer.
+
+PACKAGE-CONTENTS is a list of file or directory names relative to the PACKAGES,
+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 is a list of file like objects produced by functions like plain-file,
+local-file, etc., which will be symlinked into the collection/ directory, too."
+  (define (bootloader-collection manifest)
+    (define build
+        (with-imported-modules '((guix build utils)
+                                 (ice-9 ftw)
+                                 (srfi srfi-1))
+          #~(begin
+            (use-modules ((guix build utils) #:select (mkdir-p))
+                         ((ice-9 ftw) #:select (scandir))
+                         ((srfi srfi-1) #:select (append-map remove)))
+            (define (symlink-to file directory transform-name)
+              "Creates a symlink with transformed name to FILE in DIRECTORY."
+              (when (file-exists? file)
+                    (symlink file
+                             (string-append
+                              directory "/"
+                              (transform-name (basename file))))))
+            (define (remove-hash basename)
+              "Returns the basename of a store entry without the hash."
+              ;; A plain-file inside the store has a name like
+              ;; gnu/store/9x6y7j75qy9z6iv21byrbyj4yy8hb490-config.txt.
+              ;; From its basename we drop the hash.
+              ;; Therefore we expects the first '-' at index 32.
+              ;; Otherwise the basename itself is returned.
+              (if (and (> (string-length basename) 33)
+                       (= (string-index basename #\- 0 33) 32))
+                  (substring basename 33)
+                  (basename)))
+            (define (directory-content directory)
+              "Creates a list of absolute path names inside DIRECTORY."
+              (map (lambda (name)
+                     (string-append directory name))
+                   (sort (or (scandir directory
+                                      (lambda (name)
+                                        (not (member name '("." "..")))))
+                             '())
+                         string<?)))
+            (define (select-names select names)
+              "Set SELECT to 'filter' or 'remove' names ending with '/'."
+              (select (lambda (name)
+                        (string-suffix? "/" name))
+                      names))
+            (define (filter-names-without-slash names)
+              (select-names remove names))
+            (define (filter-names-with-slash names)
+              (select-names filter names))
+            (let* ((collection (string-append #$output "/collection"))
+                   (packages '#$(map (lambda (entry)
+                                       (manifest-entry-item entry))
+                                     (manifest-entries manifest)))
+                   (contents (append-map
+                               (lambda (name)
+                                 (map (lambda (package)
+                                        (string-append package "/" name))
+                                      packages))
+                               '#$package-contents))
+                   (directories (filter-names-with-slash contents))
+                   (names-from-directories
+                    (append-map (lambda (directory)
+                                  (directory-content directory))
+                                directories))
+                   (names (append names-from-directories
+                                  (filter-names-without-slash contents))))
+              (mkdir-p collection)
+              (for-each (lambda (name)
+                          (symlink-to name collection identity))
+                        names)
+              (for-each (lambda (file)
+                          (symlink-to file collection remove-hash))
+                        '#$files))
+            #t)))
+
+    (gexp->derivation "bootloader-collection"
+                      build
+                      #:local-build? #t
+                      #:substitutable? #f
+                      #:properties
+                      `((type . profile-hook)
+                        (hook . bootloader-collection))))
+
+  (profile (content (packages->manifest packages))
+           (name "bootloader-profile")
+           (hooks (list bootloader-collection))
+           (locales? #f)
+           (allow-collisions? #f)
+           (relative-symlinks? #f)))
+
+(define* (bootloader-chain final-bootloader
+                           bootloader-packages
+                           bootloader-package-contents
+                           #:optional (files '())
+                           #:key installer)
+  "Defines a bootloader chain with the FINAL-BOOTLOADER as the final bootloader
+and certain directories and files given in the BOOTLOADER-PACKAGE-CONTENTS list
+relative to list of BOOTLOADER-PACKAGES and additional FILES.
+
+Along with the installation of the FINAL-BOOTLOADER these additional FILES and
+BOOTLOADER-PACKAGE-CONTENTS will be copied into the bootloader target directory.
+
+If a directory name in BOOTLOADER-PACKAGE-CONTENTS ends with '/', then the
+directory content instead of the directory itself will be copied.
+
+FILES is a list of file like objects produced by functions like plain-file,
+local-file, etc.
+
+If the INSTALLER argument is used, then this will be used as the bootloader
+installer.  Otherwise the intaller of the FINAL-BOOTLOADER will be used."
+  (let* ((final-installer (or installer
+                              (bootloader-installer final-bootloader)))
+         (profile (bootloader-profile
+                   (cons (bootloader-package final-bootloader)
+                         bootloader-packages)
+                   bootloader-package-contents
+                   files)))
+    (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")))))))
-- 
2.26.0