02/02: system: grub.cfg uses correct file names when store is not in root partition.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 0f65f54ebd76324653fd5506a7dab42ee44d9255
Author: Carlos Sánchez de La Lama <address@hidden>
Date:   Wed Sep 14 16:13:24 2016 +0200

    system: grub.cfg uses correct file names when store is not in root 
partition.
    
    Fixes <http://bugs.gnu.org/24346>.
    Reported by address@hidden (Carlos Sánchez de La Lama).
    
    * guix/scripts/system.scm (previous-grub-entries): Get the initrd file
    name from PARAMS.
    * gnu/system.scm (operating-system-grub.cfg): Use
    'operating-system-initrd-file' to retrieve the initrd file name.
    * gnu/system/grub.scm (strip-mount-point): New procedure.
    (grub-configuration-file)[entry->gexp]: Call 'strip-mount-point' for
    LINUX and INITRD.
    
    Co-authored-by: Ludovic Courtès <address@hidden>
---
 gnu/system.scm          |    3 ++-
 gnu/system/grub.scm     |   30 +++++++++++++++++++++++-------
 guix/scripts/system.scm |    9 +++++----
 3 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index bf79bf1..38ae8f1 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -727,6 +727,7 @@ listed in OS.  The C library expects to find it under
        (store-fs -> (operating-system-store-file-system os))
        (label ->    (kernel->grub-label (operating-system-kernel os)))
        (kernel ->   (operating-system-kernel-file os))
+       (initrd      (operating-system-initrd-file os))
        (root-device -> (if (eq? 'uuid (file-system-title root-fs))
                            (uuid->string (file-system-device root-fs))
                            (file-system-device root-fs)))
@@ -739,7 +740,7 @@ listed in OS.  The C library expects to find it under
                                    #~(string-append "--load=" #$system
                                                     "/boot")
                                    (operating-system-kernel-arguments os)))
-                           (initrd (file-append system "/initrd"))))))
+                           (initrd initrd)))))
     (grub-configuration-file (operating-system-bootloader os)
                              store-fs entries
                              #:old-entries old-entries)))
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 4592747..3d29428 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -62,6 +62,17 @@
 ;;;
 ;;; Code:
 
+(define (strip-mount-point fs file)
+  "Strip the mount point of FS from FILE, which is a gexp or other lowerable
+object denoting a file name."
+  (let ((mount-point (file-system-mount-point fs)))
+    (if (string=? mount-point "/")
+       file
+       #~(let ((file #$file))
+            (if (string-prefix? #$mount-point file)
+                (substring #$file #$(string-length mount-point))
+                file)))))
+
 (define-record-type* <grub-image>
   grub-image make-grub-image
   grub-image?
@@ -183,7 +194,8 @@ the store is.  SYSTEM must be the target system 
string---e.g.,
                      (symbol->string (assoc-ref colors 'bg)))))
 
   (define font-file
-    #~(string-append #$grub "/share/grub/unicode.pf2"))
+    (strip-mount-point root-fs
+                       (file-append grub "/share/grub/unicode.pf2")))
 
   (mlet* %store-monad ((image (grub-background-image config)))
     (return (and image
@@ -209,7 +221,7 @@ fi~%"
                            #$(grub-root-search root-fs font-file)
                            #$font-file
 
-                           #$image
+                           #$(strip-mount-point root-fs image)
                            #$(theme-colors grub-theme-color-normal)
                            #$(theme-colors grub-theme-color-highlight))))))
 
@@ -249,15 +261,19 @@ corresponding to old generations of the system."
   (define entry->gexp
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
-      #~(format port "menuentry ~s {
+      ;; Use the right file names for LINUX and STORE-FS in case STORE-FS is
+      ;; not the "/" file system.
+      (let ((linux  (strip-mount-point store-fs linux))
+            (initrd (strip-mount-point store-fs initrd)))
+        #~(format port "menuentry ~s {
   ~a
   linux ~a ~a
   initrd ~a
 }~%"
-                #$label
-                #$(grub-root-search store-fs linux)
-                #$linux (string-join (list address@hidden))
-                #$initrd))))
+                  #$label
+                  #$(grub-root-search store-fs linux)
+                  #$linux (string-join (list address@hidden))
+                  #$initrd)))))
 
   (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
     (define builder
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 953c624..a2cd97a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -383,7 +383,8 @@ it atomically, and then run OS's activation script."
                                   (uuid->string root)
                                   root))
             (kernel           (boot-parameters-kernel params))
-            (kernel-arguments (boot-parameters-kernel-arguments params)))
+            (kernel-arguments (boot-parameters-kernel-arguments params))
+            (initrd           (boot-parameters-initrd params)))
        (menu-entry
         (label (string-append label " (#"
                               (number->string number) ", "
@@ -391,10 +392,10 @@ it atomically, and then run OS's activation script."
         (linux kernel)
         (linux-arguments
          (cons* (string-append "--root=" root-device)
-                #~(string-append "--system=" #$system)
-                #~(string-append "--load=" #$system "/boot")
+                (string-append "--system=" system)
+                (string-append "--load=" system "/boot")
                 kernel-arguments))
-        (initrd #~(string-append #$system "/initrd"))))))
+        (initrd initrd)))))
 
   (let* ((numbers (generation-numbers profile))
          (systems (map (cut generation-file-name profile <>)