Package: guix-patches;
Reported by: Stefan Kuhr <Stefan_Kuhr <at> arcor.de>
Date: Sun, 3 May 2020 23:44:02 UTC
Severity: normal
Tags: patch
Merged with 41066
Done: Stefan <stefan-guix <at> vodafonemail.de>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Stefan Kuhr <Stefan_Kuhr <at> arcor.de> To: 41068 <at> debbugs.gnu.org Subject: [bug#41068] [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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.