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.

1 files changed, 25 insertions, 1 deletions

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)