aboutsummaryrefslogtreecommitdiff
path: root/gnu/system/vm.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system/vm.scm')
-rw-r--r--gnu/system/vm.scm125
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))
'())