1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
6 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
7 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
9 ;;; This file is part of GNU Guix.
11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
12 ;;; under the terms of the GNU General Public License as published by
13 ;;; the Free Software Foundation; either version 3 of the License, or (at
14 ;;; your option) any later version.
16 ;;; GNU Guix is distributed in the hope that it will be useful, but
17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;;; GNU General Public License for more details.
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
24 (define-module (gnu system vm)
25 #:use-module (guix config)
26 #:use-module (guix store)
27 #:use-module (guix gexp)
28 #:use-module (guix derivations)
29 #:use-module (guix packages)
30 #:use-module (guix monads)
31 #:use-module (guix records)
32 #:use-module (guix modules)
33 #:use-module (guix utils)
34 #:use-module (gcrypt hash)
35 #:use-module (guix base32)
36 #:use-module ((guix self) #:select (make-config.scm))
38 #:use-module ((gnu build vm)
39 #:select (qemu-command))
40 #:use-module (gnu packages base)
41 #:use-module (gnu packages bootloaders)
42 #:use-module (gnu packages cdrom)
43 #:use-module (gnu packages compression)
44 #:use-module (gnu packages guile)
45 #:autoload (gnu packages gnupg) (guile-gcrypt)
46 #:use-module (gnu packages gawk)
47 #:use-module (gnu packages bash)
48 #:use-module (gnu packages less)
49 #:use-module (gnu packages virtualization)
50 #:use-module (gnu packages disk)
51 #:use-module (gnu packages zile)
52 #:use-module (gnu packages linux)
53 #:use-module (gnu packages admin)
55 #:use-module (gnu bootloader)
56 #:use-module (gnu bootloader grub)
57 #:use-module (gnu system shadow)
58 #:use-module (gnu system pam)
59 #:use-module (gnu system linux-container)
60 #:use-module (gnu system linux-initrd)
61 #:use-module (gnu bootloader)
62 #:use-module (gnu system file-systems)
63 #:use-module (gnu system)
64 #:use-module (gnu services)
65 #:use-module (gnu services base)
66 #:use-module (gnu system uuid)
68 #:use-module (srfi srfi-1)
69 #:use-module (srfi srfi-26)
70 #:use-module (rnrs bytevectors)
71 #:use-module (ice-9 match)
73 #:export (expression->derivation-in-linux-vm
75 virtualized-operating-system
78 system-qemu-image/shared-store
79 system-qemu-image/shared-store-script
80 system-disk-image-in-vm
89 ;;; Tools to evaluate build expressions within virtual machines.
93 (define %linux-vm-file-systems
94 ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with
97 ;; The 9p documentation says that cache=loose is "intended for exclusive,
98 ;; read-only mounts", without additional details. It's much faster than the
99 ;; default cache=none, especially when copying and registering store items.
100 ;; Thus, use cache=loose, except for /xchg where we want to ensure
103 (mount-point (%store-prefix))
106 (needed-for-boot? #t)
108 (options "trans=virtio,cache=loose")
111 (mount-point "/xchg")
114 (needed-for-boot? #t)
115 (options "trans=virtio")
121 (needed-for-boot? #t)
122 (options "trans=virtio,cache=loose")
126 ;; Select (guix …) and (gnu …) modules, except (guix config).
129 (('guix rest ...) #t)
133 (define gcrypt-sqlite3&co
134 ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
135 (append-map (lambda (package)
137 (match (package-transitive-propagated-inputs package)
138 (((labels packages) ...)
140 (list guile-gcrypt guile-sqlite3)))
142 (define* (expression->derivation-in-linux-vm name exp
144 (system (%current-system)) target
152 %linux-vm-file-systems)
154 (single-file-output? #f)
155 (make-disk-image? #f)
156 (references-graphs #f)
158 (disk-image-format "qcow2")
159 (disk-image-size 'guess)
162 "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
163 derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
164 virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
165 9p share of the store, the '/xchg' where EXP should put its output file(s),
166 and a 9p share of /tmp.
168 If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
169 Otherwise, copy the contents of /xchg to a new directory OUTPUT.
171 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
172 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
173 return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
174 based on the size of the closure of REFERENCES-GRAPHS.
176 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
177 pairs, as for `derivation'. The files containing the reference graphs are
178 made available under the /xchg CIFS share.
180 SUBSTITUTABLE? determines whether the returned derivation should be marked as
183 (program-file "builder-in-linux-vm" exp))
186 ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
187 ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
188 ;; Guile, which it couldn't do using the statically-linked guile used in
189 ;; the initrd. See example at
190 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
191 (program-file "linux-vm-loader"
192 ;; Communicate USER-BUILDER's exit status via /xchg so that
193 ;; the host can distinguish between success, failure, and
195 #~(let ((status (system* #$user-builder)))
196 (call-with-output-file "/xchg/.exit-status"
198 (write status port)))
202 (define-syntax-rule (check predicate)
203 (let-system (system target)
204 (predicate (or target system))))
206 (let ((initrd (or initrd
207 (base-initrd file-systems
208 #:on-error 'backtrace
210 #:linux-modules %base-initrd-modules
211 #:qemu-networking? #t))))
214 ;; Code that launches the VM that evaluates EXP.
215 (with-extensions gcrypt-sqlite3&co
216 (with-imported-modules `(,@(source-module-closure
219 #:select? not-config?)
221 ;; For consumption by (gnu store database).
222 ((guix config) => ,(make-config.scm)))
224 (use-modules (guix build utils)
227 (let* ((native-inputs
228 '#+(list qemu (canonical-package coreutils)))
229 (linux (string-append #$linux "/"
230 #$(system-linux-image-file-name)))
233 (graphs '#$(match references-graphs
234 (((graph-files . _) ...) graph-files)
236 (target #$(let-system (system target)
238 (size #$(if (eq? 'guess disk-image-size)
239 #~(+ (* 70 (expt 2 20)) ;ESP
240 (estimated-partition-size graphs))
243 (set-path-environment-variable "PATH" '("bin") native-inputs)
245 (load-in-linux-vm loader
247 #:linux linux #:initrd initrd
248 #:qemu (qemu-command target)
249 #:memory-size #$memory-size
250 #:make-disk-image? #$make-disk-image?
251 #:single-file-output? #$single-file-output?
252 #:target-arm32? #$(check target-arm32?)
253 #:target-aarch64? #$(check target-aarch64?)
254 #:disk-image-format #$disk-image-format
255 #:disk-image-size size
256 #:references-graphs graphs))))))
258 (gexp->derivation name builder
259 ;; TODO: Require the "kvm" feature.
263 #:guile-for-build guile-for-build
264 #:references-graphs references-graphs
265 #:substitutable? substitutable?)))
267 (define (has-guix-service-type? os)
268 "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
269 (not (not (find (lambda (service)
270 (eq? (service-kind service) guix-service-type))
271 (operating-system-services os)))))
273 (define* (qemu-image #:key
275 (system (%current-system))
276 (target (%current-target-system))
278 (disk-image-size 'guess)
279 (disk-image-format "qcow2")
280 (file-system-type "ext4")
281 (file-system-options '())
282 (device-nodes 'linux)
283 (extra-directives '())
289 (register-closures? (has-guix-service-type? os))
293 "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
294 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
295 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
296 partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
297 partition (a UUID object). FILE-SYSTEM-OPTIONS is an optional list of
298 command-line options passed to 'mkfs.ext4' (or similar).
300 The returned image is a full disk image that runs OS-DERIVATION,
301 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
302 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
304 INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
305 all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
306 register INPUTS in the store database of the image so that Guix can be used in
307 the image. By default, REGISTER-CLOSURES? is set to true only if a service of
308 type GUIX-SERVICE-TYPE is present in the services definition of the operating
311 When DEVICE-NODES is 'linux, create Linux-device block and character devices
312 under /dev. When it is 'hurd, do Hurdish things.
314 EXTRA-DIRECTIVES is an optional list of directives to populate the root file
315 system that is passed to 'populate-root-file-system'."
317 (and register-closures?
318 (local-file (search-path %load-path
319 "guix/store/schema.sql"))))
321 (expression->derivation-in-linux-vm
323 (with-extensions gcrypt-sqlite3&co
324 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
325 (gnu build bootloader)
326 (guix store database)
328 #:select? not-config?)
329 ((guix config) => ,(make-config.scm)))
331 (use-modules (gnu build bootloader)
333 ((gnu build linux-boot)
334 #:select (make-essential-device-nodes
335 make-hurd-device-nodes))
336 (guix store database)
339 (ice-9 binary-ports))
341 (sql-schema #$schema)
343 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
344 (setenv "GUIX_LOCPATH"
345 #+(file-append glibc-utf8-locales "/lib/locale"))
346 (setlocale LC_ALL "en_US.utf8")
349 '#$(append (list parted e2fsprogs dosfstools)
350 (map canonical-package
351 (list sed grep coreutils findutils gawk))))
353 ;; This variable is unused but allows us to add INPUTS-TO-COPY
356 '#$(map (match-lambda
358 ((name thing output) `(,thing ,output)))
361 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
363 (let* ((graphs '#$(match inputs
366 (initialize (root-partition-initializer
367 #:extra-directives '#$extra-directives
369 #:copy-closures? #$copy-inputs?
370 #:register-closures? #$register-closures?
371 #:system-directory #$os
374 #$(match device-nodes
375 ('linux #~make-essential-device-nodes)
376 ('hurd #~make-hurd-device-nodes))
378 ;; Disable deduplication to speed things up,
379 ;; and because it doesn't help much for a
380 ;; single system generation.
382 (root-size #$(if (eq? 'guess disk-image-size)
384 ;; Minimum 20 MiB root size
386 (estimated-partition-size
387 (map (cut string-append "/xchg/" <>)
390 (* 50 (expt 2 20)))))
395 (label #$file-system-label)
396 (uuid #$(and=> file-system-uuid
398 (file-system #$file-system-type)
399 (file-system-options '#$file-system-options)
401 (initializer initialize)))
402 ;; Append a small EFI System Partition for use with UEFI
403 ;; bootloaders if we are not targeting ARM because UEFI
404 ;; support in U-Boot is experimental.
406 ;; FIXME: ‘target-arm?’ may be not operate on the right
407 ;; system/target values. Rewrite using ‘let-system’ when
412 ;; The standalone grub image is about 10MiB, but
413 ;; leave some room for custom or multiple images.
414 (size (* 40 (expt 2 20)))
415 (label "GNU-ESP") ;cosmetic only
416 ;; Use "vfat" here since this property is used
417 ;; when mounting. The actual FAT-ness is based
418 ;; on file system size (16 in this case).
421 (grub-efi #$(and (not (target-arm?)) grub-efi)))
422 (initialize-hard-disk "/dev/vda"
423 #:partitions partitions
426 #$(bootloader-package bootloader)
427 #:bootcfg #$bootcfg-drv
429 #$(bootloader-configuration-file bootloader)
430 #:bootloader-installer
431 #$(bootloader-installer bootloader)))))))
434 #:make-disk-image? #t
435 #:disk-image-size disk-image-size
436 #:disk-image-format disk-image-format
437 #:references-graphs inputs
438 #:substitutable? substitutable?))
440 (define* (system-docker-image os
442 (name "guix-docker-image")
443 (register-closures? (has-guix-service-type? os))
445 "Build a docker image. OS is the desired <operating-system>. NAME is the
446 base name to use for the output file. When SHARED-NETWORK? is true, assume
447 that the container will share network with the host and thus doesn't need a
448 DHCP client, nscd, and so on.
450 When REGISTER-CLOSURES? is true, register the closure of OS with Guix in the
451 resulting Docker image. By default, REGISTER-CLOSURES? is set to true only if
452 a service of type GUIX-SERVICE-TYPE is present in the services definition of
453 the operating system."
455 (and register-closures?
456 (local-file (search-path %load-path
457 "guix/store/schema.sql"))))
460 ;; Program that runs the boot script of OS, which in turn starts shepherd.
461 (program-file "boot-program"
462 #~(let ((system (cadr (command-line))))
463 (setenv "GUIX_NEW_SYSTEM" system)
464 (execl #$(file-append guile-2.2 "/bin/guile")
465 "guile" "--no-auto-compile"
466 (string-append system "/boot")))))
469 (let ((os (operating-system-with-gc-roots
470 (containerized-operating-system os '()
473 (list boot-program)))
474 (name (string-append name ".tar.gz"))
475 (graph "system-graph"))
477 (with-extensions (cons guile-json-3 ;for (guix docker)
478 gcrypt-sqlite3&co) ;for (guix store database)
479 (with-imported-modules `(,@(source-module-closure
481 (guix store database)
483 (guix build store-copy)
485 #:select? not-config?)
486 ((guix config) => ,(make-config.scm)))
488 (use-modules (guix docker)
492 (guix build store-copy)
493 (guix store database))
495 ;; Set the SQL schema location.
496 (sql-schema #$schema)
498 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
499 (setenv "GUIX_LOCPATH"
500 #+(file-append glibc-utf8-locales "/lib/locale"))
501 (setlocale LC_ALL "en_US.utf8")
503 (let* (;; This initializer requires elevated privileges that are
504 ;; not normally available in the build environment (e.g.,
505 ;; it needs to create device nodes). In order to obtain
506 ;; such privileges, we run it as root in a VM.
507 (initialize (root-partition-initializer
508 #:closures '(#$graph)
509 #:register-closures? #$register-closures?
510 #:system-directory #$os
511 ;; De-duplication would fail due to
512 ;; cross-device link errors, so don't do it.
514 ;; Even as root in a VM, the initializer would fail due to
515 ;; lack of privileges if we use a root-directory that is on
516 ;; a file system that is shared with the host (e.g., /tmp).
517 (root-directory "/guixsd-system-root"))
518 (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
519 (mkdir root-directory)
520 (initialize root-directory)
522 (string-append "/xchg/" #$name) ;; The output file.
523 (cons* root-directory
525 (call-with-input-file
526 (string-append "/xchg/" #$graph)
527 read-reference-graph)))
529 #:entry-point '(#$boot-program #$os)
530 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
531 #:creation-time (make-time time-utc 0 1)
532 #:transformations `((,root-directory -> ""))))))))
534 (expression->derivation-in-linux-vm
536 #:make-disk-image? #f
537 #:single-file-output? #t
538 #:references-graphs `((,graph ,os)))))
542 ;;; VM and disk images.
545 (define* (system-disk-image-in-vm os
548 (file-system-type "ext4")
549 (disk-image-size (* 900 (expt 2 20)))
552 "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
553 system described by OS. Said image can be copied on a USB stick as is. When
554 VOLATILE? is true, the root file system is made volatile; this is useful
555 to USB sticks meant to be read-only.
557 SUBSTITUTABLE? determines whether the returned derivation should be marked as
562 (define (root-uuid os)
563 ;; UUID of the root file system, computed in a deterministic fashion.
564 ;; This is what we use to locate the root file system so it has to be
565 ;; different from the user's own file system UUIDs.
566 (operating-system-uuid os 'dce))
568 (define file-systems-to-keep
570 (string=? (file-system-mount-point fs) "/"))
571 (operating-system-file-systems os)))
573 (let* ((os (operating-system (inherit os)
574 ;; Since this is meant to be used on real hardware, don't
575 ;; install QEMU networking or anything like that. Assume USB
576 ;; mass storage devices (usb-storage.ko) are available.
577 (initrd (lambda (file-systems . rest)
578 (apply (operating-system-initrd os)
580 #:volatile-root? volatile?
583 (bootloader (operating-system-bootloader os))
585 ;; Force our own root file system. (We need a "/" file system
586 ;; to call 'root-uuid'.)
587 (file-systems (cons (file-system
589 (device "/dev/placeholder")
590 (type file-system-type))
591 file-systems-to-keep))))
592 (uuid (root-uuid os))
593 (os (operating-system
595 (file-systems (cons (file-system
598 (type file-system-type))
599 file-systems-to-keep))))
600 (bootcfg (operating-system-bootcfg os)))
601 (qemu-image #:name name
603 #:bootcfg-drv bootcfg
604 #:bootloader (bootloader-configuration-bootloader
605 (operating-system-bootloader os))
606 #:disk-image-size disk-image-size
607 #:disk-image-format "raw"
608 #:file-system-type file-system-type
609 #:file-system-label root-label
610 #:file-system-uuid uuid
612 #:inputs `(("system" ,os)
613 ("bootcfg" ,bootcfg))
614 #:substitutable? substitutable?)))
616 (define* (system-qemu-image os
618 (file-system-type "ext4")
619 (disk-image-size (* 900 (expt 2 20))))
620 "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
621 of the GNU system as described by OS."
622 (define file-systems-to-keep
623 ;; Keep only file systems other than root and not normally bound to real
626 (let ((target (file-system-mount-point fs))
627 (source (file-system-device fs)))
628 (or (string=? target "/")
629 (string-prefix? "/dev/" source))))
630 (operating-system-file-systems os)))
633 ;; UUID of the root file system.
634 (operating-system-uuid os
635 (if (string=? file-system-type "iso9660")
640 (let* ((os (operating-system (inherit os)
641 ;; Assume we have an initrd with the whole QEMU shebang.
643 ;; Force our own root file system. Refer to it by UUID so that
644 ;; it works regardless of how the image is used ("qemu -hda",
646 (file-systems (cons (file-system
649 (type file-system-type))
650 file-systems-to-keep))))
651 (bootcfg (operating-system-bootcfg os)))
653 #:bootcfg-drv bootcfg
654 #:bootloader (bootloader-configuration-bootloader
655 (operating-system-bootloader os))
656 #:disk-image-size disk-image-size
657 #:file-system-type file-system-type
658 #:file-system-uuid root-uuid
659 #:inputs `(("system" ,os)
660 ("bootcfg" ,bootcfg))
665 ;;; VMs that share file systems with the host.
668 (define (file-system->mount-tag fs)
669 "Return a 9p mount tag for host file system FS."
670 ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
671 ;; slashes, and cannot start with '_'. Compute an identifier that
672 ;; corresponds to the rules.
674 (string-drop (bytevector->base32-string
675 (sha1 (string->utf8 fs)))
678 (define (mapping->file-system mapping)
679 "Return a 9p file system that realizes MAPPING."
681 (($ <file-system-mapping> source target writable?)
684 (device (file-system->mount-tag source))
686 (flags (if writable? '() '(read-only)))
687 (options "trans=virtio,cache=loose")
689 (create-mount-point? #t)))))
691 (define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
692 "Return an operating system based on OS suitable for use in a virtualized
693 environment with the store shared with the host. MAPPINGS is a list of
694 <file-system-mapping> to realize in the virtualized OS."
695 (define user-file-systems
696 ;; Remove file systems that conflict with those added below, or that are
697 ;; normally bound to real devices.
699 (let ((target (file-system-mount-point fs))
700 (source (file-system-device fs)))
701 (or (string=? target (%store-prefix))
702 (string=? target "/")
703 (and (string? source)
704 (string-prefix? "/dev/" source))
706 ;; Labels and UUIDs are necessarily invalid in the VM.
707 (and (file-system-mount? fs)
708 (or (file-system-label? source)
710 (operating-system-file-systems os)))
712 (define virtual-file-systems
718 (append (map mapping->file-system mappings)
721 (operating-system (inherit os)
723 ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
724 ;; force the traditional i386/BIOS method.
725 ;; See <https://bugs.gnu.org/28768>.
726 (bootloader (bootloader-configuration
727 (inherit (operating-system-bootloader os))
728 (bootloader grub-bootloader)
729 (target "/dev/vda")))
731 (initrd (lambda (file-systems . rest)
732 (apply (operating-system-initrd os)
740 ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
741 ;; since that would lead the bootloader config to look for the kernel and
743 (file-systems (if full-boot?
747 (inherit (mapping->file-system %store-mapping))
748 (needed-for-boot? #t))
749 virtual-file-systems)))))
751 (define* (system-qemu-image/shared-store
755 (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
756 "Return a derivation that builds a QEMU image of OS that shares its store
759 When FULL-BOOT? is true, return an image that does a complete boot sequence,
760 bootloaded included; thus, make a disk image that contains everything the
761 bootloader refers to: OS kernel, initrd, bootloader data, etc."
763 ;; Use a fixed UUID to improve determinism.
764 (operating-system-uuid os 'dce))
767 (operating-system-bootcfg os))
769 ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
770 ;; BOOTCFG and all its dependencies, including the output of OS.
771 ;; This is more than needed (we only need the kernel, initrd, GRUB for its
772 ;; font, and the background image), but it's hard to filter that.
774 #:bootcfg-drv bootcfg
775 #:bootloader (bootloader-configuration-bootloader
776 (operating-system-bootloader os))
777 #:disk-image-size disk-image-size
778 #:file-system-uuid root-uuid
779 #:inputs (if full-boot?
780 `(("bootcfg" ,bootcfg))
783 ;; XXX: Passing #t here is too slow, so let it off by default.
784 #:register-closures? #f
785 #:copy-inputs? full-boot?))
787 (define* (common-qemu-options image shared-fs)
788 "Return the a string-value gexp with the common QEMU options to boot IMAGE,
789 with '-virtfs' options for the host file systems listed in SHARED-FS."
791 (define (virtfs-option fs)
792 #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
793 #$fs #$(file-system->mount-tag fs)))
795 #~(;; Only enable kvm if we see /dev/kvm exists.
796 ;; This allows users without hardware virtualization to still use these
798 #$@(if (file-exists? "/dev/kvm")
803 "-nic" "user,model=virtio-net-pci"
804 "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
805 "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
807 #$@(map virtfs-option shared-fs)
809 (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
812 (define* (system-qemu-image/shared-store-script os
820 (* (if full-boot? 500 70)
823 "Return a derivation that builds a script to run a virtual machine image of
824 OS that shares its store with the host. The virtual machine runs with
825 MEMORY-SIZE MiB of memory.
827 MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
828 systems into the guest.
830 When FULL-BOOT? is true, the returned script runs everything starting from the
831 bootloader; otherwise it directly starts the operating system kernel. The
832 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
833 it is mostly useful when FULL-BOOT? is true."
834 (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
835 (image (system-qemu-image/shared-store
837 #:full-boot? full-boot?
838 #:disk-image-size disk-image-size)))
839 (define kernel-arguments
840 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
841 #+@(operating-system-kernel-arguments os "/dev/vda1")))
844 #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
847 #~("-kernel" #$(operating-system-kernel-file os)
848 "-initrd" #$(file-append os "/initrd")
849 (format #f "-append ~s"
850 (string-join #$kernel-arguments " "))))
851 #$@(common-qemu-options image
852 (map file-system-mapping-source
853 (cons %store-mapping mappings)))
854 "-m " (number->string #$memory-size)
858 #~(call-with-output-file #$output
860 (format port "#!~a~% exec ~a \"$@\"~%"
861 #$(file-append bash "/bin/sh")
862 (string-join #$qemu-exec " "))
863 (chmod port #o555))))
865 (gexp->derivation "run-vm.sh" builder)))
869 ;;; High-level abstraction.
872 (define-record-type* <virtual-machine> %virtual-machine
875 (operating-system virtual-machine-operating-system) ;<operating-system>
876 (qemu virtual-machine-qemu ;<package>
878 (graphic? virtual-machine-graphic? ;Boolean
880 (memory-size virtual-machine-memory-size ;integer (MiB)
882 (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
884 (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
887 (define-syntax virtual-machine
889 "Declare a virtual machine running the specified OS, with the given
892 (%virtual-machine (operating-system os)))
894 (%virtual-machine fields ...))))
896 (define (port-forwardings->qemu-options forwardings)
897 "Return the QEMU option for the given port FORWARDINGS as a string, where
898 FORWARDINGS is a list of host-port/guest-port pairs."
901 ((host-port . guest-port)
902 (string-append "hostfwd=tcp::"
903 (number->string host-port)
904 "-:" (number->string guest-port))))
908 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
910 ;; XXX: SYSTEM and TARGET are ignored.
912 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
913 (system-qemu-image/shared-store-script os
916 #:memory-size memory-size
919 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size
922 `("-nic" ,(string-append
923 "user,model=virtio-net-pci,"
924 (port-forwardings->qemu-options forwardings)))))
925 (system-qemu-image/shared-store-script os
928 #:memory-size memory-size
931 #:options options)))))