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