branch master updated: system: Add store-directory-prefix to boot-parameters.

[guix-commits]

This is an automated email from the git hooks/post-receive script.

m1gu3l pushed a commit to branch master
in repository guix.

The following commit(s) were added to refs/heads/master by this push:
     new 582cf92  system: Add store-directory-prefix to boot-parameters.
582cf92 is described below

commit 582cf9257cd1f9c969fbba5eb1c336ac8b975cde
Author: Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
AuthorDate: Sat Oct 24 18:15:53 2020 +0200

    system: Add store-directory-prefix to boot-parameters.
    
    Fixes <http://issues.guix.gnu.org/44196>
    
    * gnu/machine/ssh.scm (roll-back-managed-host): Use
    boot-parameters-store-directory-prefix.
    * gnu/system.scm (define-module): Export
    boot-parameters-store-directory-prefix.
    (<boot-parameters>)[store-directory-prefix]: New field. It is used to
    generate the correct paths when /gnu/store is installed on a btrfs
    subvolume whose name doesn't match the final runtime path, as the
    bootloader doesn't have knowledge about the final mounting points.
    [boot-parameters-store-directory-prefix]: New accessor.
    (read-boot-parameters): Read directory-prefix from store field.
    (operating-system-boot-parameters-file): Add directory-prefix to
    store field.
    * guix/scripts/system.scm (reinstall-bootloader): Use
    boot-parameters-store-directory-prefix.
    * test/boot-parameters.scm (%default-btrfs-subvolume,
    %default-store-directory-prefix): New variables.
    (%grub-boot-parameters): Use %default-store-directory-prefix.
    (%default-operating-system): Use %default-btrfs-subvolume.
    (test-boot-parameters): Add directory-prefix.
    (test optional fields): Add test for directory-prefix.
    (test os store-directory-prefix): New test.
---
 gnu/machine/ssh.scm       |  3 +++
 gnu/system.scm            | 23 ++++++++++++++++++++++-
 guix/scripts/system.scm   |  3 +++
 tests/boot-parameters.scm | 23 ++++++++++++++++++++---
 4 files changed, 48 insertions(+), 4 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 5020bd3..a3a12fb 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -482,6 +482,8 @@ an environment type of 'managed-host."
                                         (list (second boot-parameters))))
                        (locale -> (boot-parameters-locale
                                    (second boot-parameters)))
+                       (store-dir -> (boot-parameters-store-directory-prefix
+                                      (second boot-parameters)))
                        (old-entries -> (map boot-parameters->menu-entry
                                             (drop boot-parameters 2)))
                        (bootloader -> (operating-system-bootloader
@@ -492,6 +494,7 @@ an environment type of 'managed-host."
                                     bootloader))
                                   bootloader entries
                                   #:locale locale
+                                  #:store-directory-prefix store-dir
                                   #:old-entries old-entries)))
                        (remote-result (machine-remote-eval machine 
remote-exp)))
     (when (eqv? 'error remote-result)
diff --git a/gnu/system.scm b/gnu/system.scm
index a3122ea..ff9ab18 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -148,6 +148,7 @@
             boot-parameters-bootloader-name
             boot-parameters-bootloader-menu-entries
             boot-parameters-store-device
+            boot-parameters-store-directory-prefix
             boot-parameters-store-mount-point
             boot-parameters-locale
             boot-parameters-kernel
@@ -293,12 +294,17 @@ directly by the user."
   ;; 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".
+  ;; The 'store-directory-prefix' field contains #f or the store path inside
+  ;; the 'store-device' as it is seen by GRUB, e.g. it would contain
+  ;; "/storefs" if the store is located in that subvolume of a btrfs
+  ;; partition.
   (root-device      boot-parameters-root-device)
   (bootloader-name  boot-parameters-bootloader-name)
   (bootloader-menu-entries                        ;list of <menu-entry>
    boot-parameters-bootloader-menu-entries)
   (store-device     boot-parameters-store-device)
   (store-mount-point boot-parameters-store-mount-point)
+  (store-directory-prefix boot-parameters-store-directory-prefix)
   (locale           boot-parameters-locale)
   (kernel           boot-parameters-kernel)
   (kernel-arguments boot-parameters-kernel-arguments)
@@ -394,6 +400,17 @@ file system labels."
           (_                                      ;the old format
            root-device))))
 
+      (store-directory-prefix
+       (match (assq 'store rest)
+         (('store . store-data)
+          (match (assq 'directory-prefix store-data)
+            (('directory-prefix prefix) prefix)
+            ;; No directory-prefix found.
+            (_ #f)))
+         (_
+          ;; No store found, old format.
+          #f)))
+
       (store-mount-point
        (match (assq 'store rest)
          (('store ('device _) ('mount-point mount-point) _ ...)
@@ -1294,6 +1311,7 @@ such as '--root' and '--load' to <boot-parameters>."
   (let* ((initrd          (and (not (operating-system-hurd os))
                                (operating-system-initrd-file os)))
          (store           (operating-system-store-file-system os))
+         (file-systems    (operating-system-file-systems os))
          (locale          (operating-system-locale os))
          (bootloader      (bootloader-configuration-bootloader
                            (operating-system-bootloader os)))
@@ -1315,6 +1333,7 @@ such as '--root' and '--load' to <boot-parameters>."
       (bootloader-configuration-menu-entries (operating-system-bootloader os)))
      (locale locale)
      (store-device (ensure-not-/dev (file-system-device store)))
+     (store-directory-prefix (btrfs-store-subvolume-file-name file-systems))
      (store-mount-point (file-system-mount-point store)))))
 
 (define (device->sexp device)
@@ -1371,7 +1390,9 @@ being stored into the \"parameters\" file)."
                       (device
                        #$(device->sexp (boot-parameters-store-device params)))
                       (mount-point #$(boot-parameters-store-mount-point
-                                      params))))
+                                      params))
+                      (directory-prefix
+                       #$(boot-parameters-store-directory-prefix params))))
                   #:set-load-path? #f)))
 
 (define-gexp-compiler (operating-system-compiler (os <operating-system>)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9ed5c26..ad99815 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -385,6 +385,8 @@ STORE is an open connection to the store."
          (params (first (profile-boot-parameters %system-profile
                                                  (list number))))
          (locale (boot-parameters-locale params))
+         (store-directory-prefix
+          (boot-parameters-store-directory-prefix params))
          (old-generations
           (delv number (reverse (generation-numbers %system-profile))))
          (old-params (profile-boot-parameters
@@ -398,6 +400,7 @@ STORE is an open connection to the store."
                      ((bootloader-configuration-file-generator bootloader)
                       bootloader-config entries
                       #:locale locale
+                      #:store-directory-prefix store-directory-prefix
                       #:old-entries old-entries)))
            (drvs -> (list bootcfg)))
         (mbegin %store-monad
diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm
index d7e579b..a00b227 100644
--- a/tests/boot-parameters.scm
+++ b/tests/boot-parameters.scm
@@ -46,6 +46,9 @@
 (define %default-initrd (string-append %default-initrd-path "/initrd.cpio.gz"))
 (define %default-root-device (uuid "abcdef12-3456-7890-abcd-ef1234567890"))
 (define %default-store-device (uuid "01234567-89ab-cdef-0123-456789abcdef"))
+(define %default-btrfs-subvolume "testfs")
+(define %default-store-directory-prefix
+  (string-append "/" %default-btrfs-subvolume))
 (define %default-store-mount-point (%store-prefix))
 (define %default-multiboot-modules '())
 (define %default-locale "es_ES.utf8")
@@ -63,6 +66,7 @@
    (multiboot-modules %default-multiboot-modules)
    (locale %default-locale)
    (store-device %default-store-device)
+   (store-directory-prefix %default-store-directory-prefix)
    (store-mount-point %default-store-mount-point)))
 
 (define %default-operating-system
@@ -81,7 +85,10 @@
                         (file-system
                            (device %default-store-device)
                            (mount-point %default-store-mount-point)
-                           (type "btrfs"))
+                           (type "btrfs")
+                           (options
+                            (string-append "subvol="
+                                           %default-btrfs-subvolume)))
                          %base-file-systems))))
 
 (define (quote-uuid uuid)
@@ -103,6 +110,7 @@
           (with-store #t)
           (store-device
            (quote-uuid %default-store-device))
+          (store-directory-prefix %default-store-directory-prefix)
           (store-mount-point %default-store-mount-point))
   (define (generate-boot-parameters)
     (define (sexp-or-nothing fmt val)
@@ -117,10 +125,12 @@
             (sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments)
             (sexp-or-nothing " (initrd ~S)" initrd)
             (if with-store
-                (format #false " (store~a~a)"
+                (format #false " (store~a~a~a)"
                         (sexp-or-nothing " (device ~S)" store-device)
                         (sexp-or-nothing " (mount-point ~S)"
-                                         store-mount-point))
+                                         store-mount-point)
+                        (sexp-or-nothing " (directory-prefix ~S)"
+                                         store-directory-prefix))
                 "")
             (sexp-or-nothing " (locale ~S)" locale)
             (sexp-or-nothing " (bootloader-name ~a)" bootloader-name)
@@ -149,6 +159,7 @@
        (test-read-boot-parameters #:store-device #false)
        (test-read-boot-parameters #:store-device 'false)
        (test-read-boot-parameters #:store-mount-point #false)
+       (test-read-boot-parameters #:store-directory-prefix #false)
        (test-read-boot-parameters #:multiboot-modules #false)
        (test-read-boot-parameters #:locale #false)
        (test-read-boot-parameters #:bootloader-name #false
@@ -253,4 +264,10 @@
    (operating-system-boot-parameters %default-operating-system
                                      %default-root-device)))
 
+(test-equal "from os, store-directory-prefix"
+  %default-store-directory-prefix
+  (boot-parameters-store-directory-prefix
+   (operating-system-boot-parameters %default-operating-system
+                                     %default-root-device)))
+
 (test-end "boot-parameters")