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
88 ;;; Tools to evaluate build expressions within virtual machines.
92 (define %linux-vm-file-systems
93 ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with
96 ;; The 9p documentation says that cache=loose is "intended for exclusive,
97 ;; read-only mounts", without additional details. It's much faster than the
98 ;; default cache=none, especially when copying and registering store items.
99 ;; Thus, use cache=loose, except for /xchg where we want to ensure
102 (mount-point (%store-prefix))
105 (needed-for-boot? #t)
107 (options "trans=virtio,cache=loose")
110 (mount-point "/xchg")
113 (needed-for-boot? #t)
114 (options "trans=virtio")
120 (needed-for-boot? #t)
121 (options "trans=virtio,cache=loose")
125 ;; Select (guix …) and (gnu …) modules, except (guix config).
128 (('guix rest ...) #t)
132 (define gcrypt-sqlite3&co
133 ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
134 (append-map (lambda (package)
136 (match (package-transitive-propagated-inputs package)
137 (((labels packages) ...)
139 (list guile-gcrypt guile-sqlite3)))
141 (define* (expression->derivation-in-linux-vm name exp
143 (system (%current-system))
151 %linux-vm-file-systems)
153 (single-file-output? #f)
154 (make-disk-image? #f)
155 (references-graphs #f)
157 (disk-image-format "qcow2")
158 (disk-image-size 'guess)
161 "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
162 derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
163 virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
164 9p share of the store, the '/xchg' where EXP should put its output file(s),
165 and a 9p share of /tmp.
167 If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
168 Otherwise, copy the contents of /xchg to a new directory OUTPUT.
170 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
171 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
172 return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
173 based on the size of the closure of REFERENCES-GRAPHS.
175 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
176 pairs, as for `derivation'. The files containing the reference graphs are
177 made available under the /xchg CIFS share.
179 SUBSTITUTABLE? determines whether the returned derivation should be marked as
182 (program-file "builder-in-linux-vm" exp))
185 ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
186 ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
187 ;; Guile, which it couldn't do using the statically-linked guile used in
188 ;; the initrd. See example at
189 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
190 (program-file "linux-vm-loader"
191 ;; Communicate USER-BUILDER's exit status via /xchg so that
192 ;; the host can distinguish between success, failure, and
194 #~(let ((status (system* #$user-builder)))
195 (call-with-output-file "/xchg/.exit-status"
197 (write status port)))
201 (define-syntax-rule (check predicate)
202 (let-system (system target)
203 (predicate (or target system))))
205 (let ((initrd (or initrd
206 (base-initrd file-systems
207 #:on-error 'backtrace
209 #:linux-modules %base-initrd-modules
210 #:qemu-networking? #t))))
213 ;; Code that launches the VM that evaluates EXP.
214 (with-extensions gcrypt-sqlite3&co
215 (with-imported-modules `(,@(source-module-closure
218 #:select? not-config?)
220 ;; For consumption by (gnu store database).
221 ((guix config) => ,(make-config.scm)))
223 (use-modules (guix build utils)
226 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded
227 ;; by 'estimated-partition-size' below.
228 (setenv "GUIX_LOCPATH"
229 #+(file-append glibc-utf8-locales "/lib/locale"))
230 (setlocale LC_ALL "en_US.utf8")
232 (let* ((native-inputs
233 '#+(list qemu (canonical-package coreutils)))
234 (linux (string-append
236 #+(system-linux-image-file-name system)))
239 (graphs '#$(match references-graphs
240 (((graph-files . _) ...) graph-files)
242 (target #$(let-system (system target)
244 (size #$(if (eq? 'guess disk-image-size)
245 #~(+ (* 70 (expt 2 20)) ;ESP
246 (estimated-partition-size graphs))
249 (set-path-environment-variable "PATH" '("bin") native-inputs)
251 (load-in-linux-vm loader
253 #:linux linux #:initrd initrd
254 #:qemu (qemu-command target)
255 #:memory-size #$memory-size
256 #:make-disk-image? #$make-disk-image?
257 #:single-file-output? #$single-file-output?
258 #:disk-image-format #$disk-image-format
259 #:disk-image-size size
260 #:references-graphs graphs))))))
262 (gexp->derivation name builder
263 ;; TODO: Require the "kvm" feature.
265 #:target #f ;EXP is always executed natively
267 #:guile-for-build guile-for-build
268 #:references-graphs references-graphs
269 #:substitutable? substitutable?)))
271 (define (has-guix-service-type? os)
272 "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
273 (not (not (find (lambda (service)
274 (eq? (service-kind service) guix-service-type))
275 (operating-system-services os)))))
277 (define* (qemu-image #:key
279 (system (%current-system))
280 (target (%current-target-system))
282 (disk-image-size 'guess)
283 (disk-image-format "qcow2")
284 (file-system-type "ext4")
285 (file-system-options '())
286 (device-nodes 'linux)
287 (extra-directives '())
293 (register-closures? (has-guix-service-type? os))
297 "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
298 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
299 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
300 partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
301 partition (a UUID object). FILE-SYSTEM-OPTIONS is an optional list of
302 command-line options passed to 'mkfs.ext4' (or similar).
304 The returned image is a full disk image that runs OS-DERIVATION,
305 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
306 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
308 INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
309 all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
310 register INPUTS in the store database of the image so that Guix can be used in
311 the image. By default, REGISTER-CLOSURES? is set to true only if a service of
312 type GUIX-SERVICE-TYPE is present in the services definition of the operating
315 When DEVICE-NODES is 'linux, create Linux-device block and character devices
316 under /dev. When it is 'hurd, do Hurdish things.
318 EXTRA-DIRECTIVES is an optional list of directives to populate the root file
319 system that is passed to 'populate-root-file-system'."
321 (and register-closures?
322 (local-file (search-path %load-path
323 "guix/store/schema.sql"))))
325 (define preserve-target
328 (with-parameters ((%current-target-system target))
335 `(,name ,(preserve-target thing)))
337 `(,name ,(preserve-target thing) ,output)))
340 (expression->derivation-in-linux-vm
342 (with-extensions gcrypt-sqlite3&co
343 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
344 (gnu build bootloader)
345 (gnu build hurd-boot)
346 (guix store database)
348 #:select? not-config?)
349 ((guix config) => ,(make-config.scm)))
351 (use-modules (gnu build bootloader)
353 ((gnu build hurd-boot)
354 #:select (make-hurd-device-nodes))
355 ((gnu build linux-boot)
356 #:select (make-essential-device-nodes))
357 (guix store database)
360 (ice-9 binary-ports))
362 (sql-schema #$schema)
364 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
365 (setenv "GUIX_LOCPATH"
366 #+(file-append glibc-utf8-locales "/lib/locale"))
367 (setlocale LC_ALL "en_US.utf8")
370 '#+(append (list parted e2fsprogs dosfstools)
371 (map canonical-package
372 (list sed grep coreutils findutils gawk))))
374 ;; This variable is unused but allows us to add INPUTS-TO-COPY
377 '#$(map (match-lambda
379 ((name thing output) `(,thing ,output)))
382 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
384 (let* ((graphs '#$(match inputs
387 (initialize (root-partition-initializer
388 #:extra-directives '#$extra-directives
390 #:copy-closures? #$copy-inputs?
391 #:register-closures? #$register-closures?
392 #:system-directory #$(preserve-target os)
395 #$(match device-nodes
396 ('linux #~make-essential-device-nodes)
397 ('hurd #~make-hurd-device-nodes))
399 ;; Disable deduplication to speed things up,
400 ;; and because it doesn't help much for a
401 ;; single system generation.
403 (root-size #$(if (eq? 'guess disk-image-size)
405 ;; Minimum 20 MiB root size
407 (estimated-partition-size
408 (map (cut string-append "/xchg/" <>)
411 (* 50 (expt 2 20)))))
416 (label #$file-system-label)
417 (uuid #$(and=> file-system-uuid
419 (file-system #$file-system-type)
420 (file-system-options '#$file-system-options)
422 (initializer initialize)))
423 ;; Append a small EFI System Partition for use with UEFI
424 ;; bootloaders if we are not targeting ARM because UEFI
425 ;; support in U-Boot is experimental.
427 ;; FIXME: ‘target-arm?’ may be not operate on the right
428 ;; system/target values. Rewrite using ‘let-system’ when
433 ;; The standalone grub image is about 10MiB, but
434 ;; leave some room for custom or multiple images.
435 (size (* 40 (expt 2 20)))
436 (label "GNU-ESP") ;cosmetic only
437 ;; Use "vfat" here since this property is used
438 ;; when mounting. The actual FAT-ness is based
439 ;; on file system size (16 in this case).
442 (grub-efi #$(and (not (target-arm?)) grub-efi)))
443 (initialize-hard-disk "/dev/vda"
444 #:partitions partitions
447 #+(bootloader-package bootloader)
448 #:bootcfg #$(preserve-target bootcfg-drv)
450 #$(bootloader-configuration-file bootloader)
451 #:bootloader-installer
452 #+(bootloader-installer bootloader)))))))
454 #:make-disk-image? #t
455 #:disk-image-size disk-image-size
456 #:disk-image-format disk-image-format
457 #:references-graphs inputs*
458 #:substitutable? substitutable?))
460 (define* (system-docker-image os
462 (name "guix-docker-image")
463 (register-closures? (has-guix-service-type? os))
465 "Build a docker image. OS is the desired <operating-system>. NAME is the
466 base name to use for the output file. When SHARED-NETWORK? is true, assume
467 that the container will share network with the host and thus doesn't need a
468 DHCP client, nscd, and so on.
470 When REGISTER-CLOSURES? is true, register the closure of OS with Guix in the
471 resulting Docker image. By default, REGISTER-CLOSURES? is set to true only if
472 a service of type GUIX-SERVICE-TYPE is present in the services definition of
473 the operating system."
475 (and register-closures?
476 (local-file (search-path %load-path
477 "guix/store/schema.sql"))))
480 ;; Program that runs the boot script of OS, which in turn starts shepherd.
481 (program-file "boot-program"
482 #~(let ((system (cadr (command-line))))
483 (setenv "GUIX_NEW_SYSTEM" system)
484 (execl #$(file-append guile-2.2 "/bin/guile")
485 "guile" "--no-auto-compile"
486 (string-append system "/boot")))))
489 (let ((os (operating-system-with-gc-roots
490 (containerized-operating-system os '()
493 (list boot-program)))
494 (name (string-append name ".tar.gz"))
495 (graph "system-graph"))
497 (with-extensions (cons guile-json-3 ;for (guix docker)
498 gcrypt-sqlite3&co) ;for (guix store database)
499 (with-imported-modules `(,@(source-module-closure
501 (guix store database)
503 (guix build store-copy)
505 #:select? not-config?)
506 ((guix config) => ,(make-config.scm)))
508 (use-modules (guix docker)
512 (guix build store-copy)
513 (guix store database))
515 ;; Set the SQL schema location.
516 (sql-schema #$schema)
518 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
519 (setenv "GUIX_LOCPATH"
520 #+(file-append glibc-utf8-locales "/lib/locale"))
521 (setlocale LC_ALL "en_US.utf8")
523 (let* (;; This initializer requires elevated privileges that are
524 ;; not normally available in the build environment (e.g.,
525 ;; it needs to create device nodes). In order to obtain
526 ;; such privileges, we run it as root in a VM.
527 (initialize (root-partition-initializer
528 #:closures '(#$graph)
529 #:register-closures? #$register-closures?
530 #:system-directory #$os
531 ;; De-duplication would fail due to
532 ;; cross-device link errors, so don't do it.
534 ;; Even as root in a VM, the initializer would fail due to
535 ;; lack of privileges if we use a root-directory that is on
536 ;; a file system that is shared with the host (e.g., /tmp).
537 (root-directory "/guixsd-system-root"))
538 (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
539 (mkdir root-directory)
540 (initialize root-directory)
542 (string-append "/xchg/" #$name) ;; The output file.
543 (cons* root-directory
545 (call-with-input-file
546 (string-append "/xchg/" #$graph)
547 read-reference-graph)))
549 #:entry-point '(#$boot-program #$os)
550 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
551 #:creation-time (make-time time-utc 0 1)
552 #:transformations `((,root-directory -> ""))))))))
554 (expression->derivation-in-linux-vm
556 #:make-disk-image? #f
557 #:single-file-output? #t
558 #:references-graphs `((,graph ,os)))))
562 ;;; VM and disk images.
565 (define* (system-qemu-image os
567 (file-system-type "ext4")
568 (disk-image-size (* 900 (expt 2 20))))
569 "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
570 of the GNU system as described by OS."
571 (define file-systems-to-keep
572 ;; Keep only file systems other than root and not normally bound to real
575 (let ((target (file-system-mount-point fs))
576 (source (file-system-device fs)))
577 (or (string=? target "/")
578 (and (string? source)
579 (string-prefix? "/dev/" source))
581 (file-system-label? source))))
582 (operating-system-file-systems os)))
585 ;; UUID of the root file system.
586 (operating-system-uuid os
587 (if (string=? file-system-type "iso9660")
592 (let* ((os (operating-system
595 ;; As in 'virtualized-operating-system', use BIOS-style GRUB.
596 (bootloader (bootloader-configuration
597 (bootloader grub-bootloader)
598 (target "/dev/vda")))
600 ;; Assume we have an initrd with the whole QEMU shebang.
602 ;; Force our own root file system. Refer to it by UUID so that
603 ;; it works regardless of how the image is used ("qemu -hda",
605 (file-systems (cons (file-system
608 (type file-system-type))
609 file-systems-to-keep))))
610 (bootcfg (operating-system-bootcfg os)))
612 #:bootcfg-drv bootcfg
613 #:bootloader (bootloader-configuration-bootloader
614 (operating-system-bootloader os))
615 #:disk-image-size disk-image-size
616 #:file-system-type file-system-type
617 #:file-system-uuid root-uuid
618 #:inputs `(("system" ,os)
619 ("bootcfg" ,bootcfg))
624 ;;; VMs that share file systems with the host.
627 (define (file-system->mount-tag fs)
628 "Return a 9p mount tag for host file system FS."
629 ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
630 ;; slashes, and cannot start with '_'. Compute an identifier that
631 ;; corresponds to the rules.
633 (string-drop (bytevector->base32-string
634 (sha1 (string->utf8 fs)))
637 (define (mapping->file-system mapping)
638 "Return a 9p file system that realizes MAPPING."
640 (($ <file-system-mapping> source target writable?)
643 (device (file-system->mount-tag source))
645 (flags (if writable? '() '(read-only)))
646 (options (string-append "trans=virtio"
647 (if writable? "" ",cache=loose")))
649 (create-mount-point? #t)))))
651 (define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
652 "Return an operating system based on OS suitable for use in a virtualized
653 environment with the store shared with the host. MAPPINGS is a list of
654 <file-system-mapping> to realize in the virtualized OS."
655 (define user-file-systems
656 ;; Remove file systems that conflict with those added below, or that are
657 ;; normally bound to real devices.
659 (let ((target (file-system-mount-point fs))
660 (source (file-system-device fs)))
661 (or (string=? target (%store-prefix))
662 (string=? target "/")
663 (and (string? source)
664 (string-prefix? "/dev/" source))
666 ;; Labels and UUIDs are necessarily invalid in the VM.
667 (and (file-system-mount? fs)
668 (or (file-system-label? source)
670 (operating-system-file-systems os)))
672 (define virtual-file-systems
678 (append (map mapping->file-system mappings)
681 (operating-system (inherit os)
683 ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
684 ;; force the traditional i386/BIOS method.
685 ;; See <https://bugs.gnu.org/28768>.
686 (bootloader (bootloader-configuration
687 (inherit (operating-system-bootloader os))
688 (bootloader grub-bootloader)
689 (target "/dev/vda")))
691 (initrd (lambda (file-systems . rest)
692 (apply (operating-system-initrd os)
700 ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
701 ;; since that would lead the bootloader config to look for the kernel and
703 (file-systems (if full-boot?
707 (inherit (mapping->file-system %store-mapping))
708 (needed-for-boot? #t))
709 virtual-file-systems)))))
711 (define* (system-qemu-image/shared-store
714 (system (%current-system))
715 (target (%current-target-system))
717 (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
718 "Return a derivation that builds a QEMU image of OS that shares its store
721 When FULL-BOOT? is true, return an image that does a complete boot sequence,
722 bootloaded included; thus, make a disk image that contains everything the
723 bootloader refers to: OS kernel, initrd, bootloader data, etc."
725 ;; Use a fixed UUID to improve determinism.
726 (operating-system-uuid os 'dce))
729 (operating-system-bootcfg os))
731 ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
732 ;; BOOTCFG and all its dependencies, including the output of OS.
733 ;; This is more than needed (we only need the kernel, initrd, GRUB for its
734 ;; font, and the background image), but it's hard to filter that.
738 #:bootcfg-drv bootcfg
739 #:bootloader (bootloader-configuration-bootloader
740 (operating-system-bootloader os))
741 #:disk-image-size disk-image-size
742 #:file-system-uuid root-uuid
743 #:inputs (if full-boot?
744 `(("bootcfg" ,bootcfg))
747 ;; XXX: Passing #t here is too slow, so let it off by default.
748 #:register-closures? #f
749 #:copy-inputs? full-boot?))
751 (define* (common-qemu-options image shared-fs)
752 "Return the a string-value gexp with the common QEMU options to boot IMAGE,
753 with '-virtfs' options for the host file systems listed in SHARED-FS."
755 (define (virtfs-option fs)
756 #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
757 #$fs #$(file-system->mount-tag fs)))
759 #~(;; Only enable kvm if we see /dev/kvm exists.
760 ;; This allows users without hardware virtualization to still use these
762 #$@(if (file-exists? "/dev/kvm")
767 "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
768 "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
770 #$@(map virtfs-option shared-fs)
772 (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
775 (define* (system-qemu-image/shared-store-script os
777 (system (%current-system))
778 (target (%current-target-system))
785 (* (if full-boot? 500 70)
788 "Return a derivation that builds a script to run a virtual machine image of
789 OS that shares its store with the host. The virtual machine runs with
790 MEMORY-SIZE MiB of memory.
792 MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
793 systems into the guest.
795 When FULL-BOOT? is true, the returned script runs everything starting from the
796 bootloader; otherwise it directly starts the operating system kernel. The
797 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
798 it is mostly useful when FULL-BOOT? is true."
799 (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
800 (image (system-qemu-image/shared-store
804 #:full-boot? full-boot?
805 #:disk-image-size disk-image-size)))
806 (define kernel-arguments
807 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
808 #+@(operating-system-kernel-arguments os "/dev/vda1")))
811 #~(list #+(file-append qemu "/bin/"
812 (qemu-command (or target system)))
815 #~("-kernel" #$(operating-system-kernel-file os)
816 "-initrd" #$(file-append os "/initrd")
817 (format #f "-append ~s"
818 (string-join #$kernel-arguments " "))))
819 #$@(common-qemu-options image
820 (map file-system-mapping-source
821 (cons %store-mapping mappings)))
822 "-m " (number->string #$memory-size)
826 #~(call-with-output-file #$output
828 (format port "#!~a~% exec ~a \"$@\"~%"
829 #+(file-append bash "/bin/sh")
830 (string-join #$qemu-exec " "))
831 (chmod port #o555))))
833 (gexp->derivation "run-vm.sh" builder)))
837 ;;; High-level abstraction.
840 (define-record-type* <virtual-machine> %virtual-machine
843 (operating-system virtual-machine-operating-system) ;<operating-system>
844 (qemu virtual-machine-qemu ;<package>
846 (graphic? virtual-machine-graphic? ;Boolean
848 (memory-size virtual-machine-memory-size ;integer (MiB)
850 (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
852 (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
855 (define-syntax virtual-machine
857 "Declare a virtual machine running the specified OS, with the given
860 (%virtual-machine (operating-system os)))
862 (%virtual-machine fields ...))))
864 (define (port-forwardings->qemu-options forwardings)
865 "Return the QEMU option for the given port FORWARDINGS as a string, where
866 FORWARDINGS is a list of host-port/guest-port pairs."
869 ((host-port . guest-port)
870 (string-append "hostfwd=tcp::"
871 (number->string host-port)
872 "-:" (number->string guest-port))))
876 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
879 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
880 (system-qemu-image/shared-store-script os
885 #:memory-size memory-size
888 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size
891 `("-nic" ,(string-append
892 "user,model=virtio-net-pci,"
893 (port-forwardings->qemu-options forwardings)))))
894 (system-qemu-image/shared-store-script os
899 #:memory-size memory-size
902 #:options options)))))