HCoop / jackhill / guix / guix.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
vm: Allow users to specify a UUID for the root partition.
[jackhill/guix/guix.git] / gnu / system / vm.scm
CommitLineData
04086015 1;;; GNU Guix --- Functional package management for GNU
a8ac4f08 2;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
944d2b17
CAW		 3;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
07f812c4 5;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
ecf5d537 6;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
04086015
LC		 7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23(define-module (gnu system vm)
93d44bd8 24 #:use-module (guix config)
04086015 25 #:use-module (guix store)
02100028 26 #:use-module (guix gexp)
04086015
LC		 27 #:use-module (guix derivations)
28 #:use-module (guix packages)
d9f0a237 29 #:use-module (guix monads)
fcf63cf8 30 #:use-module (guix records)
239c6e27 31 #:use-module (guix modules)
fcf63cf8 32
548f7a8f 33 #:use-module ((gnu build vm)
66670cf3 34 #:select (qemu-command))
bdb36958 35 #:use-module (gnu packages base)
862e38d5 36 #:use-module (gnu packages bootloaders)
be1033a3 37 #:use-module (gnu packages cdrom)
1b89a66e 38 #:use-module (gnu packages guile)
bdb36958 39 #:use-module (gnu packages gawk)
1b89a66e 40 #:use-module (gnu packages bash)
4f62d8d6 41 #:use-module (gnu packages less)
59132b80 42 #:use-module (gnu packages virtualization)
cc4a2aeb 43 #:use-module (gnu packages disk)
5b16ff09 44 #:use-module (gnu packages zile)
04086015 45 #:use-module (gnu packages linux)
30f25b03 46 #:use-module (gnu packages package-management)
04086015
LC		 47 #:use-module ((gnu packages make-bootstrap)
48 #:select (%guile-static-stripped))
9de46ffb 49 #:use-module (gnu packages admin)
0ded70f3 50
9121ce55 51 #:use-module (gnu bootloader)
cf189709 52 #:use-module ((gnu bootloader grub) #:select (grub-mkrescue-bootloader))
0ded70f3 53 #:use-module (gnu system shadow)
6e828634 54 #:use-module (gnu system pam)
735c6dd7 55 #:use-module (gnu system linux-initrd)
b09a8da4 56 #:use-module (gnu bootloader)
c5df1839 57 #:use-module (gnu system file-systems)
033adfe7 58 #:use-module (gnu system)
db4fdc04 59 #:use-module (gnu services)
9b336338 60 #:use-module (gnu system uuid)
0ded70f3 61
ca85d7bc 62 #:use-module (srfi srfi-1)
04086015
LC		 63 #:use-module (srfi srfi-26)
64 #:use-module (ice-9 match)
0ded70f3 65
04086015 66 #:export (expression->derivation-in-linux-vm
aedb72fb 67 qemu-image
e9f693d0 68 virtualized-operating-system
fd3bfc44 69 system-qemu-image
fcf63cf8 70
fd3bfc44 71 system-qemu-image/shared-store
1e77fedb 72 system-qemu-image/shared-store-script
ed419fa0
LC		 73 system-disk-image
74
75 virtual-machine
76 virtual-machine?))
04086015
LC		 77
78\f
79;;; Commentary:
80;;;
81;;; Tools to evaluate build expressions within virtual machines.
82;;;
83;;; Code:
84
83bcd0b8
LC		 85(define %linux-vm-file-systems
86 ;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg
87 ;; directory are shared with the host over 9p.
88 (list (file-system
89 (mount-point (%store-prefix))
90 (device "store")
91 (type "9p")
92 (needed-for-boot? #t)
3c05b4bc
LC		 93 (options "trans=virtio")
94 (check? #f))
83bcd0b8
LC		 95 (file-system
96 (mount-point "/xchg")
97 (device "xchg")
98 (type "9p")
99 (needed-for-boot? #t)
3c05b4bc
LC		 100 (options "trans=virtio")
101 (check? #f))))
83bcd0b8 102
d9f0a237 103(define* (expression->derivation-in-linux-vm name exp
04086015 104 #:key
2455085a 105 (system (%current-system))
04086015 106 (linux linux-libre)
735c6dd7 107 initrd
06da1a6b 108 (qemu qemu-minimal)
04086015 109 (env-vars '())
04086015
LC		 110 (guile-for-build
111 (%guile-for-build))
112
8d033e3e 113 (single-file-output? #f)
04086015 114 (make-disk-image? #f)
ca85d7bc 115 (references-graphs #f)
defa1b9b 116 (memory-size 256)
c4a74364 117 (disk-image-format "qcow2")
a8ac4f08 118 (disk-image-size 'guess))
735c6dd7 119 "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
8d033e3e
LC		 120derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
121virtual machine, EXP has access to all its inputs from the store; it should
122put its output file(s) in the '/xchg' directory.
123
124If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
125Otherwise, copy the contents of /xchg to a new directory OUTPUT.
04086015 126
c4a74364
LC		 127When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
128DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
a8ac4f08
LC		 129return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
130based on the size of the closure of REFERENCES-GRAPHS.
ca85d7bc
LC		 131
132When REFERENCES-GRAPHS is true, it must be a list of file name/store path
133pairs, as for `derivation'. The files containing the reference graphs are
134made available under the /xchg CIFS share."
d9f0a237 135 (mlet* %store-monad
fd129893 136 ((user-builder (gexp->file "builder-in-linux-vm" exp))
02100028 137 (loader (gexp->file "linux-vm-loader"
fd129893 138 #~(primitive-load #$user-builder)))
bdb36958 139 (coreutils -> (canonical-package coreutils))
d4254711 140 (initrd (if initrd ; use the default initrd?
735c6dd7 141 (return initrd)
060238ae 142 (base-initrd %linux-vm-file-systems
0d275f4a 143 #:linux linux
24e0160a 144 #:virtio? #t
6c1df081 145 #:qemu-networking? #t))))
1aa0033b
LC		 146
147 (define builder
148 ;; Code that launches the VM that evaluates EXP.
239c6e27
LC		 149 (with-imported-modules (source-module-closure '((guix build utils)
150 (gnu build vm)))
4ee96a79
LC		 151 #~(begin
152 (use-modules (guix build utils)
153 (gnu build vm))
154
a8ac4f08
LC		 155 (let* ((inputs '#$(list qemu coreutils))
156 (linux (string-append #$linux "/"
157 #$(system-linux-image-file-name)))
158 (initrd (string-append #$initrd "/initrd"))
159 (loader #$loader)
160 (graphs '#$(match references-graphs
161 (((graph-files . _) ...) graph-files)
162 (_ #f)))
163 (size #$(if (eq? 'guess disk-image-size)
164 #~(+ (* 70 (expt 2 20)) ;ESP
165 (estimated-partition-size graphs))
166 disk-image-size)))
4ee96a79
LC		 167
168 (set-path-environment-variable "PATH" '("bin") inputs)
169
170 (load-in-linux-vm loader
171 #:output #$output
172 #:linux linux #:initrd initrd
173 #:memory-size #$memory-size
174 #:make-disk-image? #$make-disk-image?
8d033e3e 175 #:single-file-output? #$single-file-output?
4ee96a79 176 #:disk-image-format #$disk-image-format
a8ac4f08 177 #:disk-image-size size
4ee96a79 178 #:references-graphs graphs)))))
1aa0033b
LC		 179
180 (gexp->derivation name builder
181 ;; TODO: Require the "kvm" feature.
182 #:system system
183 #:env-vars env-vars
1aa0033b
LC		 184 #:guile-for-build guile-for-build
185 #:references-graphs references-graphs)))
d9f0a237 186
be1033a3
DM		 187(define* (iso9660-image #:key
188 (name "iso9660-image")
acc0f6bb
DM		 189 file-system-label
190 file-system-uuid
be1033a3
DM		 191 (system (%current-system))
192 (qemu qemu-minimal)
193 os-drv
194 bootcfg-drv
195 bootloader
e375d3fa 196 register-closures?
be1033a3
DM		 197 (inputs '()))
198 "Return a bootable, stand-alone iso9660 image.
199
200INPUTS is a list of inputs (as for packages)."
201 (expression->derivation-in-linux-vm
202 name
203 (with-imported-modules (source-module-closure '((gnu build vm)
204 (guix build utils)))
205 #~(begin
206 (use-modules (gnu build vm)
207 (guix build utils))
208
209 (let ((inputs
210 '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
211 (map canonical-package
e375d3fa
CB		 212 (list sed grep coreutils findutils gawk))
213 (if register-closures? (list guix) '())))
be1033a3 214
e375d3fa
CB		 215
216 (graphs '#$(match inputs
217 (((names . _) ...)
218 names)))
be1033a3
DM		 219 ;; This variable is unused but allows us to add INPUTS-TO-COPY
220 ;; as inputs.
221 (to-register
222 '#$(map (match-lambda
223 ((name thing) thing)
224 ((name thing output) `(,thing ,output)))
225 inputs)))
226
227 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
228 (make-iso9660-image #$(bootloader-package bootloader)
229 #$bootcfg-drv
230 #$os-drv
acc0f6bb 231 "/xchg/guixsd.iso"
e375d3fa
CB		 232 #:register-closures? #$register-closures?
233 #:closures graphs
acc0f6bb 234 #:volume-id #$file-system-label
9b336338
LC		 235 #:volume-uuid #$(and=> file-system-uuid
236 uuid-bytevector))
be1033a3
DM		 237 (reboot))))
238 #:system system
239 #:make-disk-image? #f
8d033e3e 240 #:single-file-output? #t
be1033a3
DM		 241 #:references-graphs inputs))
242
d9f0a237 243(define* (qemu-image #:key
04086015
LC		 244 (name "qemu-image")
245 (system (%current-system))
06da1a6b 246 (qemu qemu-minimal)
a8ac4f08 247 (disk-image-size 'guess)
c4a74364 248 (disk-image-format "qcow2")
03ddfaf5 249 (file-system-type "ext4")
ef9fc40d 250 file-system-label
fd3b4b98 251 file-system-uuid
9121ce55
MO		 252 os-drv
253 bootcfg-drv
254 bootloader
150e20dd 255 (register-closures? #t)
150e20dd
LC		 256 (inputs '())
257 copy-inputs?)
c4a74364 258 "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
ef9fc40d
LC		 259'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
260Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
fd3b4b98
LC		 261partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
262partition (a UUID object).
263
264The returned image is a full disk image that runs OS-DERIVATION,
f2c403ea
LC		 265with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
266file (GRUB-CONFIGURATION must be the name of a file in the VM.)
93d44bd8 267
150e20dd
LC		 268INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
269all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
270register INPUTS in the store database of the image so that Guix can be used in
b4140694 271the image."
b53833b2
LC		 272 (expression->derivation-in-linux-vm
273 name
239c6e27
LC		 274 (with-imported-modules (source-module-closure '((gnu build vm)
275 (guix build utils)))
fd129893
LC		 276 #~(begin
277 (use-modules (gnu build vm)
a8ac4f08
LC		 278 (guix build utils)
279 (srfi srfi-26))
1aa0033b 280
fd129893 281 (let ((inputs
4d415f0c 282 '#$(append (list qemu parted e2fsprogs dosfstools)
fd129893
LC		 283 (map canonical-package
284 (list sed grep coreutils findutils gawk))
285 (if register-closures? (list guix) '())))
1aa0033b 286
fd129893
LC		 287 ;; This variable is unused but allows us to add INPUTS-TO-COPY
288 ;; as inputs.
289 (to-register
290 '#$(map (match-lambda
291 ((name thing) thing)
292 ((name thing output) `(,thing ,output)))
293 inputs)))
1aa0033b 294
fd129893 295 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
1aa0033b 296
fd129893
LC		 297 (let* ((graphs '#$(match inputs
298 (((names . _) ...)
299 names)))
300 (initialize (root-partition-initializer
301 #:closures graphs
302 #:copy-closures? #$copy-inputs?
303 #:register-closures? #$register-closures?
9121ce55 304 #:system-directory #$os-drv))
a8ac4f08
LC		 305 (root-size #$(if (eq? 'guess disk-image-size)
306 #~(estimated-partition-size
307 (map (cut string-append "/xchg/" <>)
308 graphs))
309 (- disk-image-size
310 (* 50 (expt 2 20)))))
fd129893 311 (partitions (list (partition
a8ac4f08 312 (size root-size)
fd129893 313 (label #$file-system-label)
fd3b4b98
LC		 314 (uuid #$(and=> file-system-uuid
315 uuid-bytevector))
fd129893 316 (file-system #$file-system-type)
01cc84da 317 (flags '(boot))
ecf5d537
MB		 318 (initializer initialize))
319 ;; Append a small EFI System Partition for
320 ;; use with UEFI bootloaders.
321 (partition
322 ;; The standalone grub image is about 10MiB, but
323 ;; leave some room for custom or multiple images.
324 (size (* 40 (expt 2 20)))
325 (label "GNU-ESP") ;cosmetic only
326 ;; Use "vfat" here since this property is used
327 ;; when mounting. The actual FAT-ness is based
328 ;; on filesystem size (16 in this case).
329 (file-system "vfat")
330 (flags '(esp))))))
fd129893
LC		 331 (initialize-hard-disk "/dev/vda"
332 #:partitions partitions
ecf5d537 333 #:grub-efi #$grub-efi
9121ce55
MO		 334 #:bootloader-package
335 #$(bootloader-package bootloader)
336 #:bootcfg #$bootcfg-drv
337 #:bootcfg-location
338 #$(bootloader-configuration-file bootloader)
339 #:bootloader-installer
340 #$(bootloader-installer bootloader))
fd129893 341 (reboot)))))
b53833b2
LC		 342 #:system system
343 #:make-disk-image? #t
344 #:disk-image-size disk-image-size
345 #:disk-image-format disk-image-format
346 #:references-graphs inputs))
04086015
LC		 347
348\f
349;;;
1e77fedb 350;;; VM and disk images.
04086015
LC		 351;;;
352
1e77fedb
LC		 353(define* (system-disk-image os
354 #:key
56ef7fcc 355 (name "disk-image")
1e77fedb
LC		 356 (file-system-type "ext4")
357 (disk-image-size (* 900 (expt 2 20)))
358 (volatile? #t))
359 "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
360system described by OS. Said image can be copied on a USB stick as is. When
361VOLATILE? is true, the root file system is made volatile; this is useful
362to USB sticks meant to be read-only."
651de2bd
DM		 363 (define normalize-label
364 ;; ISO labels are all-caps (case-insensitive), but since
365 ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
366 (if (string=? "iso9660" file-system-type)
367 string-upcase
368 identity))
10ace2c4
LC		 369 (define root-label
370 ;; Volume name of the root file system. Since we don't know which device
371 ;; will hold it, we use the volume name to find it (using the UUID would
372 ;; be even better, but somewhat less convenient.)
0862b954 373 (normalize-label "GuixSD_image"))
10ace2c4 374
1e77fedb
LC		 375 (define file-systems-to-keep
376 (remove (lambda (fs)
377 (string=? (file-system-mount-point fs) "/"))
378 (operating-system-file-systems os)))
379
380 (let ((os (operating-system (inherit os)
932e1f92 381 ;; Since this is meant to be used on real hardware, don't
493c245b
LC		 382 ;; install QEMU networking or anything like that. Assume USB
383 ;; mass storage devices (usb-storage.ko) are available.
52ac153e
LC		 384 (initrd (lambda (file-systems . rest)
385 (apply base-initrd file-systems
386 #:volatile-root? #t
52ac153e 387 rest)))
1e77fedb 388
cf189709
DM		 389 (bootloader (if (string=? "iso9660" file-system-type)
390 (bootloader-configuration
391 (inherit (operating-system-bootloader os))
392 (bootloader grub-mkrescue-bootloader))
393 (operating-system-bootloader os)))
394
1e77fedb
LC		 395 ;; Force our own root file system.
396 (file-systems (cons (file-system
397 (mount-point "/")
10ace2c4 398 (device root-label)
d4c87617 399 (title 'label)
1e77fedb
LC		 400 (type file-system-type))
401 file-systems-to-keep)))))
402
403 (mlet* %store-monad ((os-drv (operating-system-derivation os))
c76b3046 404 (bootcfg (operating-system-bootcfg os)))
be1033a3
DM		 405 (if (string=? "iso9660" file-system-type)
406 (iso9660-image #:name name
acc0f6bb
DM		 407 #:file-system-label root-label
408 #:file-system-uuid #f
be1033a3 409 #:os-drv os-drv
b069111f 410 #:register-closures? #t
be1033a3
DM		 411 #:bootcfg-drv bootcfg
412 #:bootloader (bootloader-configuration-bootloader
413 (operating-system-bootloader os))
414 #:inputs `(("system" ,os-drv)
415 ("bootcfg" ,bootcfg)))
416 (qemu-image #:name name
417 #:os-drv os-drv
418 #:bootcfg-drv bootcfg
419 #:bootloader (bootloader-configuration-bootloader
420 (operating-system-bootloader os))
421 #:disk-image-size disk-image-size
422 #:disk-image-format "raw"
4138e782 423 #:file-system-type file-system-type
be1033a3
DM		 424 #:file-system-label root-label
425 #:copy-inputs? #t
426 #:register-closures? #t
427 #:inputs `(("system" ,os-drv)
428 ("bootcfg" ,bootcfg)))))))
1e77fedb 429
0b14d1d7 430(define* (system-qemu-image os
66f23d66
LC		 431 #:key
432 (file-system-type "ext4")
433 (disk-image-size (* 900 (expt 2 20))))
434 "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
435of the GNU system as described by OS."
1eeccc2f
LC		 436 (define file-systems-to-keep
437 ;; Keep only file systems other than root and not normally bound to real
438 ;; devices.
439 (remove (lambda (fs)
440 (let ((target (file-system-mount-point fs))
441 (source (file-system-device fs)))
442 (or (string=? target "/")
443 (string-prefix? "/dev/" source))))
444 (operating-system-file-systems os)))
445
66f23d66 446 (let ((os (operating-system (inherit os)
e84d8b30 447 ;; Use an initrd with the whole QEMU shebang.
52ac153e
LC		 448 (initrd (lambda (file-systems . rest)
449 (apply base-initrd file-systems
450 #:virtio? #t
52ac153e 451 rest)))
e84d8b30 452
1eeccc2f
LC		 453 ;; Force our own root file system.
454 (file-systems (cons (file-system
66f23d66
LC		 455 (mount-point "/")
456 (device "/dev/sda1")
1eeccc2f
LC		 457 (type file-system-type))
458 file-systems-to-keep)))))
66f23d66
LC		 459 (mlet* %store-monad
460 ((os-drv (operating-system-derivation os))
c76b3046 461 (bootcfg (operating-system-bootcfg os)))
9121ce55
MO		 462 (qemu-image #:os-drv os-drv
463 #:bootcfg-drv bootcfg
464 #:bootloader (bootloader-configuration-bootloader
465 (operating-system-bootloader os))
66f23d66
LC		 466 #:disk-image-size disk-image-size
467 #:file-system-type file-system-type
b4140694 468 #:inputs `(("system" ,os-drv)
07f812c4 469 ("bootcfg" ,bootcfg))
150e20dd 470 #:copy-inputs? #t))))
04086015 471
fcf63cf8
LC		 472\f
473;;;
474;;; VMs that share file systems with the host.
475;;;
476
96ffa27b
LC		 477(define (file-system->mount-tag fs)
478 "Return a 9p mount tag for host file system FS."
479 ;; QEMU mount tags cannot contain slashes and cannot start with '_'.
480 ;; Compute an identifier that corresponds to the rules.
481 (string-append "TAG"
482 (string-map (match-lambda
483 (#\/ #\_)
484 (chr chr))
485 fs)))
486
fcf63cf8
LC		 487(define (mapping->file-system mapping)
488 "Return a 9p file system that realizes MAPPING."
489 (match mapping
490 (($ <file-system-mapping> source target writable?)
491 (file-system
492 (mount-point target)
493 (device (file-system->mount-tag source))
494 (type "9p")
495 (flags (if writable? '() '(read-only)))
496 (options (string-append "trans=virtio"))
497 (check? #f)
498 (create-mount-point? #t)))))
499
909de139 500(define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
83bcd0b8 501 "Return an operating system based on OS suitable for use in a virtualized
fcf63cf8
LC		 502environment with the store shared with the host. MAPPINGS is a list of
503<file-system-mapping> to realize in the virtualized OS."
504 (define user-file-systems
505 ;; Remove file systems that conflict with those added below, or that are
506 ;; normally bound to real devices.
507 (remove (lambda (fs)
508 (let ((target (file-system-mount-point fs))
509 (source (file-system-device fs)))
510 (or (string=? target (%store-prefix))
511 (string=? target "/")
29824d80
LC		 512 (and (eq? 'device (file-system-title fs))
513 (string-prefix? "/dev/" source)))))
fcf63cf8
LC		 514 (operating-system-file-systems os)))
515
909de139
DC		 516 (define virtual-file-systems
517 (cons (file-system
518 (mount-point "/")
519 (device "/dev/vda1")
520 (type "ext4"))
521
522 (append (map mapping->file-system mappings)
523 user-file-systems)))
524
83bcd0b8 525 (operating-system (inherit os)
52ac153e
LC		 526 (initrd (lambda (file-systems . rest)
527 (apply base-initrd file-systems
528 #:volatile-root? #t
529 #:virtio? #t
52ac153e 530 rest)))
65fb4515
LC		 531
532 ;; Disable swap.
533 (swap-devices '())
534
909de139
DC		 535 ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
536 ;; since that would lead the bootloader config to look for the kernel and
537 ;; initrd in it.
538 (file-systems (if full-boot?
539 virtual-file-systems
540 (cons
541 (file-system
542 (inherit (mapping->file-system %store-mapping))
543 (needed-for-boot? #t))
544 virtual-file-systems)))))
83bcd0b8 545
fd3bfc44 546(define* (system-qemu-image/shared-store
0b14d1d7 547 os
6aa260af
LC		 548 #:key
549 full-boot?
4c0416ae 550 (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
fd3bfc44 551 "Return a derivation that builds a QEMU image of OS that shares its store
6aa260af
LC		 552with the host.
553
554When FULL-BOOT? is true, return an image that does a complete boot sequence,
555bootloaded included; thus, make a disk image that contains everything the
556bootloader refers to: OS kernel, initrd, bootloader data, etc."
557 (mlet* %store-monad ((os-drv (operating-system-derivation os))
c76b3046 558 (bootcfg (operating-system-bootcfg os)))
6aa260af 559 ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
07f812c4 560 ;; BOOTCFG and all its dependencies, including the output of OS-DRV.
6aa260af
LC		 561 ;; This is more than needed (we only need the kernel, initrd, GRUB for its
562 ;; font, and the background image), but it's hard to filter that.
9121ce55
MO		 563 (qemu-image #:os-drv os-drv
564 #:bootcfg-drv bootcfg
565 #:bootloader (bootloader-configuration-bootloader
566 (operating-system-bootloader os))
150e20dd 567 #:disk-image-size disk-image-size
6aa260af 568 #:inputs (if full-boot?
07f812c4 569 `(("bootcfg" ,bootcfg))
6aa260af 570 '())
150e20dd
LC		 571
572 ;; XXX: Passing #t here is too slow, so let it off by default.
573 #:register-closures? #f
6aa260af 574 #:copy-inputs? full-boot?)))
fd3bfc44 575
96ffa27b
LC		 576(define* (common-qemu-options image shared-fs)
577 "Return the a string-value gexp with the common QEMU options to boot IMAGE,
578with '-virtfs' options for the host file systems listed in SHARED-FS."
26a076ed 579
96ffa27b 580 (define (virtfs-option fs)
26a076ed
DC		 581 #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
582 #$fs #$(file-system->mount-tag fs)))
96ffa27b 583
26a076ed 584 #~(;; Only enable kvm if we see /dev/kvm exists.
944d2b17
CAW		 585 ;; This allows users without hardware virtualization to still use these
586 ;; commands.
26a076ed
DC		 587 #$@(if (file-exists? "/dev/kvm")
588 '("-enable-kvm")
589 '())
590
591 "-no-reboot"
592 "-net nic,model=virtio"
593
594 #$@(map virtfs-option shared-fs)
595 "-vga std"
596 (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
ebfb71d4 597 #$image)))
3c1f0e3b 598
ab11f0be
LC		 599(define* (system-qemu-image/shared-store-script os
600 #:key
601 (qemu qemu)
602 (graphic? #t)
ebfb71d4 603 (memory-size 256)
fcf63cf8 604 (mappings '())
6aa260af
LC		 605 full-boot?
606 (disk-image-size
9a1bfe76 607 (* (if full-boot? 500 70)
ed419fa0
LC		 608 (expt 2 20)))
609 (options '()))
fd3bfc44 610 "Return a derivation that builds a script to run a virtual machine image of
ebfb71d4
JN		 611OS that shares its store with the host. The virtual machine runs with
612MEMORY-SIZE MiB of memory.
6aa260af 613
fcf63cf8
LC		 614MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
615systems into the guest.
616
6aa260af
LC		 617When FULL-BOOT? is true, the returned script runs everything starting from the
618bootloader; otherwise it directly starts the operating system kernel. The
619DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
620it is mostly useful when FULL-BOOT? is true."
909de139 621 (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
6aa260af
LC		 622 (os-drv (operating-system-derivation os))
623 (image (system-qemu-image/shared-store
624 os
625 #:full-boot? full-boot?
626 #:disk-image-size disk-image-size)))
26a076ed 627 (define kernel-arguments
83071b05
DM		 628 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
629 #+@(operating-system-kernel-arguments os os-drv "/dev/vda1")))
26a076ed
DC		 630
631 (define qemu-exec
632 #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
633 #$@(if full-boot?
634 #~()
635 #~("-kernel" #$(operating-system-kernel-file os)
636 "-initrd" #$(file-append os-drv "/initrd")
637 (format #f "-append ~s"
638 (string-join #$kernel-arguments " "))))
639 #$@(common-qemu-options image
640 (map file-system-mapping-source
ebfb71d4 641 (cons %store-mapping mappings)))
ed419fa0
LC		 642 "-m " (number->string #$memory-size)
643 #$@options))
26a076ed 644
fd3bfc44 645 (define builder
02100028
LC		 646 #~(call-with-output-file #$output
647 (lambda (port)
26a076ed
DC		 648 (format port "#!~a~% exec ~a \"$@\"~%"
649 #$(file-append bash "/bin/sh")
650 (string-join #$qemu-exec " "))
02100028
LC		 651 (chmod port #o555))))
652
653 (gexp->derivation "run-vm.sh" builder)))
fd3bfc44 654
ed419fa0
LC		 655\f
656;;;
657;;; High-level abstraction.
658;;;
659
660(define-record-type* <virtual-machine> %virtual-machine
661 make-virtual-machine
662 virtual-machine?
663 (operating-system virtual-machine-operating-system) ;<operating-system>
664 (qemu virtual-machine-qemu ;<package>
665 (default qemu))
666 (graphic? virtual-machine-graphic? ;Boolean
667 (default #f))
668 (memory-size virtual-machine-memory-size ;integer (MiB)
669 (default 256))
670 (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
671 (default '())))
672
673(define-syntax virtual-machine
674 (syntax-rules ()
675 "Declare a virtual machine running the specified OS, with the given
676options."
677 ((_ os) ;shortcut
678 (%virtual-machine (operating-system os)))
679 ((_ fields ...)
680 (%virtual-machine fields ...))))
681
682(define (port-forwardings->qemu-options forwardings)
683 "Return the QEMU option for the given port FORWARDINGS as a string, where
684FORWARDINGS is a list of host-port/guest-port pairs."
685 (string-join
686 (map (match-lambda
687 ((host-port . guest-port)
688 (string-append "hostfwd=tcp::"
689 (number->string host-port)
690 "-:" (number->string guest-port))))
691 forwardings)
692 ","))
693
694(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
695 system target)
696 ;; XXX: SYSTEM and TARGET are ignored.
697 (match vm
698 (($ <virtual-machine> os qemu graphic? memory-size ())
699 (system-qemu-image/shared-store-script os
700 #:qemu qemu
701 #:graphic? graphic?
702 #:memory-size memory-size))
703 (($ <virtual-machine> os qemu graphic? memory-size forwardings)
704 (let ((options
705 `("-net" ,(string-append
706 "user,"
707 (port-forwardings->qemu-options forwardings)))))
708 (system-qemu-image/shared-store-script os
709 #:qemu qemu
710 #:graphic? graphic?
711 #:memory-size memory-size
712 #:options options)))))
713
04086015 714;;; vm.scm ends here
jackhill's copy of GNU Guix: https://guix.gnu.org/