Merge branch 'master' into core-updates

1 files changed, 48 insertions, 33 deletions

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b505b0cf6b..91e117b9f3 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -32,7 +32,7 @@
   #:use-module (guix modules)
   #:use-module (guix scripts pack)
   #:use-module (guix utils)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module ((guix self) #:select (make-config.scm))
 
@@ -43,7 +43,7 @@
   #:use-module (gnu packages cdrom)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
-  #:autoload   (gnu packages gnupg) (libgcrypt)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -124,10 +124,12 @@
     (('gnu rest ...) #t)
     (rest #f)))
 
-(define guile-sqlite3&co
-  ;; Guile-SQLite3 and its propagated inputs.
-  (cons guile-sqlite3
-        (package-transitive-propagated-inputs guile-sqlite3)))
+(define gcrypt-sqlite3&co
+  ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
+  (append-map (lambda (package)
+                (cons package
+                      (package-transitive-propagated-inputs package)))
+              (list guile-gcrypt guile-sqlite3)))
 
 (define* (expression->derivation-in-linux-vm name exp
                                              #:key
@@ -164,10 +166,6 @@ based on the size of the closure of REFERENCES-GRAPHS.
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs, as for `derivation'.  The files containing the reference graphs are
 made available under the /xchg CIFS share."
-  (define config
-    ;; (guix config) module for consumption by (guix gcrypt).
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define user-builder
     (program-file "builder-in-linux-vm" exp))
 
@@ -195,12 +193,14 @@ made available under the /xchg CIFS share."
 
     (define builder
       ;; Code that launches the VM that evaluates EXP.
-      (with-extensions guile-sqlite3&co
+      (with-extensions gcrypt-sqlite3&co
         (with-imported-modules `(,@(source-module-closure
                                     '((guix build utils)
                                       (gnu build vm))
                                     #:select? not-config?)
-                                 ((guix config) => ,config))
+
+                                 ;; For consumption by (gnu store database).
+                                 ((guix config) => ,(make-config.scm)))
           #~(begin
               (use-modules (guix build utils)
                            (gnu build vm))
@@ -255,9 +255,6 @@ made available under the /xchg CIFS share."
   "Return a bootable, stand-alone iso9660 image.
 
 INPUTS is a list of inputs (as for packages)."
-  (define config
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -265,12 +262,12 @@ INPUTS is a list of inputs (as for packages)."
 
   (expression->derivation-in-linux-vm
    name
-   (with-extensions guile-sqlite3&co
+   (with-extensions gcrypt-sqlite3&co
      (with-imported-modules `(,@(source-module-closure '((gnu build vm)
                                                          (guix store database)
                                                          (guix build utils))
                                                        #:select? not-config?)
-                              ((guix config) => ,config))
+                              ((guix config) => ,(make-config.scm)))
        #~(begin
            (use-modules (gnu build vm)
                         (guix store database)
@@ -347,9 +344,6 @@ INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
 the image."
-  (define config
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -357,13 +351,13 @@ the image."
 
   (expression->derivation-in-linux-vm
    name
-   (with-extensions guile-sqlite3&co
+   (with-extensions gcrypt-sqlite3&co
      (with-imported-modules `(,@(source-module-closure '((gnu build vm)
                                                          (gnu build bootloader)
                                                          (guix store database)
                                                          (guix build utils))
                                                        #:select? not-config?)
-                              ((guix config) => ,config))
+                              ((guix config) => ,(make-config.scm)))
        #~(begin
            (use-modules (gnu build bootloader)
                         (gnu build vm)
@@ -462,10 +456,6 @@ makes sense when you want to build a GuixSD Docker image that has Guix
 installed inside of it.  If you don't need Guix (e.g., your GuixSD Docker
 image just contains a web server that is started by the Shepherd), then you
 should set REGISTER-CLOSURES? to #f."
-  (define config
-    ;; (guix config) module for consumption by (guix gcrypt).
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -475,8 +465,8 @@ should set REGISTER-CLOSURES? to #f."
                       (name -> (string-append name ".tar.gz"))
                       (graph -> "system-graph"))
     (define build
-      (with-extensions (cons guile-json          ;for (guix docker)
-                             guile-sqlite3&co)   ;for (guix store database)
+      (with-extensions (cons guile-json           ;for (guix docker)
+                             gcrypt-sqlite3&co)   ;for (guix store database)
         (with-imported-modules `(,@(source-module-closure
                                     '((guix docker)
                                       (guix store database)
@@ -484,7 +474,7 @@ should set REGISTER-CLOSURES? to #f."
                                       (guix build store-copy)
                                       (gnu build vm))
                                     #:select? not-config?)
-                                 ((guix config) => ,config))
+                                 ((guix config) => ,(make-config.scm)))
           #~(begin
               (use-modules (guix docker)
                            (guix build utils)
@@ -539,17 +529,42 @@ should set REGISTER-CLOSURES? to #f."
 (define* (operating-system-uuid os #:optional (type 'dce))
   "Compute UUID object with a deterministic \"UUID\" for OS, of the given
 TYPE (one of 'iso9660 or 'dce).  Return a UUID object."
+  ;; Note: For this to be deterministic, we must not hash things that contains
+  ;; (directly or indirectly) procedures, for example.  That rules out
+  ;; anything that contains gexps, thunk or delayed record fields, etc.
+
+  (define service-name
+    (compose service-type-name service-kind))
+
+  (define (file-system-digest fs)
+    ;; Return a hashable digest that does not contain 'dependencies' since
+    ;; this field can contain procedures.
+    (let ((device (file-system-device fs)))
+      (list (file-system-mount-point fs)
+            (file-system-type fs)
+            (cond ((file-system-label? device)
+                   (file-system-label->string device))
+                  ((uuid? device)
+                   (uuid->string device))
+                  ((string? device)
+                   device)
+                  (else #f))
+            (file-system-options fs))))
+
   (if (eq? type 'iso9660)
       (let ((pad (compose (cut string-pad <> 2 #\0)
                           number->string))
-            (h   (hash (operating-system-services os) 3600)))
+            (h   (hash (map service-name (operating-system-services os))
+                       3600)))
         (bytevector->uuid
          (string->iso9660-uuid
           (string-append "1970-01-01-"
                          (pad (hash (operating-system-host-name os) 24)) "-"
                          (pad (quotient h 60)) "-"
                          (pad (modulo h 60)) "-"
-                         (pad (hash (operating-system-file-systems os) 100))))
+                         (pad (hash (map file-system-digest
+                                         (operating-system-file-systems os))
+                                    100))))
          'iso9660))
       (bytevector->uuid
        (uint-list->bytevector
@@ -557,9 +572,9 @@ TYPE (one of 'iso9660 or 'dce).  Return a UUID object."
                     (- (expt 2 32) 1))
               (hash (operating-system-host-name os)
                     (- (expt 2 32) 1))
-              (hash (operating-system-services os)
+              (hash (map service-name (operating-system-services os))
                     (- (expt 2 32) 1))
-              (hash (operating-system-file-systems os)
+              (hash (map file-system-digest (operating-system-file-systems os))
                     (- (expt 2 32) 1)))
         (endianness little)
         4)