diff mbox series

[bug#41066] gnu: bootloader: Support for chain loading.

Message ID 0DCDD4B0-DC4B-4870-B018-D771C509F9E5@vodafonemail.de
State Accepted
Headers show
Series [bug#41066] gnu: bootloader: Support for chain loading. | expand

Checks

Context Check Description
cbaines/submitting builds fail
cbaines/applying patch fail View Laminar job

Commit Message

Stefan Oct. 25, 2020, 4:59 p.m. UTC
* gnu/bootloader.scm (bootloader-profile): New internal function to build a
profile from a package and a collection of files to install.
(bootloader-chain): New function to chain a bootloader with a collection of
additional files like other bootloaders, configuration files or device-trees.

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

(operating-system
  (bootloader
    (bootloader-configuration
      (bootloader
        (bootloader-chain
          (list (file-append firmware "/boot/")
                (file-append u-boot-my-scb "/libexec/u-boot.bin")
                (plain-file "config.txt"
                            "kernel=u-boot.bin"))
          grub-efi-netboot-bootloader
          #:hook my-special-bootloader-profile-manipulator
          #:installer (install-grub-efi-netboot "efi/boot"))
        (target "/boot"))))
…)
---
 gnu/bootloader.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 124 insertions(+), 1 deletion(-)

Comments

Danny Milosavljevic Nov. 2, 2020, 3:42 p.m. UTC | #1
Hi Mathieu,

I've tried to test Stefan's patch on guix master with this configuration:

(use-modules (gnu))
(use-service-modules networking ssh)
(use-package-modules screen ssh bootloaders)

(operating-system
  (host-name "komputilo")
  (timezone "Europe/Berlin")
  (locale "en_US.utf8")
  (bootloader (bootloader-configuration
                (bootloader
                 (efi-bootloader-chain
                  (list ;(file-append firmware "/boot/")
                        (plain-file "config.txt"
                                    "kernel=u-boot.bin")
                        (file-append u-boot-a20-olinuxino-micro
                                     "/libexec/u-boot.bin"))
                  grub-efi-netboot-bootloader
                  ;#:hook my-special-bootloader-profile-manipulator
                  #:installer (install-grub-efi-netboot "efi/boot")))
                (target "/boot")))
  (file-systems (cons (file-system
                        (device (file-system-label "my-root"))
                        (mount-point "/")
                        (type "ext4"))
                      %base-file-systems))
  (users (cons (user-account
                (name "alice")
                (comment "Bob's sister")
                (group "users")
                (supplementary-groups '("wheel"
                                        "audio" "video")))
               %base-user-accounts))
  (packages (cons screen %base-packages))
  (services (append (list (service dhcp-client-service-type)
                          (service openssh-service-type
                                   (openssh-configuration
                                    (openssh openssh-sans-x)
                                    (port-number 2222))))
                    %base-services)))

and this command:

$ ./pre-inst-env guix system disk-image -t raw raspberry-os.scm

And I get this error:

################################################## ]^MESC[Kregistering 296 items  [######################################################]^MESC[Kregistering 296 items
Backtrace:
           5 (primitive-load "/gnu/store/br73py6l6w1x2p0ankqq9d8il4f…")
In ice-9/eval.scm:
    619:8  4 (_ #(#<directory (guile-user) 7ffff5bb7f00> #<proced…> …))
In ./gnu/build/image.scm:
    208:4  3 (initialize-root-partition "tmp-root" #:bootcfg _ # _ # …)
In ice-9/eval.scm:
    619:8  2 (_ #(#(#<directory (guile-user) 7ffff5bb7f00>) "/gnu…" …))
   293:34  1 (_ #(#(#<directory (guile-user) 7ffff5bb7f00>) "/gnu…" …))
In unknown file:
           0 (string-append "tmp-root" #f "/")

ERROR: In procedure string-append:
In procedure string-append: Wrong type (expecting string): #f
environment variable `PATH' set to `/gnu/store/swwd2i26pqx1jyfg81lrnrw1hq7adn05-e2fsprogs-1.45.6/bin:/gnu/store/swwd2i26pqx1jyfg81lrnrw1hq7adn05-e2fsprogs-1.45.6/sbin:/gnu/store/ppv9hd6mznmf1p4gagnrwzdivfhvc48z-fakeroot-1.25.3/bin:/gnu/store/nqynh6b3jhjh6wiq47jr4l6arckfw9j8-dosfstools-4.1/sbin:/gnu/store/zms4y35fpbpz5mr8qcb7ky8sqqnq61kh-mtools-4.0.25/bin'
installing bootloader...
[fails]

Before I search for it, would you know why it is?
Mathieu Othacehe Nov. 2, 2020, 4:21 p.m. UTC | #2
Hello Danny,

> $ ./pre-inst-env guix system disk-image -t raw raspberry-os.scm

The image types are not yet properly documented. However, the "raw"
image type corresponds to a raw image built for the current
architecture.

Using something like:

--8<---------------cut here---------------start------------->8---
./pre-inst-env guix system disk-image -t arm32-raw raspberry-os.scm
--8<---------------cut here---------------end--------------->8---

should cross-compile an image targeting an ARM32 architecture (since
commit c0458011).

Thanks,

Mathieu
Ludovic Courtès Nov. 3, 2020, 9:07 a.m. UTC | #3
Hi,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

>> $ ./pre-inst-env guix system disk-image -t raw raspberry-os.scm
>
> The image types are not yet properly documented. However, the "raw"
> image type corresponds to a raw image built for the current
> architecture.
>
> Using something like:
>
> ./pre-inst-env guix system disk-image -t arm32-raw raspberry-os.scm
>
> should cross-compile an image targeting an ARM32 architecture (since
> commit c0458011).

Ah so ‘-s’ and ‘--target’ are overridden by the image type?

Ludo’.
Mathieu Othacehe Nov. 3, 2020, 9:32 a.m. UTC | #4
Hey,

> Ah so ‘-s’ and ‘--target’ are overridden by the image type?

If a "target" is set in the "image" definition then yes it overrides
"--target", otherwise "--target" is honored.

This is handled by the following snippet:

--8<---------------cut here---------------start------------->8---
(let* ((base-image (os->image os #:type image-type))
       (base-target (image-target base-image)))
  (lower-object
   (system-image
    (image
     (inherit (if label
                  (image-with-label base-image label)
                  base-image))
     (target (or base-target target))
     (size image-size)
     (operating-system os))))))
--8<---------------cut here---------------end--------------->8---

There's no particular heuristic for "--system".

Mathieu
Stefan Nov. 7, 2020, 9:14 p.m. UTC | #5
Hi!

I did some more improvements to my previous patch.

Before copying files, it makes sense to check if the bootloader target is actually a directory. Also there is the convention for bootloader installer to check e.g. /mnt/boot/efi for existence and to prefer it over /boot/efi.

If someone implements an own installer procedure, then that installer gets the bootloader profile passed and may handle the files collection already, in which case copying them afterwards into the target directory is not wanted any more. So I added a #:copy-files? option to prevent copying files, but defaulting to #t.

For the generation of a profile a list of hooks is expected. I changed the #:hook option to be a #:hooks option and allow a single procedure and a list of procedures.


Schüss

Stefan
diff mbox series

Patch

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 2eebb8e9d9..b319e1f92f 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -22,6 +22,8 @@ 
 
 (define-module (gnu bootloader)
   #:use-module (guix discovery)
+  #:use-module (guix gexp)
+  #:use-module (guix profiles)
   #:use-module (guix records)
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
@@ -66,7 +68,9 @@ 
             bootloader-configuration-additional-configuration
 
             %bootloaders
-            lookup-bootloader-by-name))
+            lookup-bootloader-by-name
+
+            bootloader-chain))
 
 ^L
 ;;;
@@ -227,3 +231,122 @@  record."
               (eq? name (bootloader-name bootloader)))
             (force %bootloaders))
       (leave (G_ "~a: no such bootloader~%") name)))
+
+(define (bootloader-profile files bootloader-package hook)
+  "Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
+links to additional FILES from the store.  This collection is meant to be used
+by the bootloader installer.
+
+FILES is a list of file or directory names from the store, which will be
+symlinked into the collection/ directory.  If a directory name ends with '/',
+then the directory content instead of the directory itself will be symlinked
+into the collection/ directory.
+
+FILES may contain file like objects produced by functions like plain-file,
+local-file, etc., or package contents produced with file-append."
+  (define (bootloader-collection manifest)
+    (define build
+        (with-imported-modules '((guix build utils)
+                                 (ice-9 ftw)
+                                 (srfi srfi-1)
+                                 (srfi srfi-26))
+          #~(begin
+            (use-modules ((guix build utils)
+                          #:select (mkdir-p strip-store-file-name))
+                         ((ice-9 ftw)
+                          #:select (scandir))
+                         ((srfi srfi-1)
+                          #:select (append-map every remove))
+                         ((srfi srfi-26)
+                          #:select (cut)))
+            (define (symlink-to file directory transform)
+              "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
+              (symlink file (string-append directory "/" (transform file))))
+            (define (directory-content directory)
+              "Creates a list of absolute path names inside DIRECTORY."
+              (map (lambda (name)
+                     (string-append directory name))
+                   (or (scandir directory (lambda (name)
+                                            (not (member name '("." "..")))))
+                       '())))
+            (define name-ends-with-/? (cut string-suffix? "/" <>))
+            (define (name-is-store-entry? name)
+              "Return #t if NAME is a direct store entry and nothing inside."
+              (not (string-index (strip-store-file-name name) #\/)))
+            (let* ((collection (string-append #$output "/collection"))
+                   (files '#$files)
+                   (directories (filter name-ends-with-/? files))
+                   (names-from-directories
+                    (append-map (lambda (directory)
+                                  (directory-content directory))
+                                directories))
+                   (names (append names-from-directories
+                                  (remove name-ends-with-/? files))))
+              (mkdir-p collection)
+              (if (every file-exists? names)
+                  (begin
+                    (for-each (lambda (name)
+                               (symlink-to name collection
+                                            (if (name-is-store-entry? name)
+                                                strip-store-file-name
+                                                basename)))
+                              names)
+                    #t)
+                  #f)))))
+
+    (gexp->derivation "bootloader-collection"
+                      build
+                      #:local-build? #t
+                      #:substitutable? #f
+                      #:properties
+                      `((type . profile-hook)
+                        (hook . bootloader-collection))))
+
+  (profile (content (packages->manifest (list bootloader-package)))
+           (name "bootloader-profile")
+           (hooks (append (list bootloader-collection)
+                          (or hook '())))
+           (locales? #f)
+           (allow-collisions? #f)
+           (relative-symlinks? #f)))
+
+(define* (bootloader-chain files
+                           final-bootloader
+                           #:key
+                           hook
+                           installer)
+  "Defines a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
+certain directories and files from the store given in the list of FILES.
+
+FILES may contain file like objects produced by functions like plain-file,
+local-file, etc., or package contents produced with file-append.  They will be
+collected inside a directory collection/ inside a generated bootloader profile,
+which will be passed to the INSTALLER.
+
+If a directory name in FILES ends with '/', then the directory content instead
+of the directory itself will be symlinked into the collection/ directory.
+
+The PROFILE-HOOK function can be used to further modify the bootloader profile.
+
+If the INSTALLER argument is used, then this function will be called to install
+the bootloader. Otherwise the installer of the FINAL-BOOTLOADER will be called.
+
+Independent of the INSTALLER argument, all files in the mentioned collection/
+directory of the bootloader profile will be copied into the bootloader target
+directory after the actual bootloader installer has been called."
+  (let* ((final-installer (or installer
+                              (bootloader-installer final-bootloader)))
+         (profile (bootloader-profile files
+                                      (bootloader-package final-bootloader)
+                                      hook)))
+    (bootloader
+     (inherit final-bootloader)
+     (package profile)
+     (installer
+      #~(lambda (bootloader target mount-point)
+          (#$final-installer bootloader target mount-point)
+          (copy-recursively
+           (string-append bootloader "/collection")
+           (string-append mount-point target)
+           #:follow-symlinks? #t
+           #:log (%make-void-port "w")))))))