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