Subject: [PATCH] gnu: grub: Support for chain loading.

From: Stefan Kuhr <[email-masked]>
Date: Sun, 3 May 2020 23:29:23 +0200

* gnu/bootloaders/grub.scm (grub-efi-net-bootloader-chain): New efi bootloader
for chaining with other bootloaders.
* guix/packages.scm (package-collection): New function to build a union of
packages with a collection of certain files.

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

(operating-system
  (bootloader
    (grub-efi-net-bootloader-chain
      (list u-boot
            firmware)
      '("libexec/u-boot.bin"
        "firmware/")
      (list (plain-file "config.txt"
                        "kernel=u-boot.bin"))
      #:target "/boot-tftp"
      #:efi-subdir "efi/boot")
    (target "/boot-tftp"))
   ...)
---
 gnu/bootloader/grub.scm |  36 +++++++++++++
 guix/packages.scm       | 114 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 150 insertions(+)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 9ca4f016f6..67736724a7 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -22,6 +22,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu bootloader grub)
+  #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module ((guix utils) #:select (%current-system %current-target-system))
   #:use-module (guix gexp)
@@ -54,6 +55,7 @@
             grub-bootloader
             grub-efi-bootloader
             grub-efi-net-bootloader
+            grub-efi-net-bootloader-chain
             grub-mkrescue-bootloader
 
             grub-configuration))
@@ -525,6 +527,40 @@ TARGET for the system whose root is mounted at MOUNT-POINT."
      (installer (install-grub-efi-net efi-subdir))
      (configuration-file (string-append target "/" efi-subdir "/grub.cfg")))))
 
+(define* (grub-efi-net-bootloader-chain bootloader-packages
+                                        bootloader-package-contents
+                                        #:optional (files '())
+                                        #:key
+                                        (target #f)
+                                        (efi-subdir #f))
+  "Defines a (grub-efi-net-bootloader) with ADDITIONAL-BOOTLOADER-FILES from
+ADDITIONAL-BOOTLOADER-PACKAGES and ADDITIONAL-FILES, all collected as a
+(package-collection), whose files inside the \"collection\" folder get
+copied into TARGET along with the the bootloader installation in EFI-SUBDIR."
+  (let* ((base-bootloader (grub-efi-net-bootloader #:target target
+                                                   #:efi-subdir efi-subdir))
+         (base-installer (bootloader-installer base-bootloader))
+         (packages (package-collection
+                    (cons (bootloader-package base-bootloader)
+                          bootloader-packages)
+                    bootloader-package-contents
+                    files)))
+    (bootloader
+     (inherit base-bootloader)
+     (package packages)
+     (installer
+      #~(lambda (bootloader target mount-point)
+          (#$base-installer bootloader target mount-point)
+          (copy-recursively
+           (string-append bootloader "/collection")
+           (string-join (delete ""
+                                (string-split
+                                 (string-append mount-point "/" target)
+                                 #\/))
+                        "/"
+                        'prefix)
+           #:follow-symlinks? #t))))))
+
 (define* grub-mkrescue-bootloader
   (bootloader
    (inherit grub-efi-bootloader)
diff --git a/guix/packages.scm b/guix/packages.scm
index 2fa4fd05d7..987c3b80ac 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -32,6 +32,7 @@
   #:use-module (guix derivations)
   #:use-module (guix memoization)
   #:use-module (guix build-system)
+  #:use-module (guix build-system trivial)
   #:use-module (guix search-paths)
   #:use-module (guix sets)
   #:use-module (ice-9 match)
@@ -114,6 +115,7 @@
             package-with-patches
             package-with-extra-patches
             package/inherit
+            package-collection
 
             transitive-input-references
 
@@ -944,6 +946,118 @@ OVERRIDES."
       overrides ...
       (replacement (and=> (package-replacement p) loop)))))
 
+(define* (package-collection packages package-contents #:optional (files '()))
+  "Defines a package union from PACKAGES and additional FILES.  Its output
+\":out\" has a \"collection\" directory with links to selected PACKAGE-CONTENTS
+and FILES. The output \":collection\" of the package links to that directory."
+  (let ((package-names (map (lambda (package)
+                              (package-name package))
+                            packages))
+        (link-machine '(lambda (file directory targetname)
+                         (symlink file
+                                  (string-append directory
+                                                 "/"
+                                                 (targetname file))))))
+    (package
+     (name (string-join (append '("package-collection") package-names) "-"))
+     ;; We copy the version of the first package.
+     (version (package-version (first packages)))
+     ;; FILES are expected to be a list of gexps like 'plain-file'. As gexps
+     ;; can't (yet) be used in the arguments of a package we convert FILES into
+     ;; the source of this package.
+     (source (computed-file
+              "computed-files"
+              (with-imported-modules
+               '((guix build utils))
+               #~(begin
+                   (use-modules (guix build utils))
+                   (define (targetname file)
+                     ;; A plain-file inside the store has a name like
+                     ;; gnu/store/9x6y7j75qy9z6iv21byrbyj4yy8hb490-config.txt.
+                     ;; We take its basename and drop the hash from it.
+                     ;; Therefore it expects the first '-' at index 32.
+                     ;; Otherwise the basename of file is returned
+                     (let ((name (basename file)))
+                       (if (and (> (string-length name) 33)
+                                (= (string-index name #\- 0 33) 32))
+                           (substring name 33)
+                           (name))))
+                   (mkdir-p #$output)
+                   (for-each (lambda (file)
+                               (#$link-machine file #$output targetname))
+                             '#$files)))))
+     (build-system trivial-build-system)
+     (arguments
+      `(#:modules
+        ((guix build union)
+         (guix build utils))
+        #:builder
+        (begin
+          (use-modules (guix build union)
+                       (guix build utils)
+                       (ice-9 ftw)
+                       (ice-9 match)
+                       (srfi srfi-1))
+          ;; Make a union of all packages as :out.
+          (match %build-inputs
+            (((names . directories) ...)
+             (union-build %output directories)))
+          (let* ((directory-content
+                  ;; Creates a list of absolute path names inside DIR.
+                  (lambda (dir)
+                    (map (lambda (name)
+                           (string-append dir name))
+                         (scandir dir (lambda (name)
+                                        (not (member name '("." ".."))))))))
+                 (select-names
+                  ;; Select names ending with (filter) or without "/" (remove)
+                  (lambda (select names)
+                    (select (lambda (name)
+                              (string=? (string-take-right name 1) "/"))
+                      names)))
+                 (content
+                  ;; The selected package content as a list of absolute paths.
+                  (map (lambda (name)
+                         (string-append %output "/" name))
+                       ',package-contents))
+                 (directory-names
+                  (append (select-names filter content)
+                          (list (string-append
+                                 (assoc-ref %build-inputs "source")
+                                 "/"))))
+                 (names-from-directories
+                  (fold (lambda (directory previous)
+                          (append (directory-content directory) previous))
+                        '()
+                        directory-names))
+                 (names-from-content (select-names remove content))
+                 (names (append names-from-directories names-from-content))
+                 (collection-directory (string-append %output "/collection"))
+                 (collection (assoc-ref %outputs "collection")))
+            ;; Collect links to package-contents and file.
+            (mkdir-p collection-directory)
+            (for-each (lambda (name)
+                        (,link-machine name collection-directory basename))
+                      names)
+            (symlink collection-directory collection)))))
+     (inputs (fold-right
+              (lambda (package previous)
+                (cons (list (package-name package) package) previous))
+              '()
+              packages))
+     (outputs '("out" "collection"))
+     (synopsis "Package union with a collection of package contents and files")
+     (description
+      (string-append "A package collection is useful when bootloaders need to "
+                     "be chained and the bootloader-installer needs to install "
+                     "selected parts of them.  This collection includes: "
+                     (string-join package-names ", ") "."))
+     (license
+      (append (map (lambda (package)
+                     (package-license package))
+                   packages)))
+     (home-page ""))))
+
 ^L
 ;;;
 ;;; Package derivations.
-- 
2.26.0