Commit | Line | Data |
---|---|---|
04086015 | 1 | ;;; GNU Guix --- Functional package management for GNU |
60fd4118 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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) |
9de46ffb | 53 | #:use-module (gnu packages admin) |
0ded70f3 | 54 | |
9121ce55 | 55 | #:use-module (gnu bootloader) |
9b396c0c | 56 | #:use-module (gnu bootloader grub) |
0ded70f3 | 57 | #:use-module (gnu system shadow) |
6e828634 | 58 | #:use-module (gnu system pam) |
69cae3d3 | 59 | #:use-module (gnu system linux-container) |
735c6dd7 | 60 | #:use-module (gnu system linux-initrd) |
b09a8da4 | 61 | #:use-module (gnu bootloader) |
c5df1839 | 62 | #:use-module (gnu system file-systems) |
033adfe7 | 63 | #:use-module (gnu system) |
db4fdc04 | 64 | #:use-module (gnu services) |
d03de6be | 65 | #:use-module (gnu services base) |
9b336338 | 66 | #:use-module (gnu system uuid) |
0ded70f3 | 67 | |
ca85d7bc | 68 | #:use-module (srfi srfi-1) |
04086015 | 69 | #:use-module (srfi srfi-26) |
5f7fe1c5 | 70 | #:use-module (rnrs bytevectors) |
04086015 | 71 | #:use-module (ice-9 match) |
0ded70f3 | 72 | |
04086015 | 73 | #:export (expression->derivation-in-linux-vm |
aedb72fb | 74 | qemu-image |
e9f693d0 | 75 | virtualized-operating-system |
fcf63cf8 | 76 | |
fd3bfc44 | 77 | system-qemu-image/shared-store |
1e77fedb | 78 | system-qemu-image/shared-store-script |
a335f6fc | 79 | system-docker-image |
ed419fa0 LC |
80 | |
81 | virtual-machine | |
82 | virtual-machine?)) | |
04086015 LC |
83 | |
84 | \f | |
85 | ;;; Commentary: | |
86 | ;;; | |
87 | ;;; Tools to evaluate build expressions within virtual machines. | |
88 | ;;; | |
89 | ;;; Code: | |
90 | ||
bdc96f6e MC |
91 | ;; By default, the msize value is 8 KiB, which according to QEMU is |
92 | ;; insufficient and would degrade performance. The msize value should roughly | |
93 | ;; match the bandwidth of the system's IO (see: | |
94 | ;; https://wiki.qemu.org/Documentation/9psetup#msize). Use 100 MiB as a | |
95 | ;; conservative default. | |
96 | (define %default-msize-value (* 100 (expt 2 20))) ;100 MiB | |
97 | ||
83bcd0b8 | 98 | (define %linux-vm-file-systems |
8c9bf294 CM |
99 | ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with |
100 | ;; the host over 9p. | |
66ec3895 LC |
101 | ;; |
102 | ;; The 9p documentation says that cache=loose is "intended for exclusive, | |
103 | ;; read-only mounts", without additional details. It's much faster than the | |
104 | ;; default cache=none, especially when copying and registering store items. | |
105 | ;; Thus, use cache=loose, except for /xchg where we want to ensure | |
106 | ;; consistency. | |
83bcd0b8 LC |
107 | (list (file-system |
108 | (mount-point (%store-prefix)) | |
109 | (device "store") | |
110 | (type "9p") | |
111 | (needed-for-boot? #t) | |
fce22547 | 112 | (flags '(read-only)) |
bdc96f6e MC |
113 | (options (format #f "trans=virtio,cache=loose,msize=~a" |
114 | %default-msize-value)) | |
3c05b4bc | 115 | (check? #f)) |
83bcd0b8 LC |
116 | (file-system |
117 | (mount-point "/xchg") | |
118 | (device "xchg") | |
119 | (type "9p") | |
120 | (needed-for-boot? #t) | |
bdc96f6e | 121 | (options (format #f "trans=virtio,msize=~a" %default-msize-value)) |
8c9bf294 CM |
122 | (check? #f)) |
123 | (file-system | |
124 | (mount-point "/tmp") | |
125 | (device "tmp") | |
126 | (type "9p") | |
127 | (needed-for-boot? #t) | |
bdc96f6e MC |
128 | (options (format #f "trans=virtio,cache=loose,msize=~a" |
129 | %default-msize-value)) | |
3c05b4bc | 130 | (check? #f)))) |
83bcd0b8 | 131 | |
c45477d2 LC |
132 | (define not-config? |
133 | ;; Select (guix …) and (gnu …) modules, except (guix config). | |
134 | (match-lambda | |
135 | (('guix 'config) #f) | |
136 | (('guix rest ...) #t) | |
137 | (('gnu rest ...) #t) | |
138 | (rest #f))) | |
139 | ||
ca719424 LC |
140 | (define gcrypt-sqlite3&co |
141 | ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. | |
142 | (append-map (lambda (package) | |
143 | (cons package | |
910d0121 LC |
144 | (match (package-transitive-propagated-inputs package) |
145 | (((labels packages) ...) | |
146 | packages)))) | |
ca719424 | 147 | (list guile-gcrypt guile-sqlite3))) |
c45477d2 | 148 | |
d9f0a237 | 149 | (define* (expression->derivation-in-linux-vm name exp |
04086015 | 150 | #:key |
b3477234 | 151 | (system (%current-system)) |
04086015 | 152 | (linux linux-libre) |
735c6dd7 | 153 | initrd |
06da1a6b | 154 | (qemu qemu-minimal) |
04086015 | 155 | (env-vars '()) |
04086015 LC |
156 | (guile-for-build |
157 | (%guile-for-build)) | |
50e53c1c LC |
158 | (file-systems |
159 | %linux-vm-file-systems) | |
04086015 | 160 | |
8d033e3e | 161 | (single-file-output? #f) |
04086015 | 162 | (make-disk-image? #f) |
ca85d7bc | 163 | (references-graphs #f) |
defa1b9b | 164 | (memory-size 256) |
c4a74364 | 165 | (disk-image-format "qcow2") |
a328f66a LC |
166 | (disk-image-size 'guess) |
167 | ||
168 | (substitutable? #t)) | |
735c6dd7 | 169 | "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a |
8d033e3e | 170 | derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the |
50e53c1c LC |
171 | virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a |
172 | 9p share of the store, the '/xchg' where EXP should put its output file(s), | |
173 | and a 9p share of /tmp. | |
8d033e3e LC |
174 | |
175 | If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT. | |
176 | Otherwise, copy the contents of /xchg to a new directory OUTPUT. | |
04086015 | 177 | |
c4a74364 LC |
178 | When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type |
179 | DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and | |
a8ac4f08 LC |
180 | return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based |
181 | based on the size of the closure of REFERENCES-GRAPHS. | |
ca85d7bc LC |
182 | |
183 | When REFERENCES-GRAPHS is true, it must be a list of file name/store path | |
184 | pairs, as for `derivation'. The files containing the reference graphs are | |
a328f66a LC |
185 | made available under the /xchg CIFS share. |
186 | ||
187 | SUBSTITUTABLE? determines whether the returned derivation should be marked as | |
188 | substitutable." | |
be43c08b LC |
189 | (define user-builder |
190 | (program-file "builder-in-linux-vm" exp)) | |
191 | ||
192 | (define loader | |
193 | ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for | |
194 | ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured | |
195 | ;; Guile, which it couldn't do using the statically-linked guile used in | |
196 | ;; the initrd. See example at | |
197 | ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>. | |
198 | (program-file "linux-vm-loader" | |
be6520e6 LC |
199 | ;; Communicate USER-BUILDER's exit status via /xchg so that |
200 | ;; the host can distinguish between success, failure, and | |
201 | ;; kernel panic. | |
202 | #~(let ((status (system* #$user-builder))) | |
203 | (call-with-output-file "/xchg/.exit-status" | |
204 | (lambda (port) | |
205 | (write status port))) | |
206 | (sync) | |
207 | (reboot)))) | |
be43c08b | 208 | |
502f609d LC |
209 | (define-syntax-rule (check predicate) |
210 | (let-system (system target) | |
211 | (predicate (or target system)))) | |
212 | ||
e34ae75d LC |
213 | (let ((initrd (or initrd |
214 | (base-initrd file-systems | |
215 | #:on-error 'backtrace | |
216 | #:linux linux | |
217 | #:linux-modules %base-initrd-modules | |
218 | #:qemu-networking? #t)))) | |
1aa0033b LC |
219 | |
220 | (define builder | |
221 | ;; Code that launches the VM that evaluates EXP. | |
ca719424 | 222 | (with-extensions gcrypt-sqlite3&co |
c45477d2 LC |
223 | (with-imported-modules `(,@(source-module-closure |
224 | '((guix build utils) | |
225 | (gnu build vm)) | |
226 | #:select? not-config?) | |
ca719424 LC |
227 | |
228 | ;; For consumption by (gnu store database). | |
229 | ((guix config) => ,(make-config.scm))) | |
c45477d2 LC |
230 | #~(begin |
231 | (use-modules (guix build utils) | |
232 | (gnu build vm)) | |
233 | ||
000e7a0a LC |
234 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded |
235 | ;; by 'estimated-partition-size' below. | |
236 | (setenv "GUIX_LOCPATH" | |
237 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
238 | (setlocale LC_ALL "en_US.utf8") | |
239 | ||
d4ddf22d MO |
240 | (let* ((native-inputs |
241 | '#+(list qemu (canonical-package coreutils))) | |
b3477234 LC |
242 | (linux (string-append |
243 | #+linux "/" | |
244 | #+(system-linux-image-file-name system))) | |
245 | (initrd #+initrd) | |
246 | (loader #+loader) | |
c45477d2 LC |
247 | (graphs '#$(match references-graphs |
248 | (((graph-files . _) ...) graph-files) | |
249 | (_ #f))) | |
502f609d LC |
250 | (target #$(let-system (system target) |
251 | (or target system))) | |
c45477d2 LC |
252 | (size #$(if (eq? 'guess disk-image-size) |
253 | #~(+ (* 70 (expt 2 20)) ;ESP | |
254 | (estimated-partition-size graphs)) | |
255 | disk-image-size))) | |
256 | ||
d4ddf22d | 257 | (set-path-environment-variable "PATH" '("bin") native-inputs) |
c45477d2 LC |
258 | |
259 | (load-in-linux-vm loader | |
260 | #:output #$output | |
261 | #:linux linux #:initrd initrd | |
d4ddf22d | 262 | #:qemu (qemu-command target) |
c45477d2 LC |
263 | #:memory-size #$memory-size |
264 | #:make-disk-image? #$make-disk-image? | |
265 | #:single-file-output? #$single-file-output? | |
c45477d2 LC |
266 | #:disk-image-format #$disk-image-format |
267 | #:disk-image-size size | |
268 | #:references-graphs graphs)))))) | |
1aa0033b LC |
269 | |
270 | (gexp->derivation name builder | |
271 | ;; TODO: Require the "kvm" feature. | |
272 | #:system system | |
b3477234 | 273 | #:target #f ;EXP is always executed natively |
1aa0033b | 274 | #:env-vars env-vars |
1aa0033b | 275 | #:guile-for-build guile-for-build |
a328f66a LC |
276 | #:references-graphs references-graphs |
277 | #:substitutable? substitutable?))) | |
d9f0a237 | 278 | |
d03de6be MC |
279 | (define (has-guix-service-type? os) |
280 | "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." | |
281 | (not (not (find (lambda (service) | |
282 | (eq? (service-kind service) guix-service-type)) | |
283 | (operating-system-services os))))) | |
284 | ||
d9f0a237 | 285 | (define* (qemu-image #:key |
04086015 LC |
286 | (name "qemu-image") |
287 | (system (%current-system)) | |
d4ddf22d | 288 | (target (%current-target-system)) |
06da1a6b | 289 | (qemu qemu-minimal) |
a8ac4f08 | 290 | (disk-image-size 'guess) |
c4a74364 | 291 | (disk-image-format "qcow2") |
03ddfaf5 | 292 | (file-system-type "ext4") |
4d1ff68d | 293 | (file-system-options '()) |
cd45d656 | 294 | (device-nodes 'linux) |
82782d8c | 295 | (extra-directives '()) |
ef9fc40d | 296 | file-system-label |
fd3b4b98 | 297 | file-system-uuid |
8bff7dc2 | 298 | os |
9121ce55 MO |
299 | bootcfg-drv |
300 | bootloader | |
d03de6be | 301 | (register-closures? (has-guix-service-type? os)) |
150e20dd | 302 | (inputs '()) |
a328f66a LC |
303 | copy-inputs? |
304 | (substitutable? #t)) | |
c4a74364 | 305 | "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., |
ef9fc40d LC |
306 | 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. |
307 | Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root | |
fd3b4b98 | 308 | partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root |
4d1ff68d LC |
309 | partition (a UUID object). FILE-SYSTEM-OPTIONS is an optional list of |
310 | command-line options passed to 'mkfs.ext4' (or similar). | |
fd3b4b98 LC |
311 | |
312 | The returned image is a full disk image that runs OS-DERIVATION, | |
f2c403ea LC |
313 | with a GRUB installation that uses GRUB-CONFIGURATION as its configuration |
314 | file (GRUB-CONFIGURATION must be the name of a file in the VM.) | |
93d44bd8 | 315 | |
150e20dd LC |
316 | INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy |
317 | all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, | |
318 | register INPUTS in the store database of the image so that Guix can be used in | |
d03de6be MC |
319 | the image. By default, REGISTER-CLOSURES? is set to true only if a service of |
320 | type GUIX-SERVICE-TYPE is present in the services definition of the operating | |
82782d8c LC |
321 | system. |
322 | ||
cd45d656 LC |
323 | When DEVICE-NODES is 'linux, create Linux-device block and character devices |
324 | under /dev. When it is 'hurd, do Hurdish things. | |
325 | ||
82782d8c LC |
326 | EXTRA-DIRECTIVES is an optional list of directives to populate the root file |
327 | system that is passed to 'populate-root-file-system'." | |
c45477d2 LC |
328 | (define schema |
329 | (and register-closures? | |
330 | (local-file (search-path %load-path | |
331 | "guix/store/schema.sql")))) | |
332 | ||
52c1b90a LC |
333 | (define preserve-target |
334 | (if target | |
335 | (lambda (obj) | |
336 | (with-parameters ((%current-target-system target)) | |
337 | obj)) | |
338 | identity)) | |
339 | ||
340 | (define inputs* | |
341 | (map (match-lambda | |
342 | ((name thing) | |
343 | `(,name ,(preserve-target thing))) | |
344 | ((name thing output) | |
345 | `(,name ,(preserve-target thing) ,output))) | |
346 | inputs)) | |
347 | ||
b53833b2 LC |
348 | (expression->derivation-in-linux-vm |
349 | name | |
ca719424 | 350 | (with-extensions gcrypt-sqlite3&co |
c45477d2 LC |
351 | (with-imported-modules `(,@(source-module-closure '((gnu build vm) |
352 | (gnu build bootloader) | |
23567138 | 353 | (gnu build hurd-boot) |
c45477d2 LC |
354 | (guix store database) |
355 | (guix build utils)) | |
356 | #:select? not-config?) | |
ca719424 | 357 | ((guix config) => ,(make-config.scm))) |
c45477d2 LC |
358 | #~(begin |
359 | (use-modules (gnu build bootloader) | |
360 | (gnu build vm) | |
b37c5441 JN |
361 | ((gnu build hurd-boot) |
362 | #:select (make-hurd-device-nodes)) | |
cd45d656 | 363 | ((gnu build linux-boot) |
b37c5441 | 364 | #:select (make-essential-device-nodes)) |
c45477d2 LC |
365 | (guix store database) |
366 | (guix build utils) | |
367 | (srfi srfi-26) | |
368 | (ice-9 binary-ports)) | |
369 | ||
370 | (sql-schema #$schema) | |
371 | ||
9c941364 LC |
372 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. |
373 | (setenv "GUIX_LOCPATH" | |
374 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
375 | (setlocale LC_ALL "en_US.utf8") | |
376 | ||
c45477d2 | 377 | (let ((inputs |
96cb3f8a | 378 | '#+(append (list parted e2fsprogs dosfstools) |
c45477d2 LC |
379 | (map canonical-package |
380 | (list sed grep coreutils findutils gawk)))) | |
381 | ||
382 | ;; This variable is unused but allows us to add INPUTS-TO-COPY | |
383 | ;; as inputs. | |
384 | (to-register | |
385 | '#$(map (match-lambda | |
386 | ((name thing) thing) | |
387 | ((name thing output) `(,thing ,output))) | |
52c1b90a | 388 | inputs*))) |
c45477d2 LC |
389 | |
390 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) | |
391 | ||
392 | (let* ((graphs '#$(match inputs | |
393 | (((names . _) ...) | |
394 | names))) | |
395 | (initialize (root-partition-initializer | |
82782d8c | 396 | #:extra-directives '#$extra-directives |
c45477d2 LC |
397 | #:closures graphs |
398 | #:copy-closures? #$copy-inputs? | |
399 | #:register-closures? #$register-closures? | |
52c1b90a | 400 | #:system-directory #$(preserve-target os) |
b5460d95 | 401 | |
cd45d656 LC |
402 | #:make-device-nodes |
403 | #$(match device-nodes | |
404 | ('linux #~make-essential-device-nodes) | |
405 | ('hurd #~make-hurd-device-nodes)) | |
406 | ||
b5460d95 LC |
407 | ;; Disable deduplication to speed things up, |
408 | ;; and because it doesn't help much for a | |
409 | ;; single system generation. | |
410 | #:deduplicate? #f)) | |
c45477d2 LC |
411 | (root-size #$(if (eq? 'guess disk-image-size) |
412 | #~(max | |
413 | ;; Minimum 20 MiB root size | |
414 | (* 20 (expt 2 20)) | |
415 | (estimated-partition-size | |
416 | (map (cut string-append "/xchg/" <>) | |
417 | graphs))) | |
418 | (- disk-image-size | |
419 | (* 50 (expt 2 20))))) | |
420 | (partitions | |
421 | (append | |
422 | (list (partition | |
423 | (size root-size) | |
424 | (label #$file-system-label) | |
425 | (uuid #$(and=> file-system-uuid | |
426 | uuid-bytevector)) | |
427 | (file-system #$file-system-type) | |
4d1ff68d | 428 | (file-system-options '#$file-system-options) |
c45477d2 LC |
429 | (flags '(boot)) |
430 | (initializer initialize))) | |
431 | ;; Append a small EFI System Partition for use with UEFI | |
432 | ;; bootloaders if we are not targeting ARM because UEFI | |
433 | ;; support in U-Boot is experimental. | |
434 | ;; | |
1ee72bb5 | 435 | ;; FIXME: ‘target-arm?’ may be not operate on the right |
c45477d2 LC |
436 | ;; system/target values. Rewrite using ‘let-system’ when |
437 | ;; available. | |
1ee72bb5 | 438 | (if #$(target-arm?) |
c45477d2 LC |
439 | '() |
440 | (list (partition | |
441 | ;; The standalone grub image is about 10MiB, but | |
442 | ;; leave some room for custom or multiple images. | |
443 | (size (* 40 (expt 2 20))) | |
444 | (label "GNU-ESP") ;cosmetic only | |
445 | ;; Use "vfat" here since this property is used | |
446 | ;; when mounting. The actual FAT-ness is based | |
447 | ;; on file system size (16 in this case). | |
448 | (file-system "vfat") | |
1ee72bb5 MO |
449 | (flags '(esp))))))) |
450 | (grub-efi #$(and (not (target-arm?)) grub-efi))) | |
c45477d2 LC |
451 | (initialize-hard-disk "/dev/vda" |
452 | #:partitions partitions | |
1ee72bb5 | 453 | #:grub-efi grub-efi |
c45477d2 | 454 | #:bootloader-package |
96cb3f8a | 455 | #+(bootloader-package bootloader) |
52c1b90a | 456 | #:bootcfg #$(preserve-target bootcfg-drv) |
c45477d2 LC |
457 | #:bootcfg-location |
458 | #$(bootloader-configuration-file bootloader) | |
459 | #:bootloader-installer | |
96cb3f8a | 460 | #+(bootloader-installer bootloader))))))) |
b53833b2 LC |
461 | #:system system |
462 | #:make-disk-image? #t | |
463 | #:disk-image-size disk-image-size | |
464 | #:disk-image-format disk-image-format | |
52c1b90a | 465 | #:references-graphs inputs* |
a328f66a | 466 | #:substitutable? substitutable?)) |
04086015 | 467 | |
a335f6fc CM |
468 | (define* (system-docker-image os |
469 | #:key | |
247649d4 | 470 | (name "guix-docker-image") |
98bf60bf | 471 | (memory-size 256) |
d6c43d7b LC |
472 | (register-closures? (has-guix-service-type? os)) |
473 | shared-network?) | |
a335f6fc | 474 | "Build a docker image. OS is the desired <operating-system>. NAME is the |
d6c43d7b LC |
475 | base name to use for the output file. When SHARED-NETWORK? is true, assume |
476 | that the container will share network with the host and thus doesn't need a | |
477 | DHCP client, nscd, and so on. | |
478 | ||
479 | When REGISTER-CLOSURES? is true, register the closure of OS with Guix in the | |
480 | resulting Docker image. By default, REGISTER-CLOSURES? is set to true only if | |
481 | a service of type GUIX-SERVICE-TYPE is present in the services definition of | |
482 | the operating system." | |
c45477d2 LC |
483 | (define schema |
484 | (and register-closures? | |
485 | (local-file (search-path %load-path | |
486 | "guix/store/schema.sql")))) | |
9f160a0d | 487 | |
247649d4 LC |
488 | (define boot-program |
489 | ;; Program that runs the boot script of OS, which in turn starts shepherd. | |
490 | (program-file "boot-program" | |
491 | #~(let ((system (cadr (command-line)))) | |
492 | (setenv "GUIX_NEW_SYSTEM" system) | |
60fd4118 | 493 | (execl #$(file-append guile-3.0 "/bin/guile") |
247649d4 LC |
494 | "guile" "--no-auto-compile" |
495 | (string-append system "/boot"))))) | |
496 | ||
497 | ||
498 | (let ((os (operating-system-with-gc-roots | |
d6c43d7b LC |
499 | (containerized-operating-system os '() |
500 | #:shared-network? | |
501 | shared-network?) | |
247649d4 | 502 | (list boot-program))) |
69cae3d3 LC |
503 | (name (string-append name ".tar.gz")) |
504 | (graph "system-graph")) | |
a335f6fc | 505 | (define build |
81c3dc32 | 506 | (with-extensions (cons guile-json-3 ;for (guix docker) |
ca719424 | 507 | gcrypt-sqlite3&co) ;for (guix store database) |
9f160a0d LC |
508 | (with-imported-modules `(,@(source-module-closure |
509 | '((guix docker) | |
c45477d2 | 510 | (guix store database) |
9f160a0d | 511 | (guix build utils) |
c45477d2 | 512 | (guix build store-copy) |
9f160a0d LC |
513 | (gnu build vm)) |
514 | #:select? not-config?) | |
ca719424 | 515 | ((guix config) => ,(make-config.scm))) |
9f160a0d LC |
516 | #~(begin |
517 | (use-modules (guix docker) | |
518 | (guix build utils) | |
519 | (gnu build vm) | |
520 | (srfi srfi-19) | |
c45477d2 LC |
521 | (guix build store-copy) |
522 | (guix store database)) | |
523 | ||
524 | ;; Set the SQL schema location. | |
525 | (sql-schema #$schema) | |
9f160a0d | 526 | |
ed504caf LC |
527 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. |
528 | (setenv "GUIX_LOCPATH" | |
529 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
530 | (setlocale LC_ALL "en_US.utf8") | |
531 | ||
c45477d2 | 532 | (let* (;; This initializer requires elevated privileges that are |
9f160a0d LC |
533 | ;; not normally available in the build environment (e.g., |
534 | ;; it needs to create device nodes). In order to obtain | |
535 | ;; such privileges, we run it as root in a VM. | |
536 | (initialize (root-partition-initializer | |
537 | #:closures '(#$graph) | |
538 | #:register-closures? #$register-closures? | |
69cae3d3 | 539 | #:system-directory #$os |
9f160a0d LC |
540 | ;; De-duplication would fail due to |
541 | ;; cross-device link errors, so don't do it. | |
542 | #:deduplicate? #f)) | |
543 | ;; Even as root in a VM, the initializer would fail due to | |
544 | ;; lack of privileges if we use a root-directory that is on | |
545 | ;; a file system that is shared with the host (e.g., /tmp). | |
546 | (root-directory "/guixsd-system-root")) | |
c45477d2 | 547 | (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar)) |
9f160a0d LC |
548 | (mkdir root-directory) |
549 | (initialize root-directory) | |
550 | (build-docker-image | |
551 | (string-append "/xchg/" #$name) ;; The output file. | |
552 | (cons* root-directory | |
6892f0a2 LC |
553 | (map store-info-item |
554 | (call-with-input-file | |
555 | (string-append "/xchg/" #$graph) | |
556 | read-reference-graph))) | |
69cae3d3 | 557 | #$os |
247649d4 | 558 | #:entry-point '(#$boot-program #$os) |
9f160a0d LC |
559 | #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") |
560 | #:creation-time (make-time time-utc 0 1) | |
66ec3895 | 561 | #:transformations `((,root-directory -> "")))))))) |
247649d4 | 562 | |
a335f6fc | 563 | (expression->derivation-in-linux-vm |
be43c08b | 564 | name build |
98bf60bf | 565 | #:memory-size memory-size |
a335f6fc CM |
566 | #:make-disk-image? #f |
567 | #:single-file-output? #t | |
69cae3d3 | 568 | #:references-graphs `((,graph ,os))))) |
a335f6fc | 569 | |
04086015 | 570 | \f |
fcf63cf8 LC |
571 | ;;; |
572 | ;;; VMs that share file systems with the host. | |
573 | ;;; | |
574 | ||
96ffa27b LC |
575 | (define (file-system->mount-tag fs) |
576 | "Return a 9p mount tag for host file system FS." | |
dffc5ab5 LC |
577 | ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain |
578 | ;; slashes, and cannot start with '_'. Compute an identifier that | |
579 | ;; corresponds to the rules. | |
96ffa27b | 580 | (string-append "TAG" |
dffc5ab5 LC |
581 | (string-drop (bytevector->base32-string |
582 | (sha1 (string->utf8 fs))) | |
583 | 4))) | |
96ffa27b | 584 | |
fcf63cf8 LC |
585 | (define (mapping->file-system mapping) |
586 | "Return a 9p file system that realizes MAPPING." | |
587 | (match mapping | |
588 | (($ <file-system-mapping> source target writable?) | |
589 | (file-system | |
590 | (mount-point target) | |
591 | (device (file-system->mount-tag source)) | |
592 | (type "9p") | |
593 | (flags (if writable? '() '(read-only))) | |
7eeb7815 | 594 | (options (string-append "trans=virtio" |
bdc96f6e MC |
595 | (if writable? "" ",cache=loose") |
596 | ",msize=" (number->string %default-msize-value))) | |
fcf63cf8 LC |
597 | (check? #f) |
598 | (create-mount-point? #t))))) | |
599 | ||
909de139 | 600 | (define* (virtualized-operating-system os mappings #:optional (full-boot? #f)) |
83bcd0b8 | 601 | "Return an operating system based on OS suitable for use in a virtualized |
fcf63cf8 LC |
602 | environment with the store shared with the host. MAPPINGS is a list of |
603 | <file-system-mapping> to realize in the virtualized OS." | |
604 | (define user-file-systems | |
605 | ;; Remove file systems that conflict with those added below, or that are | |
606 | ;; normally bound to real devices. | |
607 | (remove (lambda (fs) | |
608 | (let ((target (file-system-mount-point fs)) | |
609 | (source (file-system-device fs))) | |
610 | (or (string=? target (%store-prefix)) | |
611 | (string=? target "/") | |
a5acc17a | 612 | (and (string? source) |
f00515b4 LC |
613 | (string-prefix? "/dev/" source)) |
614 | ||
615 | ;; Labels and UUIDs are necessarily invalid in the VM. | |
616 | (and (file-system-mount? fs) | |
a5acc17a | 617 | (or (file-system-label? source) |
f00515b4 | 618 | (uuid? source)))))) |
fcf63cf8 LC |
619 | (operating-system-file-systems os))) |
620 | ||
909de139 DC |
621 | (define virtual-file-systems |
622 | (cons (file-system | |
623 | (mount-point "/") | |
624 | (device "/dev/vda1") | |
625 | (type "ext4")) | |
626 | ||
627 | (append (map mapping->file-system mappings) | |
628 | user-file-systems))) | |
629 | ||
83bcd0b8 | 630 | (operating-system (inherit os) |
9b396c0c LC |
631 | |
632 | ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware), | |
633 | ;; force the traditional i386/BIOS method. | |
634 | ;; See <https://bugs.gnu.org/28768>. | |
635 | (bootloader (bootloader-configuration | |
132823c2 | 636 | (inherit (operating-system-bootloader os)) |
9b396c0c LC |
637 | (bootloader grub-bootloader) |
638 | (target "/dev/vda"))) | |
639 | ||
52ac153e | 640 | (initrd (lambda (file-systems . rest) |
b8e77811 MO |
641 | (apply (operating-system-initrd os) |
642 | file-systems | |
52ac153e | 643 | #:volatile-root? #t |
52ac153e | 644 | rest))) |
65fb4515 LC |
645 | |
646 | ;; Disable swap. | |
647 | (swap-devices '()) | |
648 | ||
909de139 DC |
649 | ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store |
650 | ;; since that would lead the bootloader config to look for the kernel and | |
651 | ;; initrd in it. | |
652 | (file-systems (if full-boot? | |
653 | virtual-file-systems | |
654 | (cons | |
655 | (file-system | |
656 | (inherit (mapping->file-system %store-mapping)) | |
657 | (needed-for-boot? #t)) | |
658 | virtual-file-systems))))) | |
83bcd0b8 | 659 | |
fd3bfc44 | 660 | (define* (system-qemu-image/shared-store |
0b14d1d7 | 661 | os |
6aa260af | 662 | #:key |
60f759f0 LC |
663 | (system (%current-system)) |
664 | (target (%current-target-system)) | |
6aa260af | 665 | full-boot? |
4c0416ae | 666 | (disk-image-size (* (if full-boot? 500 30) (expt 2 20)))) |
fd3bfc44 | 667 | "Return a derivation that builds a QEMU image of OS that shares its store |
6aa260af LC |
668 | with the host. |
669 | ||
670 | When FULL-BOOT? is true, return an image that does a complete boot sequence, | |
671 | bootloaded included; thus, make a disk image that contains everything the | |
672 | bootloader refers to: OS kernel, initrd, bootloader data, etc." | |
56f9d442 LC |
673 | (define root-uuid |
674 | ;; Use a fixed UUID to improve determinism. | |
675 | (operating-system-uuid os 'dce)) | |
676 | ||
8bff7dc2 LC |
677 | (define bootcfg |
678 | (operating-system-bootcfg os)) | |
679 | ||
680 | ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains | |
681 | ;; BOOTCFG and all its dependencies, including the output of OS. | |
682 | ;; This is more than needed (we only need the kernel, initrd, GRUB for its | |
683 | ;; font, and the background image), but it's hard to filter that. | |
684 | (qemu-image #:os os | |
60f759f0 LC |
685 | #:system system |
686 | #:target target | |
8bff7dc2 LC |
687 | #:bootcfg-drv bootcfg |
688 | #:bootloader (bootloader-configuration-bootloader | |
689 | (operating-system-bootloader os)) | |
690 | #:disk-image-size disk-image-size | |
691 | #:file-system-uuid root-uuid | |
692 | #:inputs (if full-boot? | |
693 | `(("bootcfg" ,bootcfg)) | |
694 | '()) | |
695 | ||
696 | ;; XXX: Passing #t here is too slow, so let it off by default. | |
697 | #:register-closures? #f | |
698 | #:copy-inputs? full-boot?)) | |
fd3bfc44 | 699 | |
96ffa27b LC |
700 | (define* (common-qemu-options image shared-fs) |
701 | "Return the a string-value gexp with the common QEMU options to boot IMAGE, | |
702 | with '-virtfs' options for the host file systems listed in SHARED-FS." | |
26a076ed | 703 | |
96ffa27b | 704 | (define (virtfs-option fs) |
26a076ed DC |
705 | #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s" |
706 | #$fs #$(file-system->mount-tag fs))) | |
96ffa27b | 707 | |
26a076ed | 708 | #~(;; Only enable kvm if we see /dev/kvm exists. |
944d2b17 CAW |
709 | ;; This allows users without hardware virtualization to still use these |
710 | ;; commands. | |
26a076ed DC |
711 | #$@(if (file-exists? "/dev/kvm") |
712 | '("-enable-kvm") | |
713 | '()) | |
714 | ||
715 | "-no-reboot" | |
2ca712bd LF |
716 | "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" |
717 | "-device" "virtio-rng-pci,rng=guixsd-vm-rng" | |
26a076ed DC |
718 | |
719 | #$@(map virtfs-option shared-fs) | |
720 | "-vga std" | |
721 | (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" | |
ebfb71d4 | 722 | #$image))) |
3c1f0e3b | 723 | |
ab11f0be LC |
724 | (define* (system-qemu-image/shared-store-script os |
725 | #:key | |
60f759f0 LC |
726 | (system (%current-system)) |
727 | (target (%current-target-system)) | |
ab11f0be LC |
728 | (qemu qemu) |
729 | (graphic? #t) | |
ebfb71d4 | 730 | (memory-size 256) |
fcf63cf8 | 731 | (mappings '()) |
6aa260af LC |
732 | full-boot? |
733 | (disk-image-size | |
9a1bfe76 | 734 | (* (if full-boot? 500 70) |
ed419fa0 LC |
735 | (expt 2 20))) |
736 | (options '())) | |
fd3bfc44 | 737 | "Return a derivation that builds a script to run a virtual machine image of |
ebfb71d4 JN |
738 | OS that shares its store with the host. The virtual machine runs with |
739 | MEMORY-SIZE MiB of memory. | |
6aa260af | 740 | |
fcf63cf8 LC |
741 | MAPPINGS is a list of <file-system-mapping> specifying mapping of host file |
742 | systems into the guest. | |
743 | ||
6aa260af LC |
744 | When FULL-BOOT? is true, the returned script runs everything starting from the |
745 | bootloader; otherwise it directly starts the operating system kernel. The | |
746 | DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image; | |
747 | it is mostly useful when FULL-BOOT? is true." | |
909de139 | 748 | (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?)) |
6aa260af LC |
749 | (image (system-qemu-image/shared-store |
750 | os | |
60f759f0 LC |
751 | #:system system |
752 | #:target target | |
6aa260af LC |
753 | #:full-boot? full-boot? |
754 | #:disk-image-size disk-image-size))) | |
26a076ed | 755 | (define kernel-arguments |
83071b05 | 756 | #~(list #$@(if graphic? #~() #~("console=ttyS0")) |
a7ef45d9 | 757 | #+@(operating-system-kernel-arguments os "/dev/vda1"))) |
26a076ed DC |
758 | |
759 | (define qemu-exec | |
e768e4e9 LC |
760 | #~(list #+(file-append qemu "/bin/" |
761 | (qemu-command (or target system))) | |
26a076ed DC |
762 | #$@(if full-boot? |
763 | #~() | |
764 | #~("-kernel" #$(operating-system-kernel-file os) | |
a7ef45d9 | 765 | "-initrd" #$(file-append os "/initrd") |
26a076ed DC |
766 | (format #f "-append ~s" |
767 | (string-join #$kernel-arguments " ")))) | |
768 | #$@(common-qemu-options image | |
769 | (map file-system-mapping-source | |
ebfb71d4 | 770 | (cons %store-mapping mappings))) |
ed419fa0 LC |
771 | "-m " (number->string #$memory-size) |
772 | #$@options)) | |
26a076ed | 773 | |
fd3bfc44 | 774 | (define builder |
02100028 LC |
775 | #~(call-with-output-file #$output |
776 | (lambda (port) | |
26a076ed | 777 | (format port "#!~a~% exec ~a \"$@\"~%" |
e768e4e9 | 778 | #+(file-append bash "/bin/sh") |
26a076ed | 779 | (string-join #$qemu-exec " ")) |
02100028 LC |
780 | (chmod port #o555)))) |
781 | ||
782 | (gexp->derivation "run-vm.sh" builder))) | |
fd3bfc44 | 783 | |
ed419fa0 LC |
784 | \f |
785 | ;;; | |
786 | ;;; High-level abstraction. | |
787 | ;;; | |
788 | ||
789 | (define-record-type* <virtual-machine> %virtual-machine | |
790 | make-virtual-machine | |
791 | virtual-machine? | |
792 | (operating-system virtual-machine-operating-system) ;<operating-system> | |
793 | (qemu virtual-machine-qemu ;<package> | |
794 | (default qemu)) | |
795 | (graphic? virtual-machine-graphic? ;Boolean | |
796 | (default #f)) | |
797 | (memory-size virtual-machine-memory-size ;integer (MiB) | |
798 | (default 256)) | |
eb152070 CB |
799 | (disk-image-size virtual-machine-disk-image-size ;integer (bytes) |
800 | (default 'guess)) | |
ed419fa0 LC |
801 | (port-forwardings virtual-machine-port-forwardings ;list of integer pairs |
802 | (default '()))) | |
803 | ||
804 | (define-syntax virtual-machine | |
805 | (syntax-rules () | |
806 | "Declare a virtual machine running the specified OS, with the given | |
807 | options." | |
808 | ((_ os) ;shortcut | |
809 | (%virtual-machine (operating-system os))) | |
810 | ((_ fields ...) | |
811 | (%virtual-machine fields ...)))) | |
812 | ||
813 | (define (port-forwardings->qemu-options forwardings) | |
814 | "Return the QEMU option for the given port FORWARDINGS as a string, where | |
815 | FORWARDINGS is a list of host-port/guest-port pairs." | |
816 | (string-join | |
817 | (map (match-lambda | |
818 | ((host-port . guest-port) | |
819 | (string-append "hostfwd=tcp::" | |
820 | (number->string host-port) | |
821 | "-:" (number->string guest-port)))) | |
822 | forwardings) | |
823 | ",")) | |
824 | ||
825 | (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>) | |
826 | system target) | |
ed419fa0 | 827 | (match vm |
eb152070 | 828 | (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ()) |
ed419fa0 | 829 | (system-qemu-image/shared-store-script os |
60f759f0 LC |
830 | #:system system |
831 | #:target target | |
ed419fa0 LC |
832 | #:qemu qemu |
833 | #:graphic? graphic? | |
eb152070 CB |
834 | #:memory-size memory-size |
835 | #:disk-image-size | |
836 | disk-image-size)) | |
837 | (($ <virtual-machine> os qemu graphic? memory-size disk-image-size | |
838 | forwardings) | |
ed419fa0 | 839 | (let ((options |
8e53fe2b MB |
840 | `("-nic" ,(string-append |
841 | "user,model=virtio-net-pci," | |
ed419fa0 LC |
842 | (port-forwardings->qemu-options forwardings))))) |
843 | (system-qemu-image/shared-store-script os | |
60f759f0 LC |
844 | #:system system |
845 | #:target target | |
ed419fa0 LC |
846 | #:qemu qemu |
847 | #:graphic? graphic? | |
848 | #:memory-size memory-size | |
eb152070 CB |
849 | #:disk-image-size |
850 | disk-image-size | |
ed419fa0 LC |
851 | #:options options))))) |
852 | ||
04086015 | 853 | ;;; vm.scm ends here |