04/05: system: grub: Allow arbitrary kernel file names in 'menu-entry'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 44d5f54e31039d78f156bd9562dca293124eaa76
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 9 23:27:00 2016 +0200

    system: grub: Allow arbitrary kernel file names in 'menu-entry'.
    
    Fixes <http://bugs.gnu.org/20067>.
    Reported by Tomáš Čech <address@hidden>.
    
    * gnu/system.scm (system-linux-image-file-name)
    (operating-system-kernel-file): New procedures.
    (operating-system-grub.cfg): Use 'operating-system-kernel-file' for the
    'kernel' field of 'menu-entry'.
    (operating-system-parameters-file): Likewise for the 'kernel' entry.
    (read-boot-parameters): Adjust 'kernel' field so that it contains the
    absolute file name of the image.
    * gnu/system/grub.scm (grub-configuration-file)[linux-image-name]:
    Remove.
    [entry->gexp]: Assume LINUX is the absolute file name of the kernel
    image.
    * doc/guix.texi (GRUB Configuration): Add an example, and adjust
    'kernel' field documentation accordingly.
---
 doc/guix.texi       |   22 ++++++++++++++++++++--
 gnu/system.scm      |   30 ++++++++++++++++++++++++++----
 gnu/system/grub.scm |   13 +++----------
 3 files changed, 49 insertions(+), 16 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6d33618..7ed8ee8 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10622,9 +10622,23 @@ The @code{grub-theme} object describing the theme to 
use.
 
 @end deftp
 
address@hidden dual boot
address@hidden boot menu
 Should you want to list additional boot menu entries @i{via} the
 @code{menu-entries} field above, you will need to create them with the
address@hidden form:
address@hidden form.  For example, imagine you want to be able to
+boot another distro (hard to imagine!), you can define a menu entry
+along these lines:
+
address@hidden
+(menu-entry
+  (label "The Other Distro")
+  (linux "/boot/old/vmlinux-2.6.32")
+  (linux-arguments '("root=/dev/sda2"))
+  (initrd "/boot/old/initrd"))
address@hidden example
+
+Details below.
 
 @deftp {Data Type} menu-entry
 The type of an entry in the GRUB boot menu.
@@ -10635,7 +10649,11 @@ The type of an entry in the GRUB boot menu.
 The label to show in the menu---e.g., @code{"GNU"}.
 
 @item @code{linux}
-The Linux kernel to boot.
+The Linux kernel image to boot, for example:
+
address@hidden
+(file-append linux-libre "/bzImage")
address@hidden example
 
 @item @code{linux-arguments} (default: @code{()})
 The list of extra Linux kernel command-line arguments---e.g.,
diff --git a/gnu/system.scm b/gnu/system.scm
index 0802010..18b2806 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -69,6 +69,7 @@
             operating-system-host-name
             operating-system-hosts-file
             operating-system-kernel
+            operating-system-kernel-file
             operating-system-kernel-arguments
             operating-system-initrd
             operating-system-users
@@ -246,6 +247,19 @@ from the initrd."
   "Return the list of swap services for OS."
   (map swap-service (operating-system-swap-devices os)))
 
+(define* (system-linux-image-file-name #:optional (system (%current-system)))
+  "Return the basename of the kernel image file for SYSTEM."
+  ;; FIXME: Evaluate the conditional based on the actual current system.
+  (if (string-prefix? "mips" (%current-system))
+      "vmlinuz"
+      "bzImage"))
+
+(define (operating-system-kernel-file os)
+  "Return an object representing the absolute file name of the kernel image of
+OS."
+  (file-append (operating-system-kernel os)
+               "/" (system-linux-image-file-name os)))
+
 (define* (operating-system-directory-base-entries os #:key container?)
   "Return the basic entries of the 'system' directory of OS for use as the
 value of the SYSTEM-SERVICE-TYPE service."
@@ -710,12 +724,13 @@ listed in OS.  The C library expects to find it under
       ((system      (operating-system-derivation os))
        (root-fs ->  (operating-system-root-file-system os))
        (store-fs -> (operating-system-store-file-system os))
-       (kernel ->   (operating-system-kernel os))
+       (label ->    (kernel->grub-label (operating-system-kernel os)))
+       (kernel ->   (operating-system-kernel-file os))
        (root-device -> (if (eq? 'uuid (file-system-title root-fs))
                            (uuid->string (file-system-device root-fs))
                            (file-system-device root-fs)))
        (entries ->  (list (menu-entry
-                           (label (kernel->grub-label kernel))
+                           (label label)
                            (linux kernel)
                            (linux-arguments
                             (cons* (string-append "--root=" root-device)
@@ -739,7 +754,7 @@ this file is the reconstruction of GRUB menu entries for 
old configurations."
                 #~(boot-parameters (version 0)
                                    (label #$label)
                                    (root-device #$(file-system-device root))
-                                   (kernel #$(operating-system-kernel os))
+                                   (kernel #$(operating-system-kernel-file os))
                                    (kernel-arguments
                                     #$(operating-system-kernel-arguments os))
                                    (initrd #$initrd))
@@ -768,7 +783,14 @@ this file is the reconstruction of GRUB menu entries for 
old configurations."
      (boot-parameters
       (label label)
       (root-device root)
-      (kernel linux)
+
+      ;; In the past, we would store the directory name of the kernel instead
+      ;; of the absolute file name of its image.  Detect that and correct it.
+      (kernel (if (string=? linux (direct-store-path linux))
+                  (string-append linux "/"
+                                 (system-linux-image-file-name))
+                  linux))
+
       (kernel-arguments
        (match (assq 'kernel-arguments rest)
          ((_ args) args)
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index aa93c0f..4592747 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -243,11 +243,6 @@ code."
 <grub-configuration> object, and where the store is available at STORE-FS, a
 <file-system> object.  OLD-ENTRIES is taken to be a list of menu entries
 corresponding to old generations of the system."
-  (define linux-image-name
-    (if (string-prefix? "mips" system)
-        "vmlinuz"
-        "bzImage"))
-
   (define all-entries
     (append entries (grub-configuration-menu-entries config)))
 
@@ -256,14 +251,12 @@ corresponding to old generations of the system."
      (($ <menu-entry> label linux arguments initrd)
       #~(format port "menuentry ~s {
   ~a
-  linux ~a/~a ~a
+  linux ~a ~a
   initrd ~a
 }~%"
                 #$label
-                #$(grub-root-search store-fs
-                                    #~(string-append #$linux "/"
-                                                     #$linux-image-name))
-                #$linux #$linux-image-name (string-join (list address@hidden))
+                #$(grub-root-search store-fs linux)
+                #$linux (string-join (list address@hidden))
                 #$initrd))))
 
   (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))