GNU bug report logs - #41068
[PATCH] gnu: grub: Support for chain loading.

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 41068 in the body.
You can then email your comments to 41068 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Stefan Kuhr <Stefan_Kuhr <at> arcor.de>
To: guix-patches <at> gnu.org
Subject: [PATCH] gnu: grub: Support for chain loading.
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

Message #8 received at 41068 <at> debbugs.gnu.org (full text, mbox):

From: Stefan <stefan-guix <at> vodafonemail.de>
To: 41068 <at> debbugs.gnu.org
Subject: Re: bug#41068: Acknowledgement ([PATCH] gnu: grub: Support for chain
 loading.)
Date: Mon, 4 May 2020 01:47:13 +0200

Please delete the previous message/this ticket.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.