1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 make-bootstrap)
54 #:select (%guile-static-stripped))
55 #:use-module (gnu packages admin)
57 #:use-module (gnu bootloader)
58 #:use-module (gnu bootloader grub)
59 #:use-module (gnu system shadow)
60 #:use-module (gnu system pam)
61 #:use-module (gnu system linux-initrd)
62 #:use-module (gnu bootloader)
63 #:use-module (gnu system file-systems)
64 #:use-module (gnu system)
65 #:use-module (gnu services)
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
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 (mount-point (%store-prefix))
100 (needed-for-boot? #t)
102 (options "trans=virtio,cache=loose")
105 ;; The 9p documentation says that cache=loose is "intended for
106 ;; exclusive, read-only mounts", without additional details. In
107 ;; practice it seems to work well for these, and it's much faster than
108 ;; the default cache=none, especially when copying and registering
111 (mount-point "/xchg")
114 (needed-for-boot? #t)
115 (options "trans=virtio,cache=loose")
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 (package-transitive-propagated-inputs package)))
138 (list guile-gcrypt guile-sqlite3)))
140 (define* (expression->derivation-in-linux-vm name exp
142 (system (%current-system))
150 %linux-vm-file-systems)
152 (single-file-output? #f)
153 (make-disk-image? #f)
154 (references-graphs #f)
156 (disk-image-format "qcow2")
157 (disk-image-size 'guess))
158 "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
159 derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
160 virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
161 9p share of the store, the '/xchg' where EXP should put its output file(s),
162 and a 9p share of /tmp.
164 If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
165 Otherwise, copy the contents of /xchg to a new directory OUTPUT.
167 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
168 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
169 return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
170 based on the size of the closure of REFERENCES-GRAPHS.
172 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
173 pairs, as for `derivation'. The files containing the reference graphs are
174 made available under the /xchg CIFS share."
176 (program-file "builder-in-linux-vm" exp))
179 ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
180 ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
181 ;; Guile, which it couldn't do using the statically-linked guile used in
182 ;; the initrd. See example at
183 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
184 (program-file "linux-vm-loader"
185 ;; When USER-BUILDER succeeds, reboot (indicating a
186 ;; success), otherwise die, which causes a kernel panic
187 ;; ("Attempted to kill init!").
188 #~(when (zero? (system* #$user-builder))
191 (let ((initrd (or initrd
192 (base-initrd file-systems
193 #:on-error 'backtrace
195 #:linux-modules %base-initrd-modules
196 #:qemu-networking? #t))))
199 ;; Code that launches the VM that evaluates EXP.
200 (with-extensions gcrypt-sqlite3&co
201 (with-imported-modules `(,@(source-module-closure
204 #:select? not-config?)
206 ;; For consumption by (gnu store database).
207 ((guix config) => ,(make-config.scm)))
209 (use-modules (guix build utils)
212 (let* ((inputs '#$(list qemu (canonical-package coreutils)))
213 (linux (string-append #$linux "/"
214 #$(system-linux-image-file-name)))
217 (graphs '#$(match references-graphs
218 (((graph-files . _) ...) graph-files)
220 (size #$(if (eq? 'guess disk-image-size)
221 #~(+ (* 70 (expt 2 20)) ;ESP
222 (estimated-partition-size graphs))
225 (set-path-environment-variable "PATH" '("bin") inputs)
227 (load-in-linux-vm loader
229 #:linux linux #:initrd initrd
230 #:memory-size #$memory-size
231 #:make-disk-image? #$make-disk-image?
232 #:single-file-output? #$single-file-output?
233 ;; FIXME: ‘target-arm32?’ may not operate on
234 ;; the right system/target values. Rewrite
235 ;; using ‘let-system’ when available.
236 #:target-arm32? #$(target-arm32?)
237 #:disk-image-format #$disk-image-format
238 #:disk-image-size size
239 #:references-graphs graphs))))))
241 (gexp->derivation name builder
242 ;; TODO: Require the "kvm" feature.
245 #:guile-for-build guile-for-build
246 #:references-graphs references-graphs)))
248 (define* (iso9660-image #:key
249 (name "iso9660-image")
252 (system (%current-system))
259 "Return a bootable, stand-alone iso9660 image.
261 INPUTS is a list of inputs (as for packages)."
263 (and register-closures?
264 (local-file (search-path %load-path
265 "guix/store/schema.sql"))))
267 (expression->derivation-in-linux-vm
269 (with-extensions gcrypt-sqlite3&co
270 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
271 (guix store database)
273 #:select? not-config?)
274 ((guix config) => ,(make-config.scm)))
276 (use-modules (gnu build vm)
277 (guix store database)
280 (sql-schema #$schema)
283 '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
284 (map canonical-package
285 (list sed grep coreutils findutils gawk))))
288 (graphs '#$(match inputs
291 ;; This variable is unused but allows us to add INPUTS-TO-COPY
294 '#$(map (match-lambda
296 ((name thing output) `(,thing ,output)))
299 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
300 (make-iso9660-image #$(bootloader-package bootloader)
304 #:register-closures? #$register-closures?
306 #:volume-id #$file-system-label
307 #:volume-uuid #$(and=> file-system-uuid
308 uuid-bytevector))))))
311 ;; Keep a local file system for /tmp so that we can populate it directly as
312 ;; root and have files owned by root. See <https://bugs.gnu.org/31752>.
313 #:file-systems (remove (lambda (file-system)
314 (string=? (file-system-mount-point file-system)
316 %linux-vm-file-systems)
318 #:make-disk-image? #f
319 #:single-file-output? #t
320 #:references-graphs inputs))
322 (define* (qemu-image #:key
324 (system (%current-system))
326 (disk-image-size 'guess)
327 (disk-image-format "qcow2")
328 (file-system-type "ext4")
334 (register-closures? #t)
337 "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
338 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
339 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
340 partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
341 partition (a UUID object).
343 The returned image is a full disk image that runs OS-DERIVATION,
344 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
345 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
347 INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
348 all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
349 register INPUTS in the store database of the image so that Guix can be used in
352 (and register-closures?
353 (local-file (search-path %load-path
354 "guix/store/schema.sql"))))
356 (expression->derivation-in-linux-vm
358 (with-extensions gcrypt-sqlite3&co
359 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
360 (gnu build bootloader)
361 (guix store database)
363 #:select? not-config?)
364 ((guix config) => ,(make-config.scm)))
366 (use-modules (gnu build bootloader)
368 (guix store database)
371 (ice-9 binary-ports))
373 (sql-schema #$schema)
376 '#$(append (list qemu parted e2fsprogs dosfstools)
377 (map canonical-package
378 (list sed grep coreutils findutils gawk))))
380 ;; This variable is unused but allows us to add INPUTS-TO-COPY
383 '#$(map (match-lambda
385 ((name thing output) `(,thing ,output)))
388 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
390 (let* ((graphs '#$(match inputs
393 (initialize (root-partition-initializer
395 #:copy-closures? #$copy-inputs?
396 #:register-closures? #$register-closures?
397 #:system-directory #$os
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)
421 (initializer initialize)))
422 ;; Append a small EFI System Partition for use with UEFI
423 ;; bootloaders if we are not targeting ARM because UEFI
424 ;; support in U-Boot is experimental.
426 ;; FIXME: ‘target-arm32?’ may be not operate on the right
427 ;; system/target values. Rewrite using ‘let-system’ when
429 (if #$(target-arm32?)
432 ;; The standalone grub image is about 10MiB, but
433 ;; leave some room for custom or multiple images.
434 (size (* 40 (expt 2 20)))
435 (label "GNU-ESP") ;cosmetic only
436 ;; Use "vfat" here since this property is used
437 ;; when mounting. The actual FAT-ness is based
438 ;; on file system size (16 in this case).
441 (initialize-hard-disk "/dev/vda"
442 #:partitions partitions
443 #:grub-efi #$grub-efi
445 #$(bootloader-package bootloader)
446 #:bootcfg #$bootcfg-drv
448 #$(bootloader-configuration-file bootloader)
449 #:bootloader-installer
450 #$(bootloader-installer bootloader)))))))
452 #:make-disk-image? #t
453 #:disk-image-size disk-image-size
454 #:disk-image-format disk-image-format
455 #:references-graphs inputs))
457 (define* (system-docker-image os
459 (name "guixsd-docker-image")
461 "Build a docker image. OS is the desired <operating-system>. NAME is the
462 base name to use for the output file. When REGISTER-CLOSURES? is not #f,
463 register the closure of OS with Guix in the resulting Docker image. This only
464 makes sense when you want to build a GuixSD Docker image that has Guix
465 installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
466 image just contains a web server that is started by the Shepherd), then you
467 should set REGISTER-CLOSURES? to #f."
469 (and register-closures?
470 (local-file (search-path %load-path
471 "guix/store/schema.sql"))))
473 (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
474 (name -> (string-append name ".tar.gz"))
475 (graph -> "system-graph"))
477 (with-extensions (cons guile-json ;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 (let* (;; This initializer requires elevated privileges that are
499 ;; not normally available in the build environment (e.g.,
500 ;; it needs to create device nodes). In order to obtain
501 ;; such privileges, we run it as root in a VM.
502 (initialize (root-partition-initializer
503 #:closures '(#$graph)
504 #:register-closures? #$register-closures?
505 #:system-directory #$os-drv
506 ;; De-duplication would fail due to
507 ;; cross-device link errors, so don't do it.
509 ;; Even as root in a VM, the initializer would fail due to
510 ;; lack of privileges if we use a root-directory that is on
511 ;; a file system that is shared with the host (e.g., /tmp).
512 (root-directory "/guixsd-system-root"))
513 (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
514 (mkdir root-directory)
515 (initialize root-directory)
517 (string-append "/xchg/" #$name) ;; The output file.
518 (cons* root-directory
520 (call-with-input-file
521 (string-append "/xchg/" #$graph)
522 read-reference-graph)))
524 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
525 #:creation-time (make-time time-utc 0 1)
526 #:transformations `((,root-directory -> ""))))))))
527 (expression->derivation-in-linux-vm
529 #:make-disk-image? #f
530 #:single-file-output? #t
531 #:references-graphs `((,graph ,os-drv)))))
535 ;;; VM and disk images.
538 (define* (operating-system-uuid os #:optional (type 'dce))
539 "Compute UUID object with a deterministic \"UUID\" for OS, of the given
540 TYPE (one of 'iso9660 or 'dce). Return a UUID object."
541 ;; Note: For this to be deterministic, we must not hash things that contains
542 ;; (directly or indirectly) procedures, for example. That rules out
543 ;; anything that contains gexps, thunk or delayed record fields, etc.
546 (compose service-type-name service-kind))
548 (define (file-system-digest fs)
549 ;; Return a hashable digest that does not contain 'dependencies' since
550 ;; this field can contain procedures.
551 (let ((device (file-system-device fs)))
552 (list (file-system-mount-point fs)
553 (file-system-type fs)
554 (cond ((file-system-label? device)
555 (file-system-label->string device))
557 (uuid->string device))
561 (file-system-options fs))))
563 (if (eq? type 'iso9660)
564 (let ((pad (compose (cut string-pad <> 2 #\0)
566 (h (hash (map service-name (operating-system-services os))
569 (string->iso9660-uuid
570 (string-append "1970-01-01-"
571 (pad (hash (operating-system-host-name os) 24)) "-"
572 (pad (quotient h 60)) "-"
573 (pad (modulo h 60)) "-"
574 (pad (hash (map file-system-digest
575 (operating-system-file-systems os))
579 (uint-list->bytevector
580 (list (hash file-system-type
582 (hash (operating-system-host-name os)
584 (hash (map service-name (operating-system-services os))
586 (hash (map file-system-digest (operating-system-file-systems os))
592 (define* (system-disk-image os
595 (file-system-type "ext4")
596 (disk-image-size (* 900 (expt 2 20)))
598 "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
599 system described by OS. Said image can be copied on a USB stick as is. When
600 VOLATILE? is true, the root file system is made volatile; this is useful
601 to USB sticks meant to be read-only."
602 (define normalize-label
603 ;; ISO labels are all-caps (case-insensitive), but since
604 ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
605 (if (string=? "iso9660" file-system-type)
610 ;; Volume name of the root file system.
611 (normalize-label "GuixSD_image"))
614 ;; UUID of the root file system, computed in a deterministic fashion.
615 ;; This is what we use to locate the root file system so it has to be
616 ;; different from the user's own file system UUIDs.
617 (operating-system-uuid os
618 (if (string=? file-system-type "iso9660")
622 (define file-systems-to-keep
624 (string=? (file-system-mount-point fs) "/"))
625 (operating-system-file-systems os)))
627 (let* ((os (operating-system (inherit os)
628 ;; Since this is meant to be used on real hardware, don't
629 ;; install QEMU networking or anything like that. Assume USB
630 ;; mass storage devices (usb-storage.ko) are available.
631 (initrd (lambda (file-systems . rest)
632 (apply (operating-system-initrd os)
637 (bootloader (if (string=? "iso9660" file-system-type)
638 (bootloader-configuration
639 (inherit (operating-system-bootloader os))
640 (bootloader grub-mkrescue-bootloader))
641 (operating-system-bootloader os)))
643 ;; Force our own root file system.
644 (file-systems (cons (file-system
647 (type file-system-type))
648 file-systems-to-keep))))
649 (bootcfg (operating-system-bootcfg os)))
650 (if (string=? "iso9660" file-system-type)
651 (iso9660-image #:name name
652 #:file-system-label root-label
653 #:file-system-uuid root-uuid
655 #:register-closures? #t
656 #:bootcfg-drv bootcfg
657 #:bootloader (bootloader-configuration-bootloader
658 (operating-system-bootloader os))
659 #:inputs `(("system" ,os)
660 ("bootcfg" ,bootcfg)))
661 (qemu-image #:name name
663 #:bootcfg-drv bootcfg
664 #:bootloader (bootloader-configuration-bootloader
665 (operating-system-bootloader os))
666 #:disk-image-size disk-image-size
667 #:disk-image-format "raw"
668 #:file-system-type file-system-type
669 #:file-system-label root-label
670 #:file-system-uuid root-uuid
672 #:register-closures? #t
673 #:inputs `(("system" ,os)
674 ("bootcfg" ,bootcfg))))))
676 (define* (system-qemu-image os
678 (file-system-type "ext4")
679 (disk-image-size (* 900 (expt 2 20))))
680 "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
681 of the GNU system as described by OS."
682 (define file-systems-to-keep
683 ;; Keep only file systems other than root and not normally bound to real
686 (let ((target (file-system-mount-point fs))
687 (source (file-system-device fs)))
688 (or (string=? target "/")
689 (string-prefix? "/dev/" source))))
690 (operating-system-file-systems os)))
693 ;; UUID of the root file system.
694 (operating-system-uuid os
695 (if (string=? file-system-type "iso9660")
700 (let* ((os (operating-system (inherit os)
701 ;; Assume we have an initrd with the whole QEMU shebang.
703 ;; Force our own root file system. Refer to it by UUID so that
704 ;; it works regardless of how the image is used ("qemu -hda",
706 (file-systems (cons (file-system
709 (type file-system-type))
710 file-systems-to-keep))))
711 (bootcfg (operating-system-bootcfg os)))
713 #:bootcfg-drv bootcfg
714 #:bootloader (bootloader-configuration-bootloader
715 (operating-system-bootloader os))
716 #:disk-image-size disk-image-size
717 #:file-system-type file-system-type
718 #:file-system-uuid root-uuid
719 #:inputs `(("system" ,os)
720 ("bootcfg" ,bootcfg))
725 ;;; VMs that share file systems with the host.
728 (define (file-system->mount-tag fs)
729 "Return a 9p mount tag for host file system FS."
730 ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
731 ;; slashes, and cannot start with '_'. Compute an identifier that
732 ;; corresponds to the rules.
734 (string-drop (bytevector->base32-string
735 (sha1 (string->utf8 fs)))
738 (define (mapping->file-system mapping)
739 "Return a 9p file system that realizes MAPPING."
741 (($ <file-system-mapping> source target writable?)
744 (device (file-system->mount-tag source))
746 (flags (if writable? '() '(read-only)))
747 (options "trans=virtio,cache=loose")
749 (create-mount-point? #t)))))
751 (define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
752 "Return an operating system based on OS suitable for use in a virtualized
753 environment with the store shared with the host. MAPPINGS is a list of
754 <file-system-mapping> to realize in the virtualized OS."
755 (define user-file-systems
756 ;; Remove file systems that conflict with those added below, or that are
757 ;; normally bound to real devices.
759 (let ((target (file-system-mount-point fs))
760 (source (file-system-device fs)))
761 (or (string=? target (%store-prefix))
762 (string=? target "/")
763 (and (string? source)
764 (string-prefix? "/dev/" source))
766 ;; Labels and UUIDs are necessarily invalid in the VM.
767 (and (file-system-mount? fs)
768 (or (file-system-label? source)
770 (operating-system-file-systems os)))
772 (define virtual-file-systems
778 (append (map mapping->file-system mappings)
781 (operating-system (inherit os)
783 ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
784 ;; force the traditional i386/BIOS method.
785 ;; See <https://bugs.gnu.org/28768>.
786 (bootloader (bootloader-configuration
787 (bootloader grub-bootloader)
788 (target "/dev/vda")))
790 (initrd (lambda (file-systems . rest)
791 (apply (operating-system-initrd os)
799 ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
800 ;; since that would lead the bootloader config to look for the kernel and
802 (file-systems (if full-boot?
806 (inherit (mapping->file-system %store-mapping))
807 (needed-for-boot? #t))
808 virtual-file-systems)))))
810 (define* (system-qemu-image/shared-store
814 (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
815 "Return a derivation that builds a QEMU image of OS that shares its store
818 When FULL-BOOT? is true, return an image that does a complete boot sequence,
819 bootloaded included; thus, make a disk image that contains everything the
820 bootloader refers to: OS kernel, initrd, bootloader data, etc."
822 ;; Use a fixed UUID to improve determinism.
823 (operating-system-uuid os 'dce))
826 (operating-system-bootcfg os))
828 ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
829 ;; BOOTCFG and all its dependencies, including the output of OS.
830 ;; This is more than needed (we only need the kernel, initrd, GRUB for its
831 ;; font, and the background image), but it's hard to filter that.
833 #:bootcfg-drv bootcfg
834 #:bootloader (bootloader-configuration-bootloader
835 (operating-system-bootloader os))
836 #:disk-image-size disk-image-size
837 #:file-system-uuid root-uuid
838 #:inputs (if full-boot?
839 `(("bootcfg" ,bootcfg))
842 ;; XXX: Passing #t here is too slow, so let it off by default.
843 #:register-closures? #f
844 #:copy-inputs? full-boot?))
846 (define* (common-qemu-options image shared-fs)
847 "Return the a string-value gexp with the common QEMU options to boot IMAGE,
848 with '-virtfs' options for the host file systems listed in SHARED-FS."
850 (define (virtfs-option fs)
851 #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
852 #$fs #$(file-system->mount-tag fs)))
854 #~(;; Only enable kvm if we see /dev/kvm exists.
855 ;; This allows users without hardware virtualization to still use these
857 #$@(if (file-exists? "/dev/kvm")
862 "-net nic,model=virtio"
863 "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
864 "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
866 #$@(map virtfs-option shared-fs)
868 (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
871 (define* (system-qemu-image/shared-store-script os
879 (* (if full-boot? 500 70)
882 "Return a derivation that builds a script to run a virtual machine image of
883 OS that shares its store with the host. The virtual machine runs with
884 MEMORY-SIZE MiB of memory.
886 MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
887 systems into the guest.
889 When FULL-BOOT? is true, the returned script runs everything starting from the
890 bootloader; otherwise it directly starts the operating system kernel. The
891 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
892 it is mostly useful when FULL-BOOT? is true."
893 (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
894 (image (system-qemu-image/shared-store
896 #:full-boot? full-boot?
897 #:disk-image-size disk-image-size)))
898 (define kernel-arguments
899 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
900 #+@(operating-system-kernel-arguments os "/dev/vda1")))
903 #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
906 #~("-kernel" #$(operating-system-kernel-file os)
907 "-initrd" #$(file-append os "/initrd")
908 (format #f "-append ~s"
909 (string-join #$kernel-arguments " "))))
910 #$@(common-qemu-options image
911 (map file-system-mapping-source
912 (cons %store-mapping mappings)))
913 "-m " (number->string #$memory-size)
917 #~(call-with-output-file #$output
919 (format port "#!~a~% exec ~a \"$@\"~%"
920 #$(file-append bash "/bin/sh")
921 (string-join #$qemu-exec " "))
922 (chmod port #o555))))
924 (gexp->derivation "run-vm.sh" builder)))
928 ;;; High-level abstraction.
931 (define-record-type* <virtual-machine> %virtual-machine
934 (operating-system virtual-machine-operating-system) ;<operating-system>
935 (qemu virtual-machine-qemu ;<package>
937 (graphic? virtual-machine-graphic? ;Boolean
939 (memory-size virtual-machine-memory-size ;integer (MiB)
941 (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
943 (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
946 (define-syntax virtual-machine
948 "Declare a virtual machine running the specified OS, with the given
951 (%virtual-machine (operating-system os)))
953 (%virtual-machine fields ...))))
955 (define (port-forwardings->qemu-options forwardings)
956 "Return the QEMU option for the given port FORWARDINGS as a string, where
957 FORWARDINGS is a list of host-port/guest-port pairs."
960 ((host-port . guest-port)
961 (string-append "hostfwd=tcp::"
962 (number->string host-port)
963 "-:" (number->string guest-port))))
967 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
969 ;; XXX: SYSTEM and TARGET are ignored.
971 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
972 (system-qemu-image/shared-store-script os
975 #:memory-size memory-size
978 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size
981 `("-net" ,(string-append
983 (port-forwardings->qemu-options forwardings)))))
984 (system-qemu-image/shared-store-script os
987 #:memory-size memory-size
990 #:options options)))))