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 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-container)
62 #:use-module (gnu system linux-initrd)
63 #:use-module (gnu bootloader)
64 #:use-module (gnu system file-systems)
65 #:use-module (gnu system)
66 #:use-module (gnu services)
67 #:use-module (gnu services base)
68 #:use-module (gnu system uuid)
70 #:use-module (srfi srfi-1)
71 #:use-module (srfi srfi-26)
72 #:use-module (rnrs bytevectors)
73 #:use-module (ice-9 match)
75 #:export (expression->derivation-in-linux-vm
77 virtualized-operating-system
80 system-qemu-image/shared-store
81 system-qemu-image/shared-store-script
91 ;;; Tools to evaluate build expressions within virtual machines.
95 (define %linux-vm-file-systems
96 ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with
99 ;; The 9p documentation says that cache=loose is "intended for exclusive,
100 ;; read-only mounts", without additional details. It's much faster than the
101 ;; default cache=none, especially when copying and registering store items.
102 ;; Thus, use cache=loose, except for /xchg where we want to ensure
105 (mount-point (%store-prefix))
108 (needed-for-boot? #t)
110 (options "trans=virtio,cache=loose")
113 (mount-point "/xchg")
116 (needed-for-boot? #t)
117 (options "trans=virtio")
123 (needed-for-boot? #t)
124 (options "trans=virtio,cache=loose")
128 ;; Select (guix …) and (gnu …) modules, except (guix config).
131 (('guix rest ...) #t)
135 (define gcrypt-sqlite3&co
136 ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
137 (append-map (lambda (package)
139 (match (package-transitive-propagated-inputs package)
140 (((labels packages) ...)
142 (list guile-gcrypt guile-sqlite3)))
144 (define* (expression->derivation-in-linux-vm name exp
146 (system (%current-system)) target
154 %linux-vm-file-systems)
156 (single-file-output? #f)
157 (make-disk-image? #f)
158 (references-graphs #f)
160 (disk-image-format "qcow2")
161 (disk-image-size 'guess)
164 "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
165 derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
166 virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
167 9p share of the store, the '/xchg' where EXP should put its output file(s),
168 and a 9p share of /tmp.
170 If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
171 Otherwise, copy the contents of /xchg to a new directory OUTPUT.
173 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
174 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
175 return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
176 based on the size of the closure of REFERENCES-GRAPHS.
178 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
179 pairs, as for `derivation'. The files containing the reference graphs are
180 made available under the /xchg CIFS share.
182 SUBSTITUTABLE? determines whether the returned derivation should be marked as
185 (program-file "builder-in-linux-vm" exp))
188 ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
189 ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
190 ;; Guile, which it couldn't do using the statically-linked guile used in
191 ;; the initrd. See example at
192 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
193 (program-file "linux-vm-loader"
194 ;; Communicate USER-BUILDER's exit status via /xchg so that
195 ;; the host can distinguish between success, failure, and
197 #~(let ((status (system* #$user-builder)))
198 (call-with-output-file "/xchg/.exit-status"
200 (write status port)))
204 (let ((initrd (or initrd
205 (base-initrd file-systems
206 #:on-error 'backtrace
208 #:linux-modules %base-initrd-modules
209 #:qemu-networking? #t))))
212 ;; Code that launches the VM that evaluates EXP.
213 (with-extensions gcrypt-sqlite3&co
214 (with-imported-modules `(,@(source-module-closure
217 #:select? not-config?)
219 ;; For consumption by (gnu store database).
220 ((guix config) => ,(make-config.scm)))
222 (use-modules (guix build utils)
225 (let* ((native-inputs
226 '#+(list qemu (canonical-package coreutils)))
227 (linux (string-append #$linux "/"
228 #$(system-linux-image-file-name)))
231 (graphs '#$(match references-graphs
232 (((graph-files . _) ...) graph-files)
234 (target #$(or (%current-target-system) (%current-system)))
235 (size #$(if (eq? 'guess disk-image-size)
236 #~(+ (* 70 (expt 2 20)) ;ESP
237 (estimated-partition-size graphs))
240 (set-path-environment-variable "PATH" '("bin") native-inputs)
242 (load-in-linux-vm loader
244 #:linux linux #:initrd initrd
245 #:qemu (qemu-command target)
246 #:memory-size #$memory-size
247 #:make-disk-image? #$make-disk-image?
248 #:single-file-output? #$single-file-output?
249 ;; FIXME: ‘target-arm32?’ and
250 ;; ‘target-aarch64?’ may not operate on the
251 ;; right system/target values. Rewrite
252 ;; using ‘let-system’ when available.
253 #:target-arm32? #$(target-arm32?)
254 #:target-aarch64? #$(target-aarch64?)
255 #:disk-image-format #$disk-image-format
256 #:disk-image-size size
257 #:references-graphs graphs))))))
259 (gexp->derivation name builder
260 ;; TODO: Require the "kvm" feature.
264 #:guile-for-build guile-for-build
265 #:references-graphs references-graphs
266 #:substitutable? substitutable?)))
268 (define (has-guix-service-type? os)
269 "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
270 (not (not (find (lambda (service)
271 (eq? (service-kind service) guix-service-type))
272 (operating-system-services os)))))
274 (define* (iso9660-image #:key
275 (name "iso9660-image")
278 (system (%current-system))
279 (target (%current-target-system))
284 (register-closures? (has-guix-service-type? os))
286 (grub-mkrescue-environment '())
288 "Return a bootable, stand-alone iso9660 image.
290 INPUTS is a list of inputs (as for packages)."
292 (and register-closures?
293 (local-file (search-path %load-path
294 "guix/store/schema.sql"))))
296 (expression->derivation-in-linux-vm
298 (with-extensions gcrypt-sqlite3&co
299 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
300 (guix store database)
302 #:select? not-config?)
303 ((guix config) => ,(make-config.scm)))
305 (use-modules (gnu build vm)
306 (guix store database)
309 (sql-schema #$schema)
311 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
312 (setenv "GUIX_LOCPATH"
313 #+(file-append glibc-utf8-locales "/lib/locale"))
314 (setlocale LC_ALL "en_US.utf8")
317 '#$(append (list parted e2fsprogs dosfstools xorriso)
318 (map canonical-package
319 (list sed grep coreutils findutils gawk))))
322 (graphs '#$(match inputs
325 ;; This variable is unused but allows us to add INPUTS-TO-COPY
328 '#$(map (match-lambda
330 ((name thing output) `(,thing ,output)))
333 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
334 (make-iso9660-image #$xorriso
335 '#$grub-mkrescue-environment
336 #$(bootloader-package bootloader)
340 #:register-closures? #$register-closures?
342 #:volume-id #$file-system-label
343 #:volume-uuid #$(and=> file-system-uuid
344 uuid-bytevector))))))
348 ;; Keep a local file system for /tmp so that we can populate it directly as
349 ;; root and have files owned by root. See <https://bugs.gnu.org/31752>.
350 #:file-systems (remove (lambda (file-system)
351 (string=? (file-system-mount-point file-system)
353 %linux-vm-file-systems)
355 #:make-disk-image? #f
356 #:single-file-output? #t
357 #:references-graphs inputs
358 #:substitutable? substitutable?
360 ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size.
363 (define* (qemu-image #:key
365 (system (%current-system))
366 (target (%current-target-system))
368 (disk-image-size 'guess)
369 (disk-image-format "qcow2")
370 (file-system-type "ext4")
376 (register-closures? (has-guix-service-type? os))
380 "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
381 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
382 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
383 partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
384 partition (a UUID object).
386 The returned image is a full disk image that runs OS-DERIVATION,
387 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
388 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
390 INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
391 all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
392 register INPUTS in the store database of the image so that Guix can be used in
393 the image. By default, REGISTER-CLOSURES? is set to true only if a service of
394 type GUIX-SERVICE-TYPE is present in the services definition of the operating
397 (and register-closures?
398 (local-file (search-path %load-path
399 "guix/store/schema.sql"))))
401 (expression->derivation-in-linux-vm
403 (with-extensions gcrypt-sqlite3&co
404 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
405 (gnu build bootloader)
406 (guix store database)
408 #:select? not-config?)
409 ((guix config) => ,(make-config.scm)))
411 (use-modules (gnu build bootloader)
413 (guix store database)
416 (ice-9 binary-ports))
418 (sql-schema #$schema)
420 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
421 (setenv "GUIX_LOCPATH"
422 #+(file-append glibc-utf8-locales "/lib/locale"))
423 (setlocale LC_ALL "en_US.utf8")
426 '#$(append (list parted e2fsprogs dosfstools)
427 (map canonical-package
428 (list sed grep coreutils findutils gawk))))
430 ;; This variable is unused but allows us to add INPUTS-TO-COPY
433 '#$(map (match-lambda
435 ((name thing output) `(,thing ,output)))
438 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
440 (let* ((graphs '#$(match inputs
443 (initialize (root-partition-initializer
445 #:copy-closures? #$copy-inputs?
446 #:register-closures? #$register-closures?
447 #:system-directory #$os
449 ;; Disable deduplication to speed things up,
450 ;; and because it doesn't help much for a
451 ;; single system generation.
453 (root-size #$(if (eq? 'guess disk-image-size)
455 ;; Minimum 20 MiB root size
457 (estimated-partition-size
458 (map (cut string-append "/xchg/" <>)
461 (* 50 (expt 2 20)))))
466 (label #$file-system-label)
467 (uuid #$(and=> file-system-uuid
469 (file-system #$file-system-type)
471 (initializer initialize)))
472 ;; Append a small EFI System Partition for use with UEFI
473 ;; bootloaders if we are not targeting ARM because UEFI
474 ;; support in U-Boot is experimental.
476 ;; FIXME: ‘target-arm?’ may be not operate on the right
477 ;; system/target values. Rewrite using ‘let-system’ when
482 ;; The standalone grub image is about 10MiB, but
483 ;; leave some room for custom or multiple images.
484 (size (* 40 (expt 2 20)))
485 (label "GNU-ESP") ;cosmetic only
486 ;; Use "vfat" here since this property is used
487 ;; when mounting. The actual FAT-ness is based
488 ;; on file system size (16 in this case).
491 (grub-efi #$(and (not (target-arm?)) grub-efi)))
492 (initialize-hard-disk "/dev/vda"
493 #:partitions partitions
496 #$(bootloader-package bootloader)
497 #:bootcfg #$bootcfg-drv
499 #$(bootloader-configuration-file bootloader)
500 #:bootloader-installer
501 #$(bootloader-installer bootloader)))))))
504 #:make-disk-image? #t
505 #:disk-image-size disk-image-size
506 #:disk-image-format disk-image-format
507 #:references-graphs inputs
508 #:substitutable? substitutable?))
510 (define* (system-docker-image os
512 (name "guix-docker-image")
513 (register-closures? (has-guix-service-type? os)))
514 "Build a docker image. OS is the desired <operating-system>. NAME is the
515 base name to use for the output file. When REGISTER-CLOSURES? is true,
516 register the closure of OS with Guix in the resulting Docker image. By
517 default, REGISTER-CLOSURES? is set to true only if a service of type
518 GUIX-SERVICE-TYPE is present in the services definition of the operating
521 (and register-closures?
522 (local-file (search-path %load-path
523 "guix/store/schema.sql"))))
526 ;; Program that runs the boot script of OS, which in turn starts shepherd.
527 (program-file "boot-program"
528 #~(let ((system (cadr (command-line))))
529 (setenv "GUIX_NEW_SYSTEM" system)
530 (execl #$(file-append guile-2.2 "/bin/guile")
531 "guile" "--no-auto-compile"
532 (string-append system "/boot")))))
535 (let ((os (operating-system-with-gc-roots
536 (containerized-operating-system os '())
537 (list boot-program)))
538 (name (string-append name ".tar.gz"))
539 (graph "system-graph"))
541 (with-extensions (cons guile-json-3 ;for (guix docker)
542 gcrypt-sqlite3&co) ;for (guix store database)
543 (with-imported-modules `(,@(source-module-closure
545 (guix store database)
547 (guix build store-copy)
549 #:select? not-config?)
550 ((guix config) => ,(make-config.scm)))
552 (use-modules (guix docker)
556 (guix build store-copy)
557 (guix store database))
559 ;; Set the SQL schema location.
560 (sql-schema #$schema)
562 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
563 (setenv "GUIX_LOCPATH"
564 #+(file-append glibc-utf8-locales "/lib/locale"))
565 (setlocale LC_ALL "en_US.utf8")
567 (let* (;; This initializer requires elevated privileges that are
568 ;; not normally available in the build environment (e.g.,
569 ;; it needs to create device nodes). In order to obtain
570 ;; such privileges, we run it as root in a VM.
571 (initialize (root-partition-initializer
572 #:closures '(#$graph)
573 #:register-closures? #$register-closures?
574 #:system-directory #$os
575 ;; De-duplication would fail due to
576 ;; cross-device link errors, so don't do it.
578 ;; Even as root in a VM, the initializer would fail due to
579 ;; lack of privileges if we use a root-directory that is on
580 ;; a file system that is shared with the host (e.g., /tmp).
581 (root-directory "/guixsd-system-root"))
582 (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
583 (mkdir root-directory)
584 (initialize root-directory)
586 (string-append "/xchg/" #$name) ;; The output file.
587 (cons* root-directory
589 (call-with-input-file
590 (string-append "/xchg/" #$graph)
591 read-reference-graph)))
593 #:entry-point '(#$boot-program #$os)
594 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
595 #:creation-time (make-time time-utc 0 1)
596 #:transformations `((,root-directory -> ""))))))))
598 (expression->derivation-in-linux-vm
600 #:make-disk-image? #f
601 #:single-file-output? #t
602 #:references-graphs `((,graph ,os)))))
606 ;;; VM and disk images.
609 (define* (operating-system-uuid os #:optional (type 'dce))
610 "Compute UUID object with a deterministic \"UUID\" for OS, of the given
611 TYPE (one of 'iso9660 or 'dce). Return a UUID object."
612 ;; Note: For this to be deterministic, we must not hash things that contains
613 ;; (directly or indirectly) procedures, for example. That rules out
614 ;; anything that contains gexps, thunk or delayed record fields, etc.
617 (compose service-type-name service-kind))
619 (define (file-system-digest fs)
620 ;; Return a hashable digest that does not contain 'dependencies' since
621 ;; this field can contain procedures.
622 (let ((device (file-system-device fs)))
623 (list (file-system-mount-point fs)
624 (file-system-type fs)
625 (file-system-device->string device)
626 (file-system-options fs))))
628 (if (eq? type 'iso9660)
629 (let ((pad (compose (cut string-pad <> 2 #\0)
631 (h (hash (map service-name (operating-system-services os))
634 (string->iso9660-uuid
635 (string-append "1970-01-01-"
636 (pad (hash (operating-system-host-name os) 24)) "-"
637 (pad (quotient h 60)) "-"
638 (pad (modulo h 60)) "-"
639 (pad (hash (map file-system-digest
640 (operating-system-file-systems os))
644 (uint-list->bytevector
645 (list (hash (map file-system-digest
646 (operating-system-file-systems os))
648 (hash (operating-system-host-name os)
650 (hash (map service-name (operating-system-services os))
652 (hash (map file-system-digest (operating-system-file-systems os))
658 (define* (system-disk-image os
661 (file-system-type "ext4")
662 (disk-image-size (* 900 (expt 2 20)))
665 "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
666 system described by OS. Said image can be copied on a USB stick as is. When
667 VOLATILE? is true, the root file system is made volatile; this is useful
668 to USB sticks meant to be read-only.
670 SUBSTITUTABLE? determines whether the returned derivation should be marked as
672 (define normalize-label
673 ;; ISO labels are all-caps (case-insensitive), but since
674 ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
675 (if (string=? "iso9660" file-system-type)
680 ;; Volume name of the root file system.
681 (normalize-label "Guix_image"))
683 (define (root-uuid os)
684 ;; UUID of the root file system, computed in a deterministic fashion.
685 ;; This is what we use to locate the root file system so it has to be
686 ;; different from the user's own file system UUIDs.
687 (operating-system-uuid os
688 (if (string=? file-system-type "iso9660")
692 (define file-systems-to-keep
694 (string=? (file-system-mount-point fs) "/"))
695 (operating-system-file-systems os)))
697 (let* ((os (operating-system (inherit os)
698 ;; Since this is meant to be used on real hardware, don't
699 ;; install QEMU networking or anything like that. Assume USB
700 ;; mass storage devices (usb-storage.ko) are available.
701 (initrd (lambda (file-systems . rest)
702 (apply (operating-system-initrd os)
704 #:volatile-root? volatile?
707 (bootloader (if (string=? "iso9660" file-system-type)
708 (bootloader-configuration
709 (inherit (operating-system-bootloader os))
710 (bootloader grub-mkrescue-bootloader))
711 (operating-system-bootloader os)))
713 ;; Force our own root file system. (We need a "/" file system
714 ;; to call 'root-uuid'.)
715 (file-systems (cons (file-system
717 (device "/dev/placeholder")
718 (type file-system-type))
719 file-systems-to-keep))))
720 (uuid (root-uuid os))
721 (os (operating-system
723 (file-systems (cons (file-system
726 (type file-system-type))
727 file-systems-to-keep))))
728 (bootcfg (operating-system-bootcfg os)))
729 (if (string=? "iso9660" file-system-type)
730 (iso9660-image #:name name
731 #:file-system-label root-label
732 #:file-system-uuid uuid
734 #:bootcfg-drv bootcfg
735 #:bootloader (bootloader-configuration-bootloader
736 (operating-system-bootloader os))
737 #:inputs `(("system" ,os)
738 ("bootcfg" ,bootcfg))
739 #:grub-mkrescue-environment
740 '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
741 #:substitutable? substitutable?)
742 (qemu-image #:name name
744 #:bootcfg-drv bootcfg
745 #:bootloader (bootloader-configuration-bootloader
746 (operating-system-bootloader os))
747 #:disk-image-size disk-image-size
748 #:disk-image-format "raw"
749 #:file-system-type file-system-type
750 #:file-system-label root-label
751 #:file-system-uuid uuid
753 #:inputs `(("system" ,os)
754 ("bootcfg" ,bootcfg))
755 #:substitutable? substitutable?))))
757 (define* (system-qemu-image os
759 (file-system-type "ext4")
760 (disk-image-size (* 900 (expt 2 20))))
761 "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
762 of the GNU system as described by OS."
763 (define file-systems-to-keep
764 ;; Keep only file systems other than root and not normally bound to real
767 (let ((target (file-system-mount-point fs))
768 (source (file-system-device fs)))
769 (or (string=? target "/")
770 (string-prefix? "/dev/" source))))
771 (operating-system-file-systems os)))
774 ;; UUID of the root file system.
775 (operating-system-uuid os
776 (if (string=? file-system-type "iso9660")
781 (let* ((os (operating-system (inherit os)
782 ;; Assume we have an initrd with the whole QEMU shebang.
784 ;; Force our own root file system. Refer to it by UUID so that
785 ;; it works regardless of how the image is used ("qemu -hda",
787 (file-systems (cons (file-system
790 (type file-system-type))
791 file-systems-to-keep))))
792 (bootcfg (operating-system-bootcfg os)))
794 #:bootcfg-drv bootcfg
795 #:bootloader (bootloader-configuration-bootloader
796 (operating-system-bootloader os))
797 #:disk-image-size disk-image-size
798 #:file-system-type file-system-type
799 #:file-system-uuid root-uuid
800 #:inputs `(("system" ,os)
801 ("bootcfg" ,bootcfg))
806 ;;; VMs that share file systems with the host.
809 (define (file-system->mount-tag fs)
810 "Return a 9p mount tag for host file system FS."
811 ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
812 ;; slashes, and cannot start with '_'. Compute an identifier that
813 ;; corresponds to the rules.
815 (string-drop (bytevector->base32-string
816 (sha1 (string->utf8 fs)))
819 (define (mapping->file-system mapping)
820 "Return a 9p file system that realizes MAPPING."
822 (($ <file-system-mapping> source target writable?)
825 (device (file-system->mount-tag source))
827 (flags (if writable? '() '(read-only)))
828 (options "trans=virtio,cache=loose")
830 (create-mount-point? #t)))))
832 (define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
833 "Return an operating system based on OS suitable for use in a virtualized
834 environment with the store shared with the host. MAPPINGS is a list of
835 <file-system-mapping> to realize in the virtualized OS."
836 (define user-file-systems
837 ;; Remove file systems that conflict with those added below, or that are
838 ;; normally bound to real devices.
840 (let ((target (file-system-mount-point fs))
841 (source (file-system-device fs)))
842 (or (string=? target (%store-prefix))
843 (string=? target "/")
844 (and (string? source)
845 (string-prefix? "/dev/" source))
847 ;; Labels and UUIDs are necessarily invalid in the VM.
848 (and (file-system-mount? fs)
849 (or (file-system-label? source)
851 (operating-system-file-systems os)))
853 (define virtual-file-systems
859 (append (map mapping->file-system mappings)
862 (operating-system (inherit os)
864 ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
865 ;; force the traditional i386/BIOS method.
866 ;; See <https://bugs.gnu.org/28768>.
867 (bootloader (bootloader-configuration
868 (inherit (operating-system-bootloader os))
869 (bootloader grub-bootloader)
870 (target "/dev/vda")))
872 (initrd (lambda (file-systems . rest)
873 (apply (operating-system-initrd os)
881 ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
882 ;; since that would lead the bootloader config to look for the kernel and
884 (file-systems (if full-boot?
888 (inherit (mapping->file-system %store-mapping))
889 (needed-for-boot? #t))
890 virtual-file-systems)))))
892 (define* (system-qemu-image/shared-store
896 (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
897 "Return a derivation that builds a QEMU image of OS that shares its store
900 When FULL-BOOT? is true, return an image that does a complete boot sequence,
901 bootloaded included; thus, make a disk image that contains everything the
902 bootloader refers to: OS kernel, initrd, bootloader data, etc."
904 ;; Use a fixed UUID to improve determinism.
905 (operating-system-uuid os 'dce))
908 (operating-system-bootcfg os))
910 ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
911 ;; BOOTCFG and all its dependencies, including the output of OS.
912 ;; This is more than needed (we only need the kernel, initrd, GRUB for its
913 ;; font, and the background image), but it's hard to filter that.
915 #:bootcfg-drv bootcfg
916 #:bootloader (bootloader-configuration-bootloader
917 (operating-system-bootloader os))
918 #:disk-image-size disk-image-size
919 #:file-system-uuid root-uuid
920 #:inputs (if full-boot?
921 `(("bootcfg" ,bootcfg))
924 ;; XXX: Passing #t here is too slow, so let it off by default.
925 #:register-closures? #f
926 #:copy-inputs? full-boot?))
928 (define* (common-qemu-options image shared-fs)
929 "Return the a string-value gexp with the common QEMU options to boot IMAGE,
930 with '-virtfs' options for the host file systems listed in SHARED-FS."
932 (define (virtfs-option fs)
933 #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
934 #$fs #$(file-system->mount-tag fs)))
936 #~(;; Only enable kvm if we see /dev/kvm exists.
937 ;; This allows users without hardware virtualization to still use these
939 #$@(if (file-exists? "/dev/kvm")
944 "-nic" "user,model=virtio-net-pci"
945 "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
946 "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
948 #$@(map virtfs-option shared-fs)
950 (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
953 (define* (system-qemu-image/shared-store-script os
961 (* (if full-boot? 500 70)
964 "Return a derivation that builds a script to run a virtual machine image of
965 OS that shares its store with the host. The virtual machine runs with
966 MEMORY-SIZE MiB of memory.
968 MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
969 systems into the guest.
971 When FULL-BOOT? is true, the returned script runs everything starting from the
972 bootloader; otherwise it directly starts the operating system kernel. The
973 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
974 it is mostly useful when FULL-BOOT? is true."
975 (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
976 (image (system-qemu-image/shared-store
978 #:full-boot? full-boot?
979 #:disk-image-size disk-image-size)))
980 (define kernel-arguments
981 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
982 #+@(operating-system-kernel-arguments os "/dev/vda1")))
985 #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
988 #~("-kernel" #$(operating-system-kernel-file os)
989 "-initrd" #$(file-append os "/initrd")
990 (format #f "-append ~s"
991 (string-join #$kernel-arguments " "))))
992 #$@(common-qemu-options image
993 (map file-system-mapping-source
994 (cons %store-mapping mappings)))
995 "-m " (number->string #$memory-size)
999 #~(call-with-output-file #$output
1001 (format port "#!~a~% exec ~a \"$@\"~%"
1002 #$(file-append bash "/bin/sh")
1003 (string-join #$qemu-exec " "))
1004 (chmod port #o555))))
1006 (gexp->derivation "run-vm.sh" builder)))
1010 ;;; High-level abstraction.
1013 (define-record-type* <virtual-machine> %virtual-machine
1014 make-virtual-machine
1016 (operating-system virtual-machine-operating-system) ;<operating-system>
1017 (qemu virtual-machine-qemu ;<package>
1019 (graphic? virtual-machine-graphic? ;Boolean
1021 (memory-size virtual-machine-memory-size ;integer (MiB)
1023 (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
1025 (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
1028 (define-syntax virtual-machine
1030 "Declare a virtual machine running the specified OS, with the given
1033 (%virtual-machine (operating-system os)))
1035 (%virtual-machine fields ...))))
1037 (define (port-forwardings->qemu-options forwardings)
1038 "Return the QEMU option for the given port FORWARDINGS as a string, where
1039 FORWARDINGS is a list of host-port/guest-port pairs."
1042 ((host-port . guest-port)
1043 (string-append "hostfwd=tcp::"
1044 (number->string host-port)
1045 "-:" (number->string guest-port))))
1049 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
1051 ;; XXX: SYSTEM and TARGET are ignored.
1053 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
1054 (system-qemu-image/shared-store-script os
1057 #:memory-size memory-size
1060 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size
1063 `("-nic" ,(string-append
1064 "user,model=virtio-net-pci,"
1065 (port-forwardings->qemu-options forwardings)))))
1066 (system-qemu-image/shared-store-script os
1069 #:memory-size memory-size
1072 #:options options)))))
1074 ;;; vm.scm ends here