system: Record store file system info in each generation.

* gnu/system.scm (<boot-parameters>)[store-device, store-mount-point]:
New fields.
(read-boot-parameters): Initialize them.
(operating-system-grub.cfg): Likewise.  Remove STORE-FS argument from
call to 'grub-configuration-file'.
(operating-system-parameters-file): Add 'store' element in
'boot-parameters'.
* gnu/system/grub.scm (strip-mount-point): Replace 'store-fs' parameter
by 'mount-point'; adjust accordingly.  Adjust callers.
(<menu-entry>)[device, device-mount-point]: New fields.
(eye-candy): Replace 'root-fs' parameter by 'store-device'; add
'store-mount-point'.  Use keyword arguments for 'system' and 'port'.
(grub-root-search): Remove 'root-fs' by 'device' and adjust
accordingly.
(grub-configuration-file): Remove 'store-fs' parameter.  Adjust
accordingly.
* guix/scripts/system.scm (previous-grub-entries): Initialize 'device'
and 'device-mount-point' fields from PARAMS.
* doc/guix.texi (GRUB Configuration): Document 'device' and
'device-mount-point'.  Explain that 'linux' can be prefixed by a GRUB
device name.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 98 insertions, 46 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index 38ae8f1771..259875d761 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -99,6 +100,8 @@
             boot-parameters?
             boot-parameters-label
             boot-parameters-root-device
+            boot-parameters-store-device
+            boot-parameters-store-mount-point
             boot-parameters-kernel
             boot-parameters-kernel-arguments
             boot-parameters-initrd
@@ -733,6 +736,12 @@ listed in OS.  The C library expects to find it under
                            (file-system-device root-fs)))
        (entries ->  (list (menu-entry
                            (label label)
+
+                           ;; The device where the kernel and initrd live.
+                           (device (file-system-device store-fs))
+                           (device-mount-point
+                            (file-system-mount-point store-fs))
+
                            (linux kernel)
                            (linux-arguments
                             (cons* (string-append "--root=" root-device)
@@ -741,8 +750,7 @@ listed in OS.  The C library expects to find it under
                                                     "/boot")
                                    (operating-system-kernel-arguments os)))
                            (initrd initrd)))))
-    (grub-configuration-file (operating-system-bootloader os)
-                             store-fs entries
+    (grub-configuration-file (operating-system-bootloader os) entries
                              #:old-entries old-entries)))
 
 (define (operating-system-parameters-file os)
@@ -750,16 +758,24 @@ listed in OS.  The C library expects to find it under
 this file is the reconstruction of GRUB menu entries for old configurations."
   (mlet %store-monad ((initrd   (operating-system-initrd-file os))
                       (root ->  (operating-system-root-file-system os))
+                      (store -> (operating-system-store-file-system os))
                       (label -> (kernel->grub-label
                                  (operating-system-kernel os))))
     (gexp->file "parameters"
-                #~(boot-parameters (version 0)
-                                   (label #$label)
-                                   (root-device #$(file-system-device root))
-                                   (kernel #$(operating-system-kernel-file os))
-                                   (kernel-arguments
-                                    #$(operating-system-kernel-arguments os))
-                                   (initrd #$initrd))
+                #~(boot-parameters
+                   (version 0)
+                   (label #$label)
+                   (root-device #$(file-system-device root))
+                   (kernel #$(operating-system-kernel-file os))
+                   (kernel-arguments
+                    #$(operating-system-kernel-arguments os))
+                   (initrd #$initrd)
+                   (store
+                    (device #$(case (file-system-title store)
+                                ((uuid) (file-system-device store))
+                                ((label) (file-system-device store))
+                                (else #f)))
+                    (mount-point #$(file-system-mount-point store))))
                 #:set-load-path? #f)))
 
 
@@ -770,7 +786,16 @@ this file is the reconstruction of GRUB menu entries for old configurations."
 (define-record-type* <boot-parameters>
   boot-parameters make-boot-parameters boot-parameters?
   (label            boot-parameters-label)
+  ;; Because we will use the 'store-device' to create the GRUB search command,
+  ;; the 'store-device' has slightly different semantics than 'root-device'.
+  ;; The 'store-device' can be a file system uuid, a file system label, or #f,
+  ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
+  ;; understand that.  The 'root-device', on the other hand, corresponds
+  ;; exactly to the device field of the <file-system> object representing the
+  ;; OS's root file system, so it might be a device path like "/dev/sda3".
   (root-device      boot-parameters-root-device)
+  (store-device     boot-parameters-store-device)
+  (store-mount-point boot-parameters-store-mount-point)
   (kernel           boot-parameters-kernel)
   (kernel-arguments boot-parameters-kernel-arguments)
   (initrd           boot-parameters-initrd))
@@ -804,7 +829,21 @@ this file is the reconstruction of GRUB menu entries for old configurations."
          (('initrd ('string-append directory file)) ;the old format
           (string-append directory file))
          (('initrd (? string? file))
-          file)))))
+          file)))
+
+      (store-device
+       (match (assq 'store rest)
+         (('store ('device device) _ ...)
+          device)
+         (_                                       ;the old format
+          root)))
+
+      (store-mount-point
+       (match (assq 'store rest)
+         (('store ('device _) ('mount-point mount-point) _ ...)
+          mount-point)
+         (_                                       ;the old format
+          "/")))))
     (x                                            ;unsupported format
      (warning (_ "unrecognized boot parameters for '~a'~%")
               system)
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 249b415ab4..5c9d0f15a1 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
+  #:use-module (rnrs bytevectors)
   #:export (grub-image
             grub-image?
             grub-image-aspect-ratio
@@ -61,16 +63,15 @@
 ;;;
 ;;; 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 (strip-mount-point mount-point file)
+  "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
+denoting a file name."
+  (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
@@ -121,6 +122,10 @@ object denoting a file name."
   menu-entry make-menu-entry
   menu-entry?
   (label           menu-entry-label)
+  (device          menu-entry-device       ; file system uuid, label, or #f
+                   (default #f))
+  (device-mount-point menu-entry-device-mount-point
+                      (default "/"))
   (linux           menu-entry-linux)
   (linux-arguments menu-entry-linux-arguments
                    (default '()))          ; list of string-valued gexps
@@ -162,12 +167,14 @@ WIDTH/HEIGHT, or #f if none was found."
         (with-monad %store-monad
           (return #f)))))
 
-(define (eye-candy config root-fs system port)
+(define* (eye-candy config store-device store-mount-point
+                    #:key 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.  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\"."
+all that.  STORE-DEVICE designates the device holding the store, and
+STORE-MOUNT-POINT is its mount point; these are used to determine where the
+background image and fonts must be searched for.  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
@@ -191,7 +198,7 @@ the store is.  SYSTEM must be the target system string---e.g.,
                      (symbol->string (assoc-ref colors 'bg)))))
 
   (define font-file
-    (strip-mount-point root-fs
+    (strip-mount-point store-mount-point
                        (file-append grub "/share/grub/unicode.pf2")))
 
   (mlet* %store-monad ((image (grub-background-image config)))
@@ -215,10 +222,10 @@ else
   set menu_color_highlight=white/blue
 fi~%"
                            #$setup-gfxterm-body
-                           #$(grub-root-search root-fs font-file)
+                           #$(grub-root-search store-device font-file)
                            #$font-file
 
-                           #$(strip-mount-point root-fs image)
+                           #$(strip-mount-point store-mount-point image)
                            #$(theme-colors grub-theme-color-normal)
                            #$(theme-colors grub-theme-color-highlight))))))
 
@@ -227,8 +234,8 @@ fi~%"
 ;;; Configuration file.
 ;;;
 
-(define (grub-root-search root-fs file)
-  "Return the GRUB 'search' command to look for ROOT-FS, which contains FILE,
+(define (grub-root-search device file)
+  "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
 a gexp.  The result is a gexp that can be inserted in the grub.cfg-generation
 code."
   ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
@@ -236,20 +243,18 @@ code."
   ;; custom menu entries.  In the latter case, don't emit a 'search' command.
   (if (and (string? file) (not (string-prefix? "/" file)))
       ""
-      (case (file-system-title root-fs)
-        ;; Preferably refer to ROOT-FS by its UUID or label.  This is more
+      (match device
+        ;; Preferably refer to DEVICE by its UUID or label.  This is more
         ;; efficient and less ambiguous, see <>.
-        ((uuid)
+        ((? bytevector? 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.
+                 (uuid->string device)))
+        ((? string? label)
+         (format #f "search --label --set ~a" label))
+        (#f
          #~(format #f "search --file --set ~a" #$file)))))
 
-(define* (grub-configuration-file config store-fs entries
+(define* (grub-configuration-file config entries
                                   #:key
                                   (system (%current-system))
                                   (old-entries '()))
@@ -262,22 +267,30 @@ corresponding to old generations of the system."
 
   (define entry->gexp
     (match-lambda
-     (($ <menu-entry> label linux arguments initrd)
-      ;; 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)))
+     (($ <menu-entry> label device device-mount-point
+                      linux arguments initrd)
+      ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
+      ;; Use the right file names for LINUX 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 store-fs linux)
+                  #$(grub-root-search device linux)
                   #$linux (string-join (list #$@arguments))
                   #$initrd)))))
 
-  (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
+  (mlet %store-monad ((sugar (eye-candy config
+                                        (menu-entry-device (first entries))
+                                        (menu-entry-device-mount-point
+                                         (first entries))
+                                        #:system system
+                                        #:port #~port)))
     (define builder
       #~(call-with-output-file #$output
           (lambda (port)