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