system: grub: Search root device by label or UUID if possible.

Fixes <http://bugs.gnu.org/22281>.
Reported by Christopher Allan Webber <cwebber@dustycloud.org>.

* gnu/system/grub.scm (eye-candy): Add 'root-fs' parameter.  Replace
'search --file' command in the output with whatever 'grub-root-search'
returns.
(grub-root-search): New procedure.
(grub-configuration-file): Add 'store-fs' parameter.  Use
'grub-root-search' instead of hard-coded 'search --file' commands.
* gnu/system.scm (store-file-system,
operating-system-store-file-system): New procedures.
(operating-system-grub.cfg): Use it, and adjust call to
'grub-configuration-file'.
* tests/system.scm: New file.
* Makefile.am (SCM_TESTS): Add it.

4 files changed, 143 insertions, 15 deletions

diff --git a/Makefile.am b/Makefile.am
index 7e41990cac..1ede6d4057 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -240,6 +240,7 @@ SCM_TESTS =					\
   tests/challenge.scm				\
   tests/cve.scm					\
   tests/file-systems.scm			\
+  tests/system.scm				\
   tests/services.scm				\
   tests/containers.scm				\
   tests/import-utils.scm
diff --git a/gnu/system.scm b/gnu/system.scm
index ee0280c069..edcfaf66fe 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -79,6 +79,7 @@
             operating-system-locale-libcs
             operating-system-mapped-devices
             operating-system-file-systems
+            operating-system-store-file-system
             operating-system-activation-script
 
             operating-system-derivation
@@ -678,12 +679,34 @@ listed in OS.  The C library expects to find it under
                  (package-version kernel)
                  " (alpha)"))
 
+(define (store-file-system file-systems)
+  "Return the file system object among FILE-SYSTEMS that contains the store."
+  (match (filter (lambda (fs)
+                   (and (file-system-mount? fs)
+                        (not (memq 'bind-mount (file-system-flags fs)))
+                        (string-prefix? (file-system-mount-point fs)
+                                        (%store-prefix))))
+                 file-systems)
+    ((and candidates (head . tail))
+     (reduce (lambda (fs1 fs2)
+               (if (> (string-length (file-system-mount-point fs1))
+                      (string-length (file-system-mount-point fs2)))
+                   fs1
+                   fs2))
+             head
+             candidates))))
+
+(define (operating-system-store-file-system os)
+  "Return the file system that contains the store of OS."
+  (store-file-system (operating-system-file-systems os)))
+
 (define* (operating-system-grub.cfg os #:optional (old-entries '()))
   "Return the GRUB configuration file for OS.  Use OLD-ENTRIES to populate the
 \"old entries\" menu."
   (mlet* %store-monad
       ((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))
        (root-device -> (if (eq? 'uuid (file-system-title root-fs))
                            (uuid->string (file-system-device root-fs))
@@ -698,7 +721,8 @@ listed in OS.  The C library expects to find it under
                                                     "/boot")
                                    (operating-system-kernel-arguments os)))
                            (initrd #~(string-append #$system "/initrd"))))))
-    (grub-configuration-file (operating-system-bootloader os) entries
+    (grub-configuration-file (operating-system-bootloader os)
+                             store-fs entries
                              #:old-entries old-entries)))
 
 (define (operating-system-parameters-file os)
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 5b824820b1..45b46cae6f 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,6 +25,7 @@
   #:use-module (guix gexp)
   #:use-module (guix download)
   #:use-module (gnu artwork)
+  #:use-module (gnu system file-systems)
   #:autoload   (gnu packages grub) (grub)
   #:autoload   (gnu packages inkscape) (inkscape)
   #:autoload   (gnu packages imagemagick) (imagemagick)
@@ -153,10 +154,12 @@ WIDTH/HEIGHT, or #f if none was found."
         (with-monad %store-monad
           (return #f)))))
 
-(define (eye-candy config system port)
+(define (eye-candy config root-fs system port)
   "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
 'grub.cfg' part concerned with graphics mode, background images, colors, and
-all that."
+all that.  ROOT-FS is a file-system object denoting the root file system where
+the store is.  SYSTEM must be the target system string---e.g.,
+\"x86_64-linux\"."
   (define setup-gfxterm-body
     ;; Intel systems need to be switched into graphics mode, whereas most
     ;; other modern architectures have no other mode and therefore don't need
@@ -179,15 +182,18 @@ all that."
       (string-append (symbol->string (assoc-ref colors 'fg)) "/"
                      (symbol->string (assoc-ref colors 'bg)))))
 
+  (define font-file
+    #~(string-append #$grub "/share/grub/unicode.pf2"))
+
   (mlet* %store-monad ((image (grub-background-image config)))
     (return (and image
                  #~(format #$port "
 function setup_gfxterm {~a}
 
 # Set 'root' to the partition that contains /gnu/store.
-search --file --set ~a/share/grub/unicode.pf2
+~a
 
-if loadfont ~a/share/grub/unicode.pf2; then
+if loadfont ~a; then
   setup_gfxterm
 fi
 
@@ -200,7 +206,9 @@ else
   set menu_color_highlight=white/blue
 fi~%"
                            #$setup-gfxterm-body
-                           #$grub #$grub
+                           #$(grub-root-search root-fs font-file)
+                           #$font-file
+
                            #$image
                            #$(theme-colors grub-theme-color-normal)
                            #$(theme-colors grub-theme-color-highlight))))))
@@ -210,13 +218,31 @@ fi~%"
 ;;; Configuration file.
 ;;;
 
-(define* (grub-configuration-file config entries
+(define (grub-root-search root-fs file)
+  "Return the GRUB 'search' command to look for ROOT-FS, which contains FILE,
+a gexp.  The result is a gexp that can be inserted in the grub.cfg-generation
+code."
+  (case (file-system-title root-fs)
+    ;; Preferably refer to ROOT-FS by its UUID or label.  This is more
+    ;; efficient and less ambiguous, see <>.
+    ((uuid)
+     (format #f "search --fs-uuid --set ~a"
+             (uuid->string (file-system-device root-fs))))
+    ((label)
+     (format #f "search --label --set ~a"
+             (file-system-device root-fs)))
+    (else
+     ;; As a last resort, look for any device containing FILE.
+     #~(format #f "search --file --set ~a" #$file))))
+
+(define* (grub-configuration-file config store-fs entries
                                   #:key
                                   (system (%current-system))
                                   (old-entries '()))
   "Return the GRUB configuration file corresponding to CONFIG, a
-<grub-configuration> object.  OLD-ENTRIES is taken to be a list of menu
-entries corresponding to old generations of the system."
+<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"
@@ -229,18 +255,18 @@ entries corresponding to old generations of the system."
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
       #~(format port "menuentry ~s {
-  # Set 'root' to the partition that contains the kernel.
-  search --file --set ~a/~a~%
-
+  ~a
   linux ~a/~a ~a
   initrd ~a
 }~%"
                 #$label
-                #$linux #$linux-image-name
+                #$(grub-root-search store-fs
+                                    #~(string-append #$linux "/"
+                                                     #$linux-image-name))
                 #$linux #$linux-image-name (string-join (list #$@arguments))
                 #$initrd))))
 
-  (mlet %store-monad ((sugar (eye-candy config system #~port)))
+  (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
     (define builder
       #~(call-with-output-file #$output
           (lambda (port)
diff --git a/tests/system.scm b/tests/system.scm
new file mode 100644
index 0000000000..7e016a610b
--- /dev/null
+++ b/tests/system.scm
@@ -0,0 +1,77 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-system)
+  #:use-module (gnu)
+  #:use-module (guix store)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64))
+
+;; Test the (gnu system) module.
+
+(define %root-fs
+  (file-system
+    (device "my-root")
+    (title 'label)
+    (mount-point "/")
+    (type "ext4")))
+
+(define %os
+  (operating-system
+    (host-name "komputilo")
+    (timezone "Europe/Berlin")
+    (locale "en_US.utf8")
+    (bootloader (grub-configuration (device "/dev/sdX")))
+    (file-systems (cons %root-fs %base-file-systems))
+
+    (users %base-user-accounts)))
+
+(test-begin "system")
+
+(test-assert "operating-system-store-file-system"
+  ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
+  ;; shouldn't be a problem.
+  (eq? %root-fs
+       (operating-system-store-file-system %os)))
+
+(test-assert "operating-system-store-file-system, prefix"
+  (let* ((gnu (file-system
+                (device "foobar")
+                (mount-point (dirname (%store-prefix)))
+                (type "ext5")))
+         (os  (operating-system
+                (inherit %os)
+                (file-systems (cons* gnu %root-fs
+                                     %base-file-systems)))))
+    (eq? gnu (operating-system-store-file-system os))))
+
+(test-assert "operating-system-store-file-system, store"
+  (let* ((gnu (file-system
+                (device "foobar")
+                (mount-point (%store-prefix))
+                (type "ext5")))
+         (os  (operating-system
+                (inherit %os)
+                (file-systems (cons* gnu %root-fs
+                                     %base-file-systems)))))
+    (eq? gnu (operating-system-store-file-system os))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))