unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#41066] [PATCH] gnu: grub: Support for chain loading.
@ 2020-05-03 23:34 Stefan
  2020-05-24 11:13 ` Danny Milosavljevic
  0 siblings, 1 reply; 35+ messages in thread
From: Stefan @ 2020-05-03 23:34 UTC (permalink / raw)
  To: 41066

* 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



^ permalink raw reply related	[flat|nested] 35+ messages in thread

end of thread, other threads:[~2021-03-27 16:49 UTC | newest]

Thread overview: 35+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-05-03 23:34 [bug#41066] [PATCH] gnu: grub: Support for chain loading Stefan
2020-05-24 11:13 ` Danny Milosavljevic
2020-05-24 13:21   ` Stefan
2020-10-04 16:31     ` [bug#41066] [PATCH] gnu: bootloader: " Stefan
2020-10-10  9:31       ` Stefan
2020-10-18 11:20         ` Stefan
2020-10-18 11:21           ` Stefan
2020-10-22 17:46             ` Danny Milosavljevic
2020-10-23 12:48               ` Ludovic Courtès
2020-10-24  1:30                 ` Danny Milosavljevic
2020-10-24 16:22                   ` Ludovic Courtès
2020-10-25  0:33                     ` Danny Milosavljevic
2020-10-25 16:58                       ` Stefan
2020-10-25 16:59                         ` Stefan
2020-11-02 15:42                           ` Danny Milosavljevic
2020-11-02 16:21                             ` Mathieu Othacehe
2020-11-03  9:07                               ` Ludovic Courtès
2020-11-03  9:32                                 ` Mathieu Othacehe
2020-11-07 21:14                                   ` Stefan
2020-11-07 21:15                                     ` Stefan
2020-10-26 10:37                       ` Ludovic Courtès
2020-11-16  9:33             ` bug#41066: " Danny Milosavljevic
2020-11-17 14:26               ` [bug#41066] " Stefan
2020-11-17 15:47                 ` Danny Milosavljevic
2020-11-17 16:17                   ` Danny Milosavljevic
2020-11-17 20:27                   ` Stefan
2020-11-18 18:05                     ` Danny Milosavljevic
2020-11-18 18:20                       ` Stefan
2020-11-28 22:14                         ` [bug#41066] [PATCH] gnu: bootloader: Improve support " Stefan
2020-12-12 17:14                           ` Stefan
2020-12-13 14:42                             ` Danny Milosavljevic
2020-12-13 17:24                               ` Stefan
2020-12-13 19:28                                 ` Stefan
2020-12-28 19:02                                   ` Stefan
2021-03-27 16:48                                     ` bug#41066: " Stefan

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).