[PATCH 03/10] Refactor grub.cfg generation logic

[cmmarusich@gmail.com]

From: Chris Marusich <cmmarusich@gmail.com>

This enables the implementation of 'guix system switch-generation' and 'guix
system roll-back'.  Those new commands will only be able to determine the
store device and mount point for a given system generation by reading them
from that generation's boot parameters file, which does not contain a
<file-system> object.  This change makes it possible for those commands
regenerate grub.cfg using that information.

* gnu/system.scm (operating-system-grub.cfg): Instead of passing store-fs
  directly as a parameter to grub-configuration-file, pass in its mount point
  and (basically) its device.

* gnu/system/grub.scm (strip-mount-point, eye-candy, grub-root-search,
  grub-configuration-file, previous-grub-entries): Refactor these procedures
  to take a mount point and/or (basically) a device as parameters instead of a
  full-fledged <file-system> object.
---
 gnu/system.scm          | 10 ++++-
 gnu/system/grub.scm     | 98 ++++++++++++++++++++++++++-----------------------
 guix/scripts/system.scm |  3 +-
 3 files changed, 63 insertions(+), 48 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index f9f63a0..0d8c25a 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -728,6 +728,10 @@ 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))
+       (grub-root-search-device -> (case (file-system-title store-fs)
+                                         ((uuid) (file-system-device store-fs))
+                                         ((label) (file-system-device store-fs))
+                                         (else #f)))
        (label ->    (kernel->grub-label (operating-system-kernel os)))
        (kernel ->   (operating-system-kernel-file os))
        (initrd      (operating-system-initrd-file os))
@@ -736,7 +740,7 @@ listed in OS.  The C library expects to find it under
                            (file-system-device root-fs)))
        (entries ->  (list (menu-entry
                            (label label)
-                           (device #f) ;; stub value, not used yet
+                           (device grub-root-search-device)
                            (linux kernel)
                            (linux-arguments
                             (cons* (string-append "--root=" root-device)
@@ -746,7 +750,9 @@ listed in OS.  The C library expects to find it under
                                    (operating-system-kernel-arguments os)))
                            (initrd initrd)))))
     (grub-configuration-file (operating-system-bootloader os)
-                             store-fs entries
+                             (file-system-mount-point store-fs)
+                             grub-root-search-device
+                             entries
                              #:old-entries old-entries)))
 
 (define (operating-system-parameters-file os)
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 859f33a..d45fdca 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -62,16 +62,15 @@
 ;;;
 ;;; Code:
 
-(define (strip-mount-point fs file)
-  "Strip the mount point of FS from FILE, which is a gexp or other lowerable
+(define (strip-mount-point mount-point file)
+  "Strip MOUNT-POINT 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)))))
+  (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
@@ -164,12 +163,15 @@ WIDTH/HEIGHT, or #f if none was found."
         (with-monad %store-monad
           (return #f)))))
 
-(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.  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 (eye-candy config store-fs-mount-point store-device system port)
+  "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
+concerned with graphics mode, background images, colors, and all that.
+STORE-FS-MOUNT-POINT is the mount point of the file system containing the
+store.  STORE-DEVICE is a file system UUID, a file system label, or #f.  The
+value of STORE-DEVICE determines the GRUB search command that will be used to
+find and set the GRUB root; for details, please refer to the
+'grub-root-search' procedure's docstring.  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
@@ -193,7 +195,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-fs-mount-point
                        (file-append grub "/share/grub/unicode.pf2")))
 
   (mlet* %store-monad ((image (grub-background-image config)))
@@ -201,7 +203,7 @@ the store is.  SYSTEM must be the target system string---e.g.,
                  #~(format #$port "
 function setup_gfxterm {~a}
 
-# Set 'root' to the partition that contains /gnu/store.
+# Set GRUB's 'root' to the device that contains the store.
 ~a
 
 if loadfont ~a; then
@@ -217,10 +219,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-fs-mount-point image)
                            #$(theme-colors grub-theme-color-normal)
                            #$(theme-colors grub-theme-color-highlight))))))
 
@@ -229,57 +231,63 @@ fi~%"
 ;;; Configuration file.
 ;;;
 
-(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
+(define (grub-root-search device file)
+  "Return a GRUB 'search' command (@pxref{search,,, grub, GNU GRUB manual})
+which will find the device indicated by DEVICE and which will set GRUB's
+'root' to it (@pxref{root,,, grub, GNU GRUB manual}).  DEVICE may be a file
+system UUID or label, in which case the search command will find the device
+containing the specified file system and set the root to it, or it may be #f,
+in which case the search command will find the device containing the specified
+FILE.  The result is a gexp that can be inserted into grub.cfg-generation
 code."
   ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
   ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of
   ;; 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
-        ;; 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)))
+  (cond ((and (string? file) (not (string-prefix? "/" file)))
+         "")
+        ((not device)
+         #~(format #f "search --file --set ~a" #$file))
+        ((string? device)
+         (format #f "search --label --set ~a" device))
         (else
-         ;; As a last resort, look for any device containing FILE.
-         #~(format #f "search --file --set ~a" #$file)))))
+         (format #f "search --fs-uuid --set ~a" (uuid->string device)))))
 
-(define* (grub-configuration-file config store-fs entries
+(define* (grub-configuration-file config
+                                  store-fs-mount-point
+                                  store-device
+                                  entries
                                   #:key
                                   (system (%current-system))
                                   (old-entries '()))
   "Return the GRUB configuration file corresponding to CONFIG, a
-<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."
+<grub-configuration> object.  STORE-FS-MOUNT-POINT is the mount point of the
+file system containing the store.  STORE-DEVICE is a file system UUID, a file
+system label, or #f.  The value of STORE-DEVICE determines the GRUB search
+command that will be used to find and set the GRUB root; for details, please
+refer to the 'grub-root-search' procedure's docstring.  OLD-ENTRIES is taken
+to be a list of menu entries corresponding to old generations of the system."
   (define all-entries
     (append entries (grub-configuration-menu-entries config)))
 
   (define entry->gexp
     (match-lambda
      (($ <menu-entry> label device 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)))
+      ;; Use the right paths in case the file system containing the store is
+      ;; not mounted at "/".
+      (let ((linux  (strip-mount-point store-fs-mount-point linux))
+            (initrd (strip-mount-point store-fs-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 store-fs-mount-point store-device system #~port)))
     (define builder
       #~(call-with-output-file #$output
           (lambda (port)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 8f0b8cd..4edaa0f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -375,6 +375,7 @@ it atomically, and then run OS's activation script."
                                 read-boot-parameters))
             (label            (boot-parameters-label params))
             (root             (boot-parameters-root-device params))
+            (store            (boot-parameters-store-device params))
             (root-device      (if (bytevector? root)
                                   (uuid->string root)
                                   root))
@@ -385,7 +386,7 @@ it atomically, and then run OS's activation script."
         (label (string-append label " (#"
                               (number->string number) ", "
                               (seconds->string time) ")"))
-        (device #f) ; stub value, not used yet
+        (device store)
         (linux kernel)
         (linux-arguments
          (cons* (string-append "--root=" root-device)
-- 
2.9.2