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