09/24: bootloader: grub: Add support for '<hurd-menu-entry>'.

[guix-commits]

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

commit 50343b8c545bd0fd1905c90895797ff1f211801a
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 | 92 ++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 68 insertions(+), 24 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 842592c..894e0dc 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -25,12 +25,15 @@
   #: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)
   #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
   #:autoload   (gnu packages xorg) (xkeyboard-config)
   #:use-module (ice-9 match)
@@ -331,33 +334,74 @@ entries corresponding to old generations of the system."
   (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))
-          (kernel (menu-entry-linux entry))
-          (arguments (menu-entry-linux-arguments entry))
-          (initrd (menu-entry-initrd entry)))
-      ;; 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.
-      (let ((kernel  (strip-mount-point device-mount-point kernel))
-            (initrd  (strip-mount-point device-mount-point initrd)))
-        #~(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))
+             (linux (menu-entry-linux entry))
+             (arguments (menu-entry-linux-arguments entry))
+             (initrd (menu-entry-initrd entry)))
+         ;; 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.
+         (let ((linux  (strip-mount-point device-mount-point linux))
+               (initrd  (strip-mount-point device-mount-point initrd)))
+           #~(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))
-               #: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
+                 #:system system
+                 #:port #~port)))
 
   (define keyboard-layout-config
     (let ((layout (bootloader-configuration-keyboard-layout config))
@@ -377,7 +421,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