HCoop / jackhill / guix / guix.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
gnu: Add r-depecher.
[jackhill/guix/guix.git] / gnu / system / vm.scm
CommitLineData
04086015 1;;; GNU Guix --- Functional package management for GNU
910d0121 2;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
944d2b17 3;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
2ca712bd 4;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
07f812c4 5;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
ecf5d537 6;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
8c9bf294 7;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
04086015
LC		 8;;;
9;;; This file is part of GNU Guix.
10;;;
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.
15;;;
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.
20;;;
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/>.
23
24(define-module (gnu system vm)
93d44bd8 25 #:use-module (guix config)
04086015 26 #:use-module (guix store)
02100028 27 #:use-module (guix gexp)
04086015
LC		 28 #:use-module (guix derivations)
29 #:use-module (guix packages)
d9f0a237 30 #:use-module (guix monads)
fcf63cf8 31 #:use-module (guix records)
239c6e27 32 #:use-module (guix modules)
00e39b2e 33 #:use-module (guix utils)
ca719424 34 #:use-module (gcrypt hash)
dffc5ab5 35 #:use-module (guix base32)
c45477d2 36 #:use-module ((guix self) #:select (make-config.scm))
fcf63cf8 37
548f7a8f 38 #:use-module ((gnu build vm)
66670cf3 39 #:select (qemu-command))
bdb36958 40 #:use-module (gnu packages base)
862e38d5 41 #:use-module (gnu packages bootloaders)
be1033a3 42 #:use-module (gnu packages cdrom)
a335f6fc 43 #:use-module (gnu packages compression)
1b89a66e 44 #:use-module (gnu packages guile)
ca719424 45 #:autoload (gnu packages gnupg) (guile-gcrypt)
bdb36958 46 #:use-module (gnu packages gawk)
1b89a66e 47 #:use-module (gnu packages bash)
4f62d8d6 48 #:use-module (gnu packages less)
59132b80 49 #:use-module (gnu packages virtualization)
cc4a2aeb 50 #:use-module (gnu packages disk)
5b16ff09 51 #:use-module (gnu packages zile)
04086015 52 #:use-module (gnu packages linux)
04086015
LC		 53 #:use-module ((gnu packages make-bootstrap)
54 #:select (%guile-static-stripped))
9de46ffb 55 #:use-module (gnu packages admin)
0ded70f3 56
9121ce55 57 #:use-module (gnu bootloader)
9b396c0c 58 #:use-module (gnu bootloader grub)
0ded70f3 59 #:use-module (gnu system shadow)
6e828634 60 #:use-module (gnu system pam)
69cae3d3 61 #:use-module (gnu system linux-container)
735c6dd7 62 #:use-module (gnu system linux-initrd)
b09a8da4 63 #:use-module (gnu bootloader)
c5df1839 64 #:use-module (gnu system file-systems)
033adfe7 65 #:use-module (gnu system)
db4fdc04 66 #:use-module (gnu services)
d03de6be 67 #:use-module (gnu services base)
9b336338 68 #:use-module (gnu system uuid)
0ded70f3 69
ca85d7bc 70 #:use-module (srfi srfi-1)
04086015 71 #:use-module (srfi srfi-26)
5f7fe1c5 72 #:use-module (rnrs bytevectors)
04086015 73 #:use-module (ice-9 match)
0ded70f3 74
04086015 75 #:export (expression->derivation-in-linux-vm
aedb72fb 76 qemu-image
e9f693d0 77 virtualized-operating-system
fd3bfc44 78 system-qemu-image
fcf63cf8 79
fd3bfc44 80 system-qemu-image/shared-store
1e77fedb 81 system-qemu-image/shared-store-script
ed419fa0 82 system-disk-image
a335f6fc 83 system-docker-image
ed419fa0
LC		 84
85 virtual-machine
86 virtual-machine?))
04086015
LC		 87
88\f
89;;; Commentary:
90;;;
91;;; Tools to evaluate build expressions within virtual machines.
92;;;
93;;; Code:
94
83bcd0b8 95(define %linux-vm-file-systems
8c9bf294
CM		 96 ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with
97 ;; the host over 9p.
66ec3895
LC		 98 ;;
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
103 ;; consistency.
83bcd0b8
LC		 104 (list (file-system
105 (mount-point (%store-prefix))
106 (device "store")
107 (type "9p")
108 (needed-for-boot? #t)
fce22547
LC		 109 (flags '(read-only))
110 (options "trans=virtio,cache=loose")
3c05b4bc 111 (check? #f))
83bcd0b8
LC		 112 (file-system
113 (mount-point "/xchg")
114 (device "xchg")
115 (type "9p")
116 (needed-for-boot? #t)
66ec3895 117 (options "trans=virtio")
8c9bf294
CM		 118 (check? #f))
119 (file-system
120 (mount-point "/tmp")
121 (device "tmp")
122 (type "9p")
123 (needed-for-boot? #t)
fce22547 124 (options "trans=virtio,cache=loose")
3c05b4bc 125 (check? #f))))
83bcd0b8 126
c45477d2
LC		 127(define not-config?
128 ;; Select (guix …) and (gnu …) modules, except (guix config).
129 (match-lambda
130 (('guix 'config) #f)
131 (('guix rest ...) #t)
132 (('gnu rest ...) #t)
133 (rest #f)))
134
ca719424
LC		 135(define gcrypt-sqlite3&co
136 ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
137 (append-map (lambda (package)
138 (cons package
910d0121
LC		 139 (match (package-transitive-propagated-inputs package)
140 (((labels packages) ...)
141 packages))))
ca719424 142 (list guile-gcrypt guile-sqlite3)))
c45477d2 143
d9f0a237 144(define* (expression->derivation-in-linux-vm name exp
04086015 145 #:key
2455085a 146 (system (%current-system))
04086015 147 (linux linux-libre)
735c6dd7 148 initrd
06da1a6b 149 (qemu qemu-minimal)
04086015 150 (env-vars '())
04086015
LC		 151 (guile-for-build
152 (%guile-for-build))
50e53c1c
LC		 153 (file-systems
154 %linux-vm-file-systems)
04086015 155
8d033e3e 156 (single-file-output? #f)
04086015 157 (make-disk-image? #f)
ca85d7bc 158 (references-graphs #f)
defa1b9b 159 (memory-size 256)
c4a74364 160 (disk-image-format "qcow2")
a8ac4f08 161 (disk-image-size 'guess))
735c6dd7 162 "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
8d033e3e 163derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
50e53c1c
LC		 164virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
1659p share of the store, the '/xchg' where EXP should put its output file(s),
166and a 9p share of /tmp.
8d033e3e
LC		 167
168If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
169Otherwise, copy the contents of /xchg to a new directory OUTPUT.
04086015 170
c4a74364
LC		 171When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
172DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
a8ac4f08
LC		 173return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
174based on the size of the closure of REFERENCES-GRAPHS.
ca85d7bc
LC		 175
176When REFERENCES-GRAPHS is true, it must be a list of file name/store path
177pairs, as for `derivation'. The files containing the reference graphs are
178made available under the /xchg CIFS share."
be43c08b
LC		 179 (define user-builder
180 (program-file "builder-in-linux-vm" exp))
181
182 (define loader
183 ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
184 ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
185 ;; Guile, which it couldn't do using the statically-linked guile used in
186 ;; the initrd. See example at
187 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
188 (program-file "linux-vm-loader"
189 ;; When USER-BUILDER succeeds, reboot (indicating a
190 ;; success), otherwise die, which causes a kernel panic
191 ;; ("Attempted to kill init!").
e6c46ec4
LC		 192 #~(if (zero? (system* #$user-builder))
193 (reboot)
194 (exit 1))))
be43c08b 195
e34ae75d
LC		 196 (let ((initrd (or initrd
197 (base-initrd file-systems
198 #:on-error 'backtrace
199 #:linux linux
200 #:linux-modules %base-initrd-modules
201 #:qemu-networking? #t))))
1aa0033b
LC		 202
203 (define builder
204 ;; Code that launches the VM that evaluates EXP.
ca719424 205 (with-extensions gcrypt-sqlite3&co
c45477d2
LC		 206 (with-imported-modules `(,@(source-module-closure
207 '((guix build utils)
208 (gnu build vm))
209 #:select? not-config?)
ca719424
LC		 210
211 ;; For consumption by (gnu store database).
212 ((guix config) => ,(make-config.scm)))
c45477d2
LC		 213 #~(begin
214 (use-modules (guix build utils)
215 (gnu build vm))
216
217 (let* ((inputs '#$(list qemu (canonical-package coreutils)))
218 (linux (string-append #$linux "/"
219 #$(system-linux-image-file-name)))
d422cbb3 220 (initrd #$initrd)
c45477d2
LC		 221 (loader #$loader)
222 (graphs '#$(match references-graphs
223 (((graph-files . _) ...) graph-files)
224 (_ #f)))
225 (size #$(if (eq? 'guess disk-image-size)
226 #~(+ (* 70 (expt 2 20)) ;ESP
227 (estimated-partition-size graphs))
228 disk-image-size)))
229
230 (set-path-environment-variable "PATH" '("bin") inputs)
231
232 (load-in-linux-vm loader
233 #:output #$output
234 #:linux linux #:initrd initrd
235 #:memory-size #$memory-size
236 #:make-disk-image? #$make-disk-image?
237 #:single-file-output? #$single-file-output?
238 ;; FIXME: ‘target-arm32?’ may not operate on
239 ;; the right system/target values. Rewrite
240 ;; using ‘let-system’ when available.
241 #:target-arm32? #$(target-arm32?)
242 #:disk-image-format #$disk-image-format
243 #:disk-image-size size
244 #:references-graphs graphs))))))
1aa0033b
LC		 245
246 (gexp->derivation name builder
247 ;; TODO: Require the "kvm" feature.
248 #:system system
249 #:env-vars env-vars
1aa0033b
LC		 250 #:guile-for-build guile-for-build
251 #:references-graphs references-graphs)))
d9f0a237 252
d03de6be
MC		 253(define (has-guix-service-type? os)
254 "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
255 (not (not (find (lambda (service)
256 (eq? (service-kind service) guix-service-type))
257 (operating-system-services os)))))
258
be1033a3
DM		 259(define* (iso9660-image #:key
260 (name "iso9660-image")
acc0f6bb
DM		 261 file-system-label
262 file-system-uuid
be1033a3
DM		 263 (system (%current-system))
264 (qemu qemu-minimal)
8bff7dc2 265 os
be1033a3
DM		 266 bootcfg-drv
267 bootloader
d03de6be 268 (register-closures? (has-guix-service-type? os))
1d86b056
DM		 269 (inputs '())
270 (grub-mkrescue-environment '()))
be1033a3
DM		 271 "Return a bootable, stand-alone iso9660 image.
272
273INPUTS is a list of inputs (as for packages)."
c45477d2
LC		 274 (define schema
275 (and register-closures?
276 (local-file (search-path %load-path
277 "guix/store/schema.sql"))))
278
be1033a3
DM		 279 (expression->derivation-in-linux-vm
280 name
ca719424 281 (with-extensions gcrypt-sqlite3&co
c45477d2
LC		 282 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
283 (guix store database)
284 (guix build utils))
285 #:select? not-config?)
ca719424 286 ((guix config) => ,(make-config.scm)))
c45477d2
LC		 287 #~(begin
288 (use-modules (gnu build vm)
289 (guix store database)
290 (guix build utils))
291
292 (sql-schema #$schema)
293
9c941364
LC		 294 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
295 (setenv "GUIX_LOCPATH"
296 #+(file-append glibc-utf8-locales "/lib/locale"))
297 (setlocale LC_ALL "en_US.utf8")
298
c45477d2
LC		 299 (let ((inputs
300 '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
301 (map canonical-package
302 (list sed grep coreutils findutils gawk))))
303
304
305 (graphs '#$(match inputs
306 (((names . _) ...)
307 names)))
308 ;; This variable is unused but allows us to add INPUTS-TO-COPY
309 ;; as inputs.
310 (to-register
311 '#$(map (match-lambda
312 ((name thing) thing)
313 ((name thing output) `(,thing ,output)))
314 inputs)))
315
316 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
1d86b056
DM		 317 (make-iso9660-image #$xorriso
318 '#$grub-mkrescue-environment
319 #$(bootloader-package bootloader)
c45477d2 320 #$bootcfg-drv
8bff7dc2 321 #$os
c45477d2
LC		 322 "/xchg/guixsd.iso"
323 #:register-closures? #$register-closures?
324 #:closures graphs
325 #:volume-id #$file-system-label
326 #:volume-uuid #$(and=> file-system-uuid
327 uuid-bytevector))))))
be1033a3 328 #:system system
fb126314
LC		 329
330 ;; Keep a local file system for /tmp so that we can populate it directly as
331 ;; root and have files owned by root. See <https://bugs.gnu.org/31752>.
332 #:file-systems (remove (lambda (file-system)
333 (string=? (file-system-mount-point file-system)
334 "/tmp"))
335 %linux-vm-file-systems)
336
be1033a3 337 #:make-disk-image? #f
8d033e3e 338 #:single-file-output? #t
45c0d1d7
LC		 339 #:references-graphs inputs
340
341 ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size.
342 #:memory-size 512))
be1033a3 343
d9f0a237 344(define* (qemu-image #:key
04086015
LC		 345 (name "qemu-image")
346 (system (%current-system))
06da1a6b 347 (qemu qemu-minimal)
a8ac4f08 348 (disk-image-size 'guess)
c4a74364 349 (disk-image-format "qcow2")
03ddfaf5 350 (file-system-type "ext4")
ef9fc40d 351 file-system-label
fd3b4b98 352 file-system-uuid
8bff7dc2 353 os
9121ce55
MO		 354 bootcfg-drv
355 bootloader
d03de6be 356 (register-closures? (has-guix-service-type? os))
150e20dd
LC		 357 (inputs '())
358 copy-inputs?)
c4a74364 359 "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
ef9fc40d
LC		 360'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
361Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
fd3b4b98
LC		 362partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
363partition (a UUID object).
364
365The returned image is a full disk image that runs OS-DERIVATION,
f2c403ea
LC		 366with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
367file (GRUB-CONFIGURATION must be the name of a file in the VM.)
93d44bd8 368
150e20dd
LC		 369INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
370all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
371register INPUTS in the store database of the image so that Guix can be used in
d03de6be
MC		 372the image. By default, REGISTER-CLOSURES? is set to true only if a service of
373type GUIX-SERVICE-TYPE is present in the services definition of the operating
374system."
c45477d2
LC		 375 (define schema
376 (and register-closures?
377 (local-file (search-path %load-path
378 "guix/store/schema.sql"))))
379
b53833b2
LC		 380 (expression->derivation-in-linux-vm
381 name
ca719424 382 (with-extensions gcrypt-sqlite3&co
c45477d2
LC		 383 (with-imported-modules `(,@(source-module-closure '((gnu build vm)
384 (gnu build bootloader)
385 (guix store database)
386 (guix build utils))
387 #:select? not-config?)
ca719424 388 ((guix config) => ,(make-config.scm)))
c45477d2
LC		 389 #~(begin
390 (use-modules (gnu build bootloader)
391 (gnu build vm)
392 (guix store database)
393 (guix build utils)
394 (srfi srfi-26)
395 (ice-9 binary-ports))
396
397 (sql-schema #$schema)
398
9c941364
LC		 399 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
400 (setenv "GUIX_LOCPATH"
401 #+(file-append glibc-utf8-locales "/lib/locale"))
402 (setlocale LC_ALL "en_US.utf8")
403
c45477d2
LC		 404 (let ((inputs
405 '#$(append (list qemu parted e2fsprogs dosfstools)
406 (map canonical-package
407 (list sed grep coreutils findutils gawk))))
408
409 ;; This variable is unused but allows us to add INPUTS-TO-COPY
410 ;; as inputs.
411 (to-register
412 '#$(map (match-lambda
413 ((name thing) thing)
414 ((name thing output) `(,thing ,output)))
415 inputs)))
416
417 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
418
419 (let* ((graphs '#$(match inputs
420 (((names . _) ...)
421 names)))
422 (initialize (root-partition-initializer
423 #:closures graphs
424 #:copy-closures? #$copy-inputs?
425 #:register-closures? #$register-closures?
8bff7dc2 426 #:system-directory #$os
b5460d95
LC		 427
428 ;; Disable deduplication to speed things up,
429 ;; and because it doesn't help much for a
430 ;; single system generation.
431 #:deduplicate? #f))
c45477d2
LC		 432 (root-size #$(if (eq? 'guess disk-image-size)
433 #~(max
434 ;; Minimum 20 MiB root size
435 (* 20 (expt 2 20))
436 (estimated-partition-size
437 (map (cut string-append "/xchg/" <>)
438 graphs)))
439 (- disk-image-size
440 (* 50 (expt 2 20)))))
441 (partitions
442 (append
443 (list (partition
444 (size root-size)
445 (label #$file-system-label)
446 (uuid #$(and=> file-system-uuid
447 uuid-bytevector))
448 (file-system #$file-system-type)
449 (flags '(boot))
450 (initializer initialize)))
451 ;; Append a small EFI System Partition for use with UEFI
452 ;; bootloaders if we are not targeting ARM because UEFI
453 ;; support in U-Boot is experimental.
454 ;;
455 ;; FIXME: ‘target-arm32?’ may be not operate on the right
456 ;; system/target values. Rewrite using ‘let-system’ when
457 ;; available.
458 (if #$(target-arm32?)
459 '()
460 (list (partition
461 ;; The standalone grub image is about 10MiB, but
462 ;; leave some room for custom or multiple images.
463 (size (* 40 (expt 2 20)))
464 (label "GNU-ESP") ;cosmetic only
465 ;; Use "vfat" here since this property is used
466 ;; when mounting. The actual FAT-ness is based
467 ;; on file system size (16 in this case).
468 (file-system "vfat")
469 (flags '(esp))))))))
470 (initialize-hard-disk "/dev/vda"
471 #:partitions partitions
472 #:grub-efi #$grub-efi
473 #:bootloader-package
474 #$(bootloader-package bootloader)
475 #:bootcfg #$bootcfg-drv
476 #:bootcfg-location
477 #$(bootloader-configuration-file bootloader)
478 #:bootloader-installer
479 #$(bootloader-installer bootloader)))))))
b53833b2
LC		 480 #:system system
481 #:make-disk-image? #t
482 #:disk-image-size disk-image-size
483 #:disk-image-format disk-image-format
484 #:references-graphs inputs))
04086015 485
a335f6fc
CM		 486(define* (system-docker-image os
487 #:key
247649d4 488 (name "guix-docker-image")
d03de6be 489 (register-closures? (has-guix-service-type? os)))
a335f6fc 490 "Build a docker image. OS is the desired <operating-system>. NAME is the
d03de6be
MC		 491base name to use for the output file. When REGISTER-CLOSURES? is true,
492register the closure of OS with Guix in the resulting Docker image. By
493default, REGISTER-CLOSURES? is set to true only if a service of type
494GUIX-SERVICE-TYPE is present in the services definition of the operating
495system."
c45477d2
LC		 496 (define schema
497 (and register-closures?
498 (local-file (search-path %load-path
499 "guix/store/schema.sql"))))
9f160a0d 500
247649d4
LC		 501 (define boot-program
502 ;; Program that runs the boot script of OS, which in turn starts shepherd.
503 (program-file "boot-program"
504 #~(let ((system (cadr (command-line))))
505 (setenv "GUIX_NEW_SYSTEM" system)
506 (execl #$(file-append guile-2.2 "/bin/guile")
507 "guile" "--no-auto-compile"
508 (string-append system "/boot")))))
509
510
511 (let ((os (operating-system-with-gc-roots
512 (containerized-operating-system os '())
513 (list boot-program)))
69cae3d3
LC		 514 (name (string-append name ".tar.gz"))
515 (graph "system-graph"))
a335f6fc 516 (define build
ca719424
LC		 517 (with-extensions (cons guile-json ;for (guix docker)
518 gcrypt-sqlite3&co) ;for (guix store database)
9f160a0d
LC		 519 (with-imported-modules `(,@(source-module-closure
520 '((guix docker)
c45477d2 521 (guix store database)
9f160a0d 522 (guix build utils)
c45477d2 523 (guix build store-copy)
9f160a0d
LC		 524 (gnu build vm))
525 #:select? not-config?)
ca719424 526 ((guix config) => ,(make-config.scm)))
9f160a0d
LC		 527 #~(begin
528 (use-modules (guix docker)
529 (guix build utils)
530 (gnu build vm)
531 (srfi srfi-19)
c45477d2
LC		 532 (guix build store-copy)
533 (guix store database))
534
535 ;; Set the SQL schema location.
536 (sql-schema #$schema)
9f160a0d 537
ed504caf
LC		 538 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
539 (setenv "GUIX_LOCPATH"
540 #+(file-append glibc-utf8-locales "/lib/locale"))
541 (setlocale LC_ALL "en_US.utf8")
542
c45477d2 543 (let* (;; This initializer requires elevated privileges that are
9f160a0d
LC		 544 ;; not normally available in the build environment (e.g.,
545 ;; it needs to create device nodes). In order to obtain
546 ;; such privileges, we run it as root in a VM.
547 (initialize (root-partition-initializer
548 #:closures '(#$graph)
549 #:register-closures? #$register-closures?
69cae3d3 550 #:system-directory #$os
9f160a0d
LC		 551 ;; De-duplication would fail due to
552 ;; cross-device link errors, so don't do it.
553 #:deduplicate? #f))
554 ;; Even as root in a VM, the initializer would fail due to
555 ;; lack of privileges if we use a root-directory that is on
556 ;; a file system that is shared with the host (e.g., /tmp).
557 (root-directory "/guixsd-system-root"))
c45477d2 558 (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
9f160a0d
LC		 559 (mkdir root-directory)
560 (initialize root-directory)
561 (build-docker-image
562 (string-append "/xchg/" #$name) ;; The output file.
563 (cons* root-directory
6892f0a2
LC		 564 (map store-info-item
565 (call-with-input-file
566 (string-append "/xchg/" #$graph)
567 read-reference-graph)))
69cae3d3 568 #$os
247649d4 569 #:entry-point '(#$boot-program #$os)
9f160a0d
LC		 570 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
571 #:creation-time (make-time time-utc 0 1)
66ec3895 572 #:transformations `((,root-directory -> ""))))))))
247649d4 573
a335f6fc 574 (expression->derivation-in-linux-vm
be43c08b 575 name build
a335f6fc
CM		 576 #:make-disk-image? #f
577 #:single-file-output? #t
69cae3d3 578 #:references-graphs `((,graph ,os)))))
a335f6fc 579
04086015
LC		 580\f
581;;;
1e77fedb 582;;; VM and disk images.
04086015
LC		 583;;;
584
5f7fe1c5
LC		 585(define* (operating-system-uuid os #:optional (type 'dce))
586 "Compute UUID object with a deterministic \"UUID\" for OS, of the given
587TYPE (one of 'iso9660 or 'dce). Return a UUID object."
1540075c
LC		 588 ;; Note: For this to be deterministic, we must not hash things that contains
589 ;; (directly or indirectly) procedures, for example. That rules out
590 ;; anything that contains gexps, thunk or delayed record fields, etc.
591
592 (define service-name
593 (compose service-type-name service-kind))
594
595 (define (file-system-digest fs)
596 ;; Return a hashable digest that does not contain 'dependencies' since
597 ;; this field can contain procedures.
598 (let ((device (file-system-device fs)))
599 (list (file-system-mount-point fs)
600 (file-system-type fs)
601 (cond ((file-system-label? device)
602 (file-system-label->string device))
603 ((uuid? device)
604 (uuid->string device))
605 ((string? device)
606 device)
607 (else #f))
608 (file-system-options fs))))
609
5f7fe1c5
LC		 610 (if (eq? type 'iso9660)
611 (let ((pad (compose (cut string-pad <> 2 #\0)
612 number->string))
1540075c
LC		 613 (h (hash (map service-name (operating-system-services os))
614 3600)))
5f7fe1c5
LC		 615 (bytevector->uuid
616 (string->iso9660-uuid
617 (string-append "1970-01-01-"
618 (pad (hash (operating-system-host-name os) 24)) "-"
619 (pad (quotient h 60)) "-"
620 (pad (modulo h 60)) "-"
1540075c
LC		 621 (pad (hash (map file-system-digest
622 (operating-system-file-systems os))
623 100))))
5f7fe1c5
LC		 624 'iso9660))
625 (bytevector->uuid
626 (uint-list->bytevector
627 (list (hash file-system-type
b1a30793 628 (- (expt 2 32) 1))
5f7fe1c5 629 (hash (operating-system-host-name os)
b1a30793 630 (- (expt 2 32) 1))
1540075c 631 (hash (map service-name (operating-system-services os))
b1a30793 632 (- (expt 2 32) 1))
1540075c 633 (hash (map file-system-digest (operating-system-file-systems os))
b1a30793 634 (- (expt 2 32) 1)))
5f7fe1c5
LC		 635 (endianness little)
636 4)
637 type)))
638
1e77fedb
LC		 639(define* (system-disk-image os
640 #:key
56ef7fcc 641 (name "disk-image")
1e77fedb
LC		 642 (file-system-type "ext4")
643 (disk-image-size (* 900 (expt 2 20)))
644 (volatile? #t))
645 "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
646system described by OS. Said image can be copied on a USB stick as is. When
647VOLATILE? is true, the root file system is made volatile; this is useful
648to USB sticks meant to be read-only."
651de2bd
DM		 649 (define normalize-label
650 ;; ISO labels are all-caps (case-insensitive), but since
651 ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
652 (if (string=? "iso9660" file-system-type)
653 string-upcase
654 identity))
5f7fe1c5 655
10ace2c4 656 (define root-label
5f7fe1c5 657 ;; Volume name of the root file system.
59e80445 658 (normalize-label "Guix_image"))
10ace2c4 659
5be7aecd 660 (define (root-uuid os)
5f7fe1c5
LC		 661 ;; UUID of the root file system, computed in a deterministic fashion.
662 ;; This is what we use to locate the root file system so it has to be
663 ;; different from the user's own file system UUIDs.
664 (operating-system-uuid os
665 (if (string=? file-system-type "iso9660")
666 'iso9660
667 'dce)))
668
1e77fedb
LC		 669 (define file-systems-to-keep
670 (remove (lambda (fs)
671 (string=? (file-system-mount-point fs) "/"))
672 (operating-system-file-systems os)))
673
8bff7dc2
LC		 674 (let* ((os (operating-system (inherit os)
675 ;; Since this is meant to be used on real hardware, don't
676 ;; install QEMU networking or anything like that. Assume USB
677 ;; mass storage devices (usb-storage.ko) are available.
678 (initrd (lambda (file-systems . rest)
679 (apply (operating-system-initrd os)
680 file-systems
681 #:volatile-root? #t
682 rest)))
683
684 (bootloader (if (string=? "iso9660" file-system-type)
685 (bootloader-configuration
686 (inherit (operating-system-bootloader os))
687 (bootloader grub-mkrescue-bootloader))
688 (operating-system-bootloader os)))
689
5be7aecd
LC		 690 ;; Force our own root file system. (We need a "/" file system
691 ;; to call 'root-uuid'.)
8bff7dc2
LC		 692 (file-systems (cons (file-system
693 (mount-point "/")
5be7aecd
LC		 694 (device "/dev/placeholder")
695 (type file-system-type))
696 file-systems-to-keep))))
697 (uuid (root-uuid os))
698 (os (operating-system
699 (inherit os)
700 (file-systems (cons (file-system
701 (mount-point "/")
702 (device uuid)
8bff7dc2
LC		 703 (type file-system-type))
704 file-systems-to-keep))))
705 (bootcfg (operating-system-bootcfg os)))
706 (if (string=? "iso9660" file-system-type)
707 (iso9660-image #:name name
708 #:file-system-label root-label
5be7aecd 709 #:file-system-uuid uuid
8bff7dc2 710 #:os os
8bff7dc2
LC		 711 #:bootcfg-drv bootcfg
712 #:bootloader (bootloader-configuration-bootloader
713 (operating-system-bootloader os))
714 #:inputs `(("system" ,os)
1d86b056
DM		 715 ("bootcfg" ,bootcfg))
716 #:grub-mkrescue-environment
717 '(("MKRESCUE_SED_MODE" . "mbr_hfs")))
8bff7dc2
LC		 718 (qemu-image #:name name
719 #:os os
720 #:bootcfg-drv bootcfg
721 #:bootloader (bootloader-configuration-bootloader
722 (operating-system-bootloader os))
723 #:disk-image-size disk-image-size
724 #:disk-image-format "raw"
725 #:file-system-type file-system-type
726 #:file-system-label root-label
5be7aecd 727 #:file-system-uuid uuid
8bff7dc2 728 #:copy-inputs? #t
8bff7dc2
LC		 729 #:inputs `(("system" ,os)
730 ("bootcfg" ,bootcfg))))))
1e77fedb 731
0b14d1d7 732(define* (system-qemu-image os
66f23d66
LC		 733 #:key
734 (file-system-type "ext4")
735 (disk-image-size (* 900 (expt 2 20))))
736 "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
737of the GNU system as described by OS."
1eeccc2f
LC		 738 (define file-systems-to-keep
739 ;; Keep only file systems other than root and not normally bound to real
740 ;; devices.
741 (remove (lambda (fs)
742 (let ((target (file-system-mount-point fs))
743 (source (file-system-device fs)))
744 (or (string=? target "/")
745 (string-prefix? "/dev/" source))))
746 (operating-system-file-systems os)))
747
61b94b8c
LC		 748 (define root-uuid
749 ;; UUID of the root file system.
750 (operating-system-uuid os
751 (if (string=? file-system-type "iso9660")
752 'iso9660
753 'dce)))
754
755
8bff7dc2
LC		 756 (let* ((os (operating-system (inherit os)
757 ;; Assume we have an initrd with the whole QEMU shebang.
758
759 ;; Force our own root file system. Refer to it by UUID so that
760 ;; it works regardless of how the image is used ("qemu -hda",
761 ;; Xen, etc.).
762 (file-systems (cons (file-system
763 (mount-point "/")
764 (device root-uuid)
765 (type file-system-type))
766 file-systems-to-keep))))
767 (bootcfg (operating-system-bootcfg os)))
768 (qemu-image #:os os
769 #:bootcfg-drv bootcfg
770 #:bootloader (bootloader-configuration-bootloader
771 (operating-system-bootloader os))
772 #:disk-image-size disk-image-size
773 #:file-system-type file-system-type
774 #:file-system-uuid root-uuid
775 #:inputs `(("system" ,os)
776 ("bootcfg" ,bootcfg))
777 #:copy-inputs? #t)))
04086015 778
fcf63cf8
LC		 779\f
780;;;
781;;; VMs that share file systems with the host.
782;;;
783
96ffa27b
LC		 784(define (file-system->mount-tag fs)
785 "Return a 9p mount tag for host file system FS."
dffc5ab5
LC		 786 ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
787 ;; slashes, and cannot start with '_'. Compute an identifier that
788 ;; corresponds to the rules.
96ffa27b 789 (string-append "TAG"
dffc5ab5
LC		 790 (string-drop (bytevector->base32-string
791 (sha1 (string->utf8 fs)))
792 4)))
96ffa27b 793
fcf63cf8
LC		 794(define (mapping->file-system mapping)
795 "Return a 9p file system that realizes MAPPING."
796 (match mapping
797 (($ <file-system-mapping> source target writable?)
798 (file-system
799 (mount-point target)
800 (device (file-system->mount-tag source))
801 (type "9p")
802 (flags (if writable? '() '(read-only)))
e0d96774 803 (options "trans=virtio,cache=loose")
fcf63cf8
LC		 804 (check? #f)
805 (create-mount-point? #t)))))
806
909de139 807(define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
83bcd0b8 808 "Return an operating system based on OS suitable for use in a virtualized
fcf63cf8
LC		 809environment with the store shared with the host. MAPPINGS is a list of
810<file-system-mapping> to realize in the virtualized OS."
811 (define user-file-systems
812 ;; Remove file systems that conflict with those added below, or that are
813 ;; normally bound to real devices.
814 (remove (lambda (fs)
815 (let ((target (file-system-mount-point fs))
816 (source (file-system-device fs)))
817 (or (string=? target (%store-prefix))
818 (string=? target "/")
a5acc17a 819 (and (string? source)
f00515b4
LC		 820 (string-prefix? "/dev/" source))
821
822 ;; Labels and UUIDs are necessarily invalid in the VM.
823 (and (file-system-mount? fs)
a5acc17a 824 (or (file-system-label? source)
f00515b4 825 (uuid? source))))))
fcf63cf8
LC		 826 (operating-system-file-systems os)))
827
909de139
DC		 828 (define virtual-file-systems
829 (cons (file-system
830 (mount-point "/")
831 (device "/dev/vda1")
832 (type "ext4"))
833
834 (append (map mapping->file-system mappings)
835 user-file-systems)))
836
83bcd0b8 837 (operating-system (inherit os)
9b396c0c
LC		 838
839 ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
840 ;; force the traditional i386/BIOS method.
841 ;; See <https://bugs.gnu.org/28768>.
842 (bootloader (bootloader-configuration
132823c2 843 (inherit (operating-system-bootloader os))
9b396c0c
LC		 844 (bootloader grub-bootloader)
845 (target "/dev/vda")))
846
52ac153e 847 (initrd (lambda (file-systems . rest)
b8e77811
MO		 848 (apply (operating-system-initrd os)
849 file-systems
52ac153e 850 #:volatile-root? #t
52ac153e 851 rest)))
65fb4515
LC		 852
853 ;; Disable swap.
854 (swap-devices '())
855
909de139
DC		 856 ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
857 ;; since that would lead the bootloader config to look for the kernel and
858 ;; initrd in it.
859 (file-systems (if full-boot?
860 virtual-file-systems
861 (cons
862 (file-system
863 (inherit (mapping->file-system %store-mapping))
864 (needed-for-boot? #t))
865 virtual-file-systems)))))
83bcd0b8 866
fd3bfc44 867(define* (system-qemu-image/shared-store
0b14d1d7 868 os
6aa260af
LC		 869 #:key
870 full-boot?
4c0416ae 871 (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
fd3bfc44 872 "Return a derivation that builds a QEMU image of OS that shares its store
6aa260af
LC		 873with the host.
874
875When FULL-BOOT? is true, return an image that does a complete boot sequence,
876bootloaded included; thus, make a disk image that contains everything the
877bootloader refers to: OS kernel, initrd, bootloader data, etc."
56f9d442
LC		 878 (define root-uuid
879 ;; Use a fixed UUID to improve determinism.
880 (operating-system-uuid os 'dce))
881
8bff7dc2
LC		 882 (define bootcfg
883 (operating-system-bootcfg os))
884
885 ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
886 ;; BOOTCFG and all its dependencies, including the output of OS.
887 ;; This is more than needed (we only need the kernel, initrd, GRUB for its
888 ;; font, and the background image), but it's hard to filter that.
889 (qemu-image #:os os
890 #:bootcfg-drv bootcfg
891 #:bootloader (bootloader-configuration-bootloader
892 (operating-system-bootloader os))
893 #:disk-image-size disk-image-size
894 #:file-system-uuid root-uuid
895 #:inputs (if full-boot?
896 `(("bootcfg" ,bootcfg))
897 '())
898
899 ;; XXX: Passing #t here is too slow, so let it off by default.
900 #:register-closures? #f
901 #:copy-inputs? full-boot?))
fd3bfc44 902
96ffa27b
LC		 903(define* (common-qemu-options image shared-fs)
904 "Return the a string-value gexp with the common QEMU options to boot IMAGE,
905with '-virtfs' options for the host file systems listed in SHARED-FS."
26a076ed 906
96ffa27b 907 (define (virtfs-option fs)
26a076ed
DC		 908 #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
909 #$fs #$(file-system->mount-tag fs)))
96ffa27b 910
26a076ed 911 #~(;; Only enable kvm if we see /dev/kvm exists.
944d2b17
CAW		 912 ;; This allows users without hardware virtualization to still use these
913 ;; commands.
26a076ed
DC		 914 #$@(if (file-exists? "/dev/kvm")
915 '("-enable-kvm")
916 '())
917
918 "-no-reboot"
919 "-net nic,model=virtio"
2ca712bd
LF		 920 "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
921 "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
26a076ed
DC		 922
923 #$@(map virtfs-option shared-fs)
924 "-vga std"
925 (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
ebfb71d4 926 #$image)))
3c1f0e3b 927
ab11f0be
LC		 928(define* (system-qemu-image/shared-store-script os
929 #:key
930 (qemu qemu)
931 (graphic? #t)
ebfb71d4 932 (memory-size 256)
fcf63cf8 933 (mappings '())
6aa260af
LC		 934 full-boot?
935 (disk-image-size
9a1bfe76 936 (* (if full-boot? 500 70)
ed419fa0
LC		 937 (expt 2 20)))
938 (options '()))
fd3bfc44 939 "Return a derivation that builds a script to run a virtual machine image of
ebfb71d4
JN		 940OS that shares its store with the host. The virtual machine runs with
941MEMORY-SIZE MiB of memory.
6aa260af 942
fcf63cf8
LC		 943MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
944systems into the guest.
945
6aa260af
LC		 946When FULL-BOOT? is true, the returned script runs everything starting from the
947bootloader; otherwise it directly starts the operating system kernel. The
948DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
949it is mostly useful when FULL-BOOT? is true."
909de139 950 (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
6aa260af
LC		 951 (image (system-qemu-image/shared-store
952 os
953 #:full-boot? full-boot?
954 #:disk-image-size disk-image-size)))
26a076ed 955 (define kernel-arguments
83071b05 956 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
a7ef45d9 957 #+@(operating-system-kernel-arguments os "/dev/vda1")))
26a076ed
DC		 958
959 (define qemu-exec
960 #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
961 #$@(if full-boot?
962 #~()
963 #~("-kernel" #$(operating-system-kernel-file os)
a7ef45d9 964 "-initrd" #$(file-append os "/initrd")
26a076ed
DC		 965 (format #f "-append ~s"
966 (string-join #$kernel-arguments " "))))
967 #$@(common-qemu-options image
968 (map file-system-mapping-source
ebfb71d4 969 (cons %store-mapping mappings)))
ed419fa0
LC		 970 "-m " (number->string #$memory-size)
971 #$@options))
26a076ed 972
fd3bfc44 973 (define builder
02100028
LC		 974 #~(call-with-output-file #$output
975 (lambda (port)
26a076ed
DC		 976 (format port "#!~a~% exec ~a \"$@\"~%"
977 #$(file-append bash "/bin/sh")
978 (string-join #$qemu-exec " "))
02100028
LC		 979 (chmod port #o555))))
980
981 (gexp->derivation "run-vm.sh" builder)))
fd3bfc44 982
ed419fa0
LC		 983\f
984;;;
985;;; High-level abstraction.
986;;;
987
988(define-record-type* <virtual-machine> %virtual-machine
989 make-virtual-machine
990 virtual-machine?
991 (operating-system virtual-machine-operating-system) ;<operating-system>
992 (qemu virtual-machine-qemu ;<package>
993 (default qemu))
994 (graphic? virtual-machine-graphic? ;Boolean
995 (default #f))
996 (memory-size virtual-machine-memory-size ;integer (MiB)
997 (default 256))
eb152070
CB		 998 (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
999 (default 'guess))
ed419fa0
LC		 1000 (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
1001 (default '())))
1002
1003(define-syntax virtual-machine
1004 (syntax-rules ()
1005 "Declare a virtual machine running the specified OS, with the given
1006options."
1007 ((_ os) ;shortcut
1008 (%virtual-machine (operating-system os)))
1009 ((_ fields ...)
1010 (%virtual-machine fields ...))))
1011
1012(define (port-forwardings->qemu-options forwardings)
1013 "Return the QEMU option for the given port FORWARDINGS as a string, where
1014FORWARDINGS is a list of host-port/guest-port pairs."
1015 (string-join
1016 (map (match-lambda
1017 ((host-port . guest-port)
1018 (string-append "hostfwd=tcp::"
1019 (number->string host-port)
1020 "-:" (number->string guest-port))))
1021 forwardings)
1022 ","))
1023
1024(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
1025 system target)
1026 ;; XXX: SYSTEM and TARGET are ignored.
1027 (match vm
eb152070 1028 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
ed419fa0
LC		 1029 (system-qemu-image/shared-store-script os
1030 #:qemu qemu
1031 #:graphic? graphic?
eb152070
CB		 1032 #:memory-size memory-size
1033 #:disk-image-size
1034 disk-image-size))
1035 (($ <virtual-machine> os qemu graphic? memory-size disk-image-size
1036 forwardings)
ed419fa0
LC		 1037 (let ((options
1038 `("-net" ,(string-append
1039 "user,"
1040 (port-forwardings->qemu-options forwardings)))))
1041 (system-qemu-image/shared-store-script os
1042 #:qemu qemu
1043 #:graphic? graphic?
1044 #:memory-size memory-size
eb152070
CB		 1045 #:disk-image-size
1046 disk-image-size
ed419fa0
LC		 1047 #:options options)))))
1048
04086015 1049;;; vm.scm ends here
jackhill's copy of GNU Guix: https://guix.gnu.org/