From 1540075c790dfaeff52c93392f2fc63b9e23b77e Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 7 Sep 2018 09:50:26 +0200
Subject: vm: Make UUID computation really deterministic.

Fixes <https://bugs.gnu.org/32652>.

* gnu/system/vm.scm (operating-system-uuid)[service-name,
file-system-digest]: New procedures.
Map these over services and file systems and hash the result.
* tests/guix-system.sh: Add test.
---
 gnu/system/vm.scm    | 33 +++++++++++++++++++++++++++++----
 tests/guix-system.sh |  8 ++++++++
 2 files changed, 37 insertions(+), 4 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 3898872a46..91e117b9f3 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -529,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
@@ -547,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)
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 36ba5fbd5f..a129efdfcb 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -232,6 +232,14 @@ guix system build "$tmpfile" -d | grep '\.drv$'
 guix system vm "$tmpfile" -d	      # succeeds
 guix system vm "$tmpfile" -d | grep '\.drv$'
 
+# Make sure the behavior is deterministic (<https://bugs.gnu.org/32652>).
+drv1="`guix system vm "$tmpfile" -d`"
+drv2="`guix system vm "$tmpfile" -d`"
+test "$drv1" = "$drv2"
+drv1="`guix system disk-image --file-system-type=iso9660 "$tmpfile" -d`"
+drv2="`guix system disk-image --file-system-type=iso9660 "$tmpfile" -d`"
+test "$drv1" = "$drv2"
+
 make_user_config "group-that-does-not-exist" "users"
 if guix system build "$tmpfile" -n 2> "$errorfile"
 then false
-- 
cgit v1.2.3