13/28: bootloader: grub: Add support for '<hurd-menu-entry>'.

[guix-commits]

janneke pushed a commit to branch wip-hurd-vm
in repository guix.

commit dd623412833076ca3760ba03605df6b58ccc191d
Author: Jan (janneke) Nieuwenhuizen <address@hidden>
AuthorDate: Sun May 10 13:24:48 2020 +0200

    bootloader: grub: Add support for '<hurd-menu-entry>'.
    
    * gnu/bootloader/grub.scm (grub-configuration-file): Add support for
    <hurd-menu-entry> and switch between entries of type <menu-entry> and
    <hurd-menu-entry>.
---
 gnu/bootloader/grub.scm | 105 ++++++++++++++++++++++++++++++++++--------------
 1 file changed, 75 insertions(+), 30 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index ccf70b3..55cca72 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -25,12 +25,16 @@
   #:use-module (guix records)
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module (guix gexp)
+  #:use-module (guix utils)
   #:use-module (gnu artwork)
   #:use-module (gnu bootloader)
   #:use-module (gnu system uuid)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system keyboard)
+  #:use-module (gnu packages base)
   #:use-module (gnu packages bootloaders)
+  #:use-module (gnu packages cross-base)
+  #:use-module (gnu packages hurd)
   #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
   #:autoload   (gnu packages xorg) (xkeyboard-config)
   #:use-module (ice-9 match)
@@ -330,39 +334,80 @@ Btrfs root file system resides."
   (define all-entries
     (append entries (bootloader-configuration-menu-entries config)))
   (define (menu-entry->gexp entry)
-    (let* ((device (menu-entry-device entry))
-           (device-mount-point (menu-entry-device-mount-point entry))
-           (label (menu-entry-label entry))
-           (arguments (menu-entry-linux-arguments entry))
-           (kernel (normalize-file (menu-entry-linux entry)
-                                   device-mount-point
-                                   btrfs-subvolume-file-name))
-           (initrd (normalize-file (menu-entry-initrd entry)
-                                   device-mount-point
-                                   btrfs-subvolume-file-name)))
-      ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
-      ;; Use the right file names for KERNEL and INITRD in case
-      ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
-      ;; separate partition.
-
-      ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the kernel and
-      ;; initrd paths, to allow booting from a Btrfs subvolume.
-      #~(format port "menuentry ~s {
+    (match entry
+      ((? menu-entry?)
+       (let* ((device (menu-entry-device entry))
+              (device-mount-point (menu-entry-device-mount-point entry))
+              (label (menu-entry-label entry))
+              (arguments (menu-entry-linux-arguments entry))
+              (linux (normalize-file (menu-entry-linux entry)
+                                     device-mount-point
+                                     btrfs-subvolume-file-name))
+              (initrd (normalize-file (menu-entry-initrd entry)
+                                      device-mount-point
+                                      btrfs-subvolume-file-name)))
+         ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
+         ;; Use the right file names for LINUX and INITRD in case
+         ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
+         ;; separate partition.
+
+         ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
+         ;; initrd paths, to allow booting from a Btrfs subvolume.
+         #~(format port "menuentry ~s {
   ~a
   linux ~a ~a
   initrd ~a
 }~%"
-                #$label
-                #$(grub-root-search device kernel)
-                #$kernel (string-join (list #$@arguments))
-                #$initrd)))
-  (define sugar
-    (eye-candy config
-               (menu-entry-device (first all-entries))
-               (menu-entry-device-mount-point (first all-entries))
-               #:btrfs-store-subvolume-file-name btrfs-subvolume-file-name
-               #:system system
-               #:port #~port))
+                   #$label
+                   #$(grub-root-search device linux)
+                   #$linux (string-join (list #$@arguments))
+                   #$initrd)))
+      ((? hurd-menu-entry?)
+       (let* ((device (hurd-menu-entry-device entry))
+              (device-mount-point (hurd-menu-entry-device-mount-point entry))
+              (label (hurd-menu-entry-label entry))
+              (mach (hurd-menu-entry-mach entry))
+              (target (%current-target-system))
+              (hurd (hurd-menu-entry-hurd entry))
+              (mach (if target
+                        (with-parameters ((%current-system "i686-linux"))
+                          mach)
+                        mach))
+              (libc (if target
+                        (with-parameters ((%current-target-system #f))
+                          (cross-libc target))
+                        glibc)))
+         #~(format port "
+menuentry ~s {
+  multiboot ~a root=device:hd0s1
+  module ~a/hurd/ext2fs.static ext2fs \\
+    --multiboot-command-line='${kernel-command-line}' \\
+    --host-priv-port='${host-port}' \\
+    --device-master-port='${device-port}' \\
+    --exec-server-task='${exec-task}' \\
+    --store-type=typed \\
+    '${root}' '$(task-create)' '$(task-resume)'
+  module ~a/lib/ld.so.1 exec ~a/hurd/exec '$(exec-task=task-create)'
+}~%"
+                   #$label
+                   #$mach #$hurd
+                   #$libc #$hurd)))))
+
+  (define (sugar)
+    (let* ((entry (first all-entries))
+           (hurd? (hurd-menu-entry? entry))
+           (device ((if hurd? hurd-menu-entry-device menu-entry-device)
+                    entry))
+           (mount-point ((if hurd?
+                             hurd-menu-entry-device-mount-point
+                             menu-entry-device-mount-point)
+                         entry)))
+      (eye-candy config
+                 device
+                 mount-point
+                 #:btrfs-store-subvolume-file-name btrfs-subvolume-file-name
+                 #:system system
+                 #:port #~port)))
 
   (define keyboard-layout-config
     (let* ((layout (bootloader-configuration-keyboard-layout config))
@@ -387,7 +432,7 @@ keymap ~a~%" #$keymap))))
                   "# This file was generated from your Guix configuration.  
Any changes
 # will be lost upon reconfiguration.
 ")
-          #$sugar
+          #$(sugar)
           #$keyboard-layout-config
           (format port "
 set default=~a