Merge branch 'master' into staging

1 files changed, 68 insertions, 57 deletions

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 09a11af863..544c0e294d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,7 +23,6 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
-  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -126,6 +125,8 @@
                                              (env-vars '())
                                              (guile-for-build
                                               (%guile-for-build))
+                                             (file-systems
+                                              %linux-vm-file-systems)
 
                                              (single-file-output? #f)
                                              (make-disk-image? #f)
@@ -135,8 +136,9 @@
                                              (disk-image-size 'guess))
   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
 derivation).  The virtual machine runs with MEMORY-SIZE MiB of memory.  In the
-virtual machine, EXP has access to all its inputs from the store; it should
-put its output file(s) in the '/xchg' directory.
+virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
+9p share of the store, the '/xchg' where EXP should put its output file(s),
+and a 9p share of /tmp.
 
 If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
 Otherwise, copy the contents of /xchg to a new directory OUTPUT.
@@ -156,7 +158,7 @@ made available under the /xchg CIFS share."
        (coreutils -> (canonical-package coreutils))
        (initrd       (if initrd                   ; use the default initrd?
                          (return initrd)
-                         (base-initrd %linux-vm-file-systems
+                         (base-initrd file-systems
                                       #:on-error 'backtrace
                                       #:linux linux
                                       #:linux-modules %base-initrd-modules
@@ -258,6 +260,14 @@ INPUTS is a list of inputs (as for packages)."
                                                       uuid-bytevector))
            (reboot))))
    #:system system
+
+   ;; Keep a local file system for /tmp so that we can populate it directly as
+   ;; root and have files owned by root.  See <https://bugs.gnu.org/31752>.
+   #:file-systems (remove (lambda (file-system)
+                            (string=? (file-system-mount-point file-system)
+                                      "/tmp"))
+                          %linux-vm-file-systems)
+
    #:make-disk-image? #f
    #:single-file-output? #t
    #:references-graphs inputs))
@@ -411,58 +421,57 @@ should set REGISTER-CLOSURES? to #f."
                      (eval-when (expand load eval)
                        (define %libgcrypt
                          #+(file-append libgcrypt "/lib/libgcrypt"))))))
+
   (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
                       (name -> (string-append name ".tar.gz"))
                       (graph -> "system-graph"))
     (define build
-      (with-imported-modules `(,@(source-module-closure '((guix docker)
-                                                          (guix build utils)
-                                                          (gnu build vm))
-                                                        #:select? not-config?)
-                               (guix build store-copy)
-                               ((guix config) => ,config))
-        #~(begin
-            ;; Guile-JSON is required by (guix docker).
-            (add-to-load-path
-             (string-append #+guile-json "/share/guile/site/"
-                            (effective-version)))
-            (use-modules (guix docker)
-                         (guix build utils)
-                         (gnu build vm)
-                         (srfi srfi-19)
-                         (guix build store-copy))
-
-            (let* ((inputs '#$(append (list tar)
-                                      (if register-closures?
-                                          (list guix)
-                                          '())))
-                   ;; This initializer requires elevated privileges that are
-                   ;; not normally available in the build environment (e.g.,
-                   ;; it needs to create device nodes).  In order to obtain
-                   ;; such privileges, we run it as root in a VM.
-                   (initialize (root-partition-initializer
-                                #:closures '(#$graph)
-                                #:register-closures? #$register-closures?
-                                #:system-directory #$os-drv
-                                ;; De-duplication would fail due to
-                                ;; cross-device link errors, so don't do it.
-                                #:deduplicate? #f))
-                   ;; Even as root in a VM, the initializer would fail due to
-                   ;; lack of privileges if we use a root-directory that is on
-                   ;; a file system that is shared with the host (e.g., /tmp).
-                   (root-directory "/guixsd-system-root"))
-              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-              (mkdir root-directory)
-              (initialize root-directory)
-              (build-docker-image
-               (string-append "/xchg/" #$name) ;; The output file.
-               (cons* root-directory
-                      (call-with-input-file (string-append "/xchg/" #$graph)
-                        read-reference-graph))
-               #$os-drv
-               #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-               #:creation-time (make-time time-utc 0 1)
-               #:transformations `((,root-directory -> "")))))))
+      (with-extensions (list guile-json)          ;for (guix docker)
+        (with-imported-modules `(,@(source-module-closure
+                                    '((guix docker)
+                                      (guix build utils)
+                                      (gnu build vm))
+                                    #:select? not-config?)
+                                 (guix build store-copy)
+                                 ((guix config) => ,config))
+          #~(begin
+              (use-modules (guix docker)
+                           (guix build utils)
+                           (gnu build vm)
+                           (srfi srfi-19)
+                           (guix build store-copy))
+
+              (let* ((inputs '#$(append (list tar)
+                                        (if register-closures?
+                                            (list guix)
+                                            '())))
+                     ;; This initializer requires elevated privileges that are
+                     ;; not normally available in the build environment (e.g.,
+                     ;; it needs to create device nodes).  In order to obtain
+                     ;; such privileges, we run it as root in a VM.
+                     (initialize (root-partition-initializer
+                                  #:closures '(#$graph)
+                                  #:register-closures? #$register-closures?
+                                  #:system-directory #$os-drv
+                                  ;; De-duplication would fail due to
+                                  ;; cross-device link errors, so don't do it.
+                                  #:deduplicate? #f))
+                     ;; Even as root in a VM, the initializer would fail due to
+                     ;; lack of privileges if we use a root-directory that is on
+                     ;; a file system that is shared with the host (e.g., /tmp).
+                     (root-directory "/guixsd-system-root"))
+                (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+                (mkdir root-directory)
+                (initialize root-directory)
+                (build-docker-image
+                 (string-append "/xchg/" #$name) ;; The output file.
+                 (cons* root-directory
+                        (call-with-input-file (string-append "/xchg/" #$graph)
+                          read-reference-graph))
+                 #$os-drv
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:transformations `((,root-directory -> ""))))))))
     (expression->derivation-in-linux-vm
      name
      ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
@@ -571,7 +580,6 @@ to USB sticks meant to be read-only."
               (file-systems (cons (file-system
                                     (mount-point "/")
                                     (device root-uuid)
-                                    (title 'uuid)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
 
@@ -636,7 +644,6 @@ of the GNU system as described by OS."
               (file-systems (cons (file-system
                                     (mount-point "/")
                                     (device root-uuid)
-                                    (title 'uuid)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
     (mlet* %store-monad
@@ -693,13 +700,12 @@ environment with the store shared with the host.  MAPPINGS is a list of
                     (source (file-system-device fs)))
                 (or (string=? target (%store-prefix))
                     (string=? target "/")
-                    (and (eq? 'device (file-system-title fs))
+                    (and (string? source)
                          (string-prefix? "/dev/" source))
 
                     ;; Labels and UUIDs are necessarily invalid in the VM.
                     (and (file-system-mount? fs)
-                         (or (eq? 'label (file-system-title fs))
-                             (eq? 'uuid (file-system-title fs))
+                         (or (file-system-label? source)
                              (uuid? source))))))
             (operating-system-file-systems os)))
 
@@ -752,6 +758,10 @@ with the host.
 When FULL-BOOT? is true, return an image that does a complete boot sequence,
 bootloaded included; thus, make a disk image that contains everything the
 bootloader refers to: OS kernel, initrd, bootloader data, etc."
+  (define root-uuid
+    ;; Use a fixed UUID to improve determinism.
+    (operating-system-uuid os 'dce))
+
   (mlet* %store-monad ((os-drv   (operating-system-derivation os))
                        (bootcfg  (operating-system-bootcfg os)))
     ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
@@ -763,6 +773,7 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc."
                 #:bootloader (bootloader-configuration-bootloader
                               (operating-system-bootloader os))
                 #:disk-image-size disk-image-size
+                #:file-system-uuid root-uuid
                 #:inputs (if full-boot?
                              `(("bootcfg" ,bootcfg))
                              '())