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

Previous Next

Full log

View this message in rfc822 format

From: help-debbugs <at> gnu.org (GNU bug Tracking System)
To: Stefan <stefan-guix <at> vodafonemail.de>
Cc: tracker <at> debbugs.gnu.org
Subject: bug#41066: closed ([PATCH] gnu: grub: Support for chain loading.)
Date: Sat, 27 Mar 2021 16:49:02 +0000

[Message part 1 (text/plain, inline)]

Your message dated Sat, 27 Mar 2021 17:48:23 +0100
with message-id <CC051D00-1ACC-4A45-A1AD-3206B7F98C78 <at> vodafonemail.de>
and subject line Re: [PATCH] gnu: bootloader: Improve support for chain loading.
has caused the debbugs.gnu.org bug report #41066,
regarding [PATCH] gnu: grub: Support for chain loading.
to be marked as done.

(If you believe you have received this mail in error, please contact
help-debbugs <at> gnu.org.)


-- 
41066: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=41066
GNU Bug Tracking System
Contact help-debbugs <at> gnu.org with problems

[Message part 2 (message/rfc822, inline)]

From: Stefan <stefan-guix <at> vodafonemail.de>
To: guix-patches <at> gnu.org
Subject: [PATCH] gnu: grub: Support for chain loading.
Date: Mon, 4 May 2020 01:34:24 +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 part 3 (message/rfc822, inline)]

From: Stefan <stefan-guix <at> vodafonemail.de>
To: 41066-done <at> debbugs.gnu.org
Subject: Re: [PATCH] gnu: bootloader: Improve support for chain loading.
Date: Sat, 27 Mar 2021 17:48:23 +0100

Hi!

I’m working on a different improvement, which will make the still outstanding patch in this ticket obsolete. So this is done.


Bye

Stefan

Previous Next

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