Commit | Line | Data |
---|---|---|
04086015 | 1 | ;;; GNU Guix --- Functional package management for GNU |
61b94b8c | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
944d2b17 | 3 | ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> |
2ca712bd | 4 | ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> |
07f812c4 | 5 | ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> |
ecf5d537 | 6 | ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> |
8c9bf294 | 7 | ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> |
04086015 LC |
8 | ;;; |
9 | ;;; This file is part of GNU Guix. | |
10 | ;;; | |
11 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
12 | ;;; under the terms of the GNU General Public License as published by | |
13 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
14 | ;;; your option) any later version. | |
15 | ;;; | |
16 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
17 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;;; GNU General Public License for more details. | |
20 | ;;; | |
21 | ;;; You should have received a copy of the GNU General Public License | |
22 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | (define-module (gnu system vm) | |
93d44bd8 | 25 | #:use-module (guix config) |
04086015 | 26 | #:use-module (guix store) |
02100028 | 27 | #:use-module (guix gexp) |
04086015 LC |
28 | #:use-module (guix derivations) |
29 | #:use-module (guix packages) | |
d9f0a237 | 30 | #:use-module (guix monads) |
fcf63cf8 | 31 | #:use-module (guix records) |
239c6e27 | 32 | #:use-module (guix modules) |
00e39b2e | 33 | #:use-module (guix utils) |
dffc5ab5 LC |
34 | #:use-module (guix hash) |
35 | #:use-module (guix base32) | |
fcf63cf8 | 36 | |
548f7a8f | 37 | #:use-module ((gnu build vm) |
66670cf3 | 38 | #:select (qemu-command)) |
bdb36958 | 39 | #:use-module (gnu packages base) |
862e38d5 | 40 | #:use-module (gnu packages bootloaders) |
be1033a3 | 41 | #:use-module (gnu packages cdrom) |
1b89a66e | 42 | #:use-module (gnu packages guile) |
bdb36958 | 43 | #:use-module (gnu packages gawk) |
1b89a66e | 44 | #:use-module (gnu packages bash) |
4f62d8d6 | 45 | #:use-module (gnu packages less) |
59132b80 | 46 | #:use-module (gnu packages virtualization) |
cc4a2aeb | 47 | #:use-module (gnu packages disk) |
5b16ff09 | 48 | #:use-module (gnu packages zile) |
04086015 | 49 | #:use-module (gnu packages linux) |
30f25b03 | 50 | #:use-module (gnu packages package-management) |
04086015 LC |
51 | #:use-module ((gnu packages make-bootstrap) |
52 | #:select (%guile-static-stripped)) | |
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) |
735c6dd7 | 59 | #:use-module (gnu system linux-initrd) |
b09a8da4 | 60 | #:use-module (gnu bootloader) |
c5df1839 | 61 | #:use-module (gnu system file-systems) |
033adfe7 | 62 | #:use-module (gnu system) |
db4fdc04 | 63 | #:use-module (gnu services) |
9b336338 | 64 | #:use-module (gnu system uuid) |
0ded70f3 | 65 | |
ca85d7bc | 66 | #:use-module (srfi srfi-1) |
04086015 | 67 | #:use-module (srfi srfi-26) |
5f7fe1c5 | 68 | #:use-module (rnrs bytevectors) |
04086015 | 69 | #:use-module (ice-9 match) |
0ded70f3 | 70 | |
04086015 | 71 | #:export (expression->derivation-in-linux-vm |
aedb72fb | 72 | qemu-image |
e9f693d0 | 73 | virtualized-operating-system |
fd3bfc44 | 74 | system-qemu-image |
fcf63cf8 | 75 | |
fd3bfc44 | 76 | system-qemu-image/shared-store |
1e77fedb | 77 | system-qemu-image/shared-store-script |
ed419fa0 LC |
78 | system-disk-image |
79 | ||
80 | virtual-machine | |
81 | virtual-machine?)) | |
04086015 LC |
82 | |
83 | \f | |
84 | ;;; Commentary: | |
85 | ;;; | |
86 | ;;; Tools to evaluate build expressions within virtual machines. | |
87 | ;;; | |
88 | ;;; Code: | |
89 | ||
83bcd0b8 | 90 | (define %linux-vm-file-systems |
8c9bf294 CM |
91 | ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with |
92 | ;; the host over 9p. | |
83bcd0b8 LC |
93 | (list (file-system |
94 | (mount-point (%store-prefix)) | |
95 | (device "store") | |
96 | (type "9p") | |
97 | (needed-for-boot? #t) | |
3c05b4bc LC |
98 | (options "trans=virtio") |
99 | (check? #f)) | |
83bcd0b8 LC |
100 | (file-system |
101 | (mount-point "/xchg") | |
102 | (device "xchg") | |
103 | (type "9p") | |
104 | (needed-for-boot? #t) | |
3c05b4bc | 105 | (options "trans=virtio") |
8c9bf294 CM |
106 | (check? #f)) |
107 | (file-system | |
108 | (mount-point "/tmp") | |
109 | (device "tmp") | |
110 | (type "9p") | |
111 | (needed-for-boot? #t) | |
112 | (options "trans=virtio") | |
3c05b4bc | 113 | (check? #f)))) |
83bcd0b8 | 114 | |
d9f0a237 | 115 | (define* (expression->derivation-in-linux-vm name exp |
04086015 | 116 | #:key |
2455085a | 117 | (system (%current-system)) |
04086015 | 118 | (linux linux-libre) |
735c6dd7 | 119 | initrd |
06da1a6b | 120 | (qemu qemu-minimal) |
04086015 | 121 | (env-vars '()) |
04086015 LC |
122 | (guile-for-build |
123 | (%guile-for-build)) | |
124 | ||
8d033e3e | 125 | (single-file-output? #f) |
04086015 | 126 | (make-disk-image? #f) |
ca85d7bc | 127 | (references-graphs #f) |
defa1b9b | 128 | (memory-size 256) |
c4a74364 | 129 | (disk-image-format "qcow2") |
a8ac4f08 | 130 | (disk-image-size 'guess)) |
735c6dd7 | 131 | "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a |
8d033e3e LC |
132 | derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the |
133 | virtual machine, EXP has access to all its inputs from the store; it should | |
134 | put its output file(s) in the '/xchg' directory. | |
135 | ||
136 | If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT. | |
137 | Otherwise, copy the contents of /xchg to a new directory OUTPUT. | |
04086015 | 138 | |
c4a74364 LC |
139 | When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type |
140 | DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and | |
a8ac4f08 LC |
141 | return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based |
142 | based on the size of the closure of REFERENCES-GRAPHS. | |
ca85d7bc LC |
143 | |
144 | When REFERENCES-GRAPHS is true, it must be a list of file name/store path | |
145 | pairs, as for `derivation'. The files containing the reference graphs are | |
146 | made available under the /xchg CIFS share." | |
d9f0a237 | 147 | (mlet* %store-monad |
fd129893 | 148 | ((user-builder (gexp->file "builder-in-linux-vm" exp)) |
02100028 | 149 | (loader (gexp->file "linux-vm-loader" |
fd129893 | 150 | #~(primitive-load #$user-builder))) |
bdb36958 | 151 | (coreutils -> (canonical-package coreutils)) |
d4254711 | 152 | (initrd (if initrd ; use the default initrd? |
735c6dd7 | 153 | (return initrd) |
060238ae | 154 | (base-initrd %linux-vm-file-systems |
248db51c | 155 | #:on-error 'backtrace |
0d275f4a | 156 | #:linux linux |
5a3716ae | 157 | #:linux-modules %base-initrd-modules |
6c1df081 | 158 | #:qemu-networking? #t)))) |
1aa0033b LC |
159 | |
160 | (define builder | |
161 | ;; Code that launches the VM that evaluates EXP. | |
239c6e27 LC |
162 | (with-imported-modules (source-module-closure '((guix build utils) |
163 | (gnu build vm))) | |
4ee96a79 LC |
164 | #~(begin |
165 | (use-modules (guix build utils) | |
166 | (gnu build vm)) | |
167 | ||
a8ac4f08 LC |
168 | (let* ((inputs '#$(list qemu coreutils)) |
169 | (linux (string-append #$linux "/" | |
170 | #$(system-linux-image-file-name))) | |
171 | (initrd (string-append #$initrd "/initrd")) | |
172 | (loader #$loader) | |
173 | (graphs '#$(match references-graphs | |
174 | (((graph-files . _) ...) graph-files) | |
175 | (_ #f))) | |
176 | (size #$(if (eq? 'guess disk-image-size) | |
177 | #~(+ (* 70 (expt 2 20)) ;ESP | |
178 | (estimated-partition-size graphs)) | |
179 | disk-image-size))) | |
4ee96a79 LC |
180 | |
181 | (set-path-environment-variable "PATH" '("bin") inputs) | |
182 | ||
183 | (load-in-linux-vm loader | |
184 | #:output #$output | |
185 | #:linux linux #:initrd initrd | |
186 | #:memory-size #$memory-size | |
187 | #:make-disk-image? #$make-disk-image? | |
8d033e3e | 188 | #:single-file-output? #$single-file-output? |
acf54bca MO |
189 | ;; FIXME: ‘target-arm32?’ may not operate on |
190 | ;; the right system/target values. Rewrite | |
191 | ;; using ‘let-system’ when available. | |
192 | #:target-arm32? #$(target-arm32?) | |
4ee96a79 | 193 | #:disk-image-format #$disk-image-format |
a8ac4f08 | 194 | #:disk-image-size size |
4ee96a79 | 195 | #:references-graphs graphs))))) |
1aa0033b LC |
196 | |
197 | (gexp->derivation name builder | |
198 | ;; TODO: Require the "kvm" feature. | |
199 | #:system system | |
200 | #:env-vars env-vars | |
1aa0033b LC |
201 | #:guile-for-build guile-for-build |
202 | #:references-graphs references-graphs))) | |
d9f0a237 | 203 | |
be1033a3 DM |
204 | (define* (iso9660-image #:key |
205 | (name "iso9660-image") | |
acc0f6bb DM |
206 | file-system-label |
207 | file-system-uuid | |
be1033a3 DM |
208 | (system (%current-system)) |
209 | (qemu qemu-minimal) | |
210 | os-drv | |
211 | bootcfg-drv | |
212 | bootloader | |
e375d3fa | 213 | register-closures? |
be1033a3 DM |
214 | (inputs '())) |
215 | "Return a bootable, stand-alone iso9660 image. | |
216 | ||
217 | INPUTS is a list of inputs (as for packages)." | |
218 | (expression->derivation-in-linux-vm | |
219 | name | |
220 | (with-imported-modules (source-module-closure '((gnu build vm) | |
221 | (guix build utils))) | |
222 | #~(begin | |
223 | (use-modules (gnu build vm) | |
224 | (guix build utils)) | |
225 | ||
226 | (let ((inputs | |
227 | '#$(append (list qemu parted e2fsprogs dosfstools xorriso) | |
228 | (map canonical-package | |
e375d3fa CB |
229 | (list sed grep coreutils findutils gawk)) |
230 | (if register-closures? (list guix) '()))) | |
be1033a3 | 231 | |
e375d3fa CB |
232 | |
233 | (graphs '#$(match inputs | |
234 | (((names . _) ...) | |
235 | names))) | |
be1033a3 DM |
236 | ;; This variable is unused but allows us to add INPUTS-TO-COPY |
237 | ;; as inputs. | |
238 | (to-register | |
239 | '#$(map (match-lambda | |
240 | ((name thing) thing) | |
241 | ((name thing output) `(,thing ,output))) | |
242 | inputs))) | |
243 | ||
244 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) | |
245 | (make-iso9660-image #$(bootloader-package bootloader) | |
246 | #$bootcfg-drv | |
247 | #$os-drv | |
acc0f6bb | 248 | "/xchg/guixsd.iso" |
e375d3fa CB |
249 | #:register-closures? #$register-closures? |
250 | #:closures graphs | |
acc0f6bb | 251 | #:volume-id #$file-system-label |
9b336338 LC |
252 | #:volume-uuid #$(and=> file-system-uuid |
253 | uuid-bytevector)) | |
be1033a3 DM |
254 | (reboot)))) |
255 | #:system system | |
256 | #:make-disk-image? #f | |
8d033e3e | 257 | #:single-file-output? #t |
be1033a3 DM |
258 | #:references-graphs inputs)) |
259 | ||
d9f0a237 | 260 | (define* (qemu-image #:key |
04086015 LC |
261 | (name "qemu-image") |
262 | (system (%current-system)) | |
06da1a6b | 263 | (qemu qemu-minimal) |
a8ac4f08 | 264 | (disk-image-size 'guess) |
c4a74364 | 265 | (disk-image-format "qcow2") |
03ddfaf5 | 266 | (file-system-type "ext4") |
ef9fc40d | 267 | file-system-label |
fd3b4b98 | 268 | file-system-uuid |
9121ce55 MO |
269 | os-drv |
270 | bootcfg-drv | |
271 | bootloader | |
150e20dd | 272 | (register-closures? #t) |
150e20dd LC |
273 | (inputs '()) |
274 | copy-inputs?) | |
c4a74364 | 275 | "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., |
ef9fc40d LC |
276 | 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. |
277 | Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root | |
fd3b4b98 LC |
278 | partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root |
279 | partition (a UUID object). | |
280 | ||
281 | The returned image is a full disk image that runs OS-DERIVATION, | |
f2c403ea LC |
282 | with a GRUB installation that uses GRUB-CONFIGURATION as its configuration |
283 | file (GRUB-CONFIGURATION must be the name of a file in the VM.) | |
93d44bd8 | 284 | |
150e20dd LC |
285 | INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy |
286 | all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, | |
287 | register INPUTS in the store database of the image so that Guix can be used in | |
b4140694 | 288 | the image." |
b53833b2 LC |
289 | (expression->derivation-in-linux-vm |
290 | name | |
e2248203 MO |
291 | (with-imported-modules (source-module-closure '((gnu build bootloader) |
292 | (gnu build vm) | |
239c6e27 | 293 | (guix build utils))) |
fd129893 | 294 | #~(begin |
e2248203 MO |
295 | (use-modules (gnu build bootloader) |
296 | (gnu build vm) | |
a8ac4f08 | 297 | (guix build utils) |
4307397b MO |
298 | (srfi srfi-26) |
299 | (ice-9 binary-ports)) | |
1aa0033b | 300 | |
fd129893 | 301 | (let ((inputs |
4d415f0c | 302 | '#$(append (list qemu parted e2fsprogs dosfstools) |
fd129893 LC |
303 | (map canonical-package |
304 | (list sed grep coreutils findutils gawk)) | |
305 | (if register-closures? (list guix) '()))) | |
1aa0033b | 306 | |
fd129893 LC |
307 | ;; This variable is unused but allows us to add INPUTS-TO-COPY |
308 | ;; as inputs. | |
309 | (to-register | |
310 | '#$(map (match-lambda | |
311 | ((name thing) thing) | |
312 | ((name thing output) `(,thing ,output))) | |
313 | inputs))) | |
1aa0033b | 314 | |
fd129893 | 315 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
1aa0033b | 316 | |
fd129893 LC |
317 | (let* ((graphs '#$(match inputs |
318 | (((names . _) ...) | |
319 | names))) | |
320 | (initialize (root-partition-initializer | |
321 | #:closures graphs | |
322 | #:copy-closures? #$copy-inputs? | |
323 | #:register-closures? #$register-closures? | |
9121ce55 | 324 | #:system-directory #$os-drv)) |
a8ac4f08 | 325 | (root-size #$(if (eq? 'guess disk-image-size) |
0c75a4de CB |
326 | #~(max |
327 | ;; Minimum 20 MiB root size | |
328 | (* 20 (expt 2 20)) | |
329 | (estimated-partition-size | |
330 | (map (cut string-append "/xchg/" <>) | |
331 | graphs))) | |
a8ac4f08 LC |
332 | (- disk-image-size |
333 | (* 50 (expt 2 20))))) | |
00e39b2e MO |
334 | (partitions |
335 | (append | |
336 | (list (partition | |
337 | (size root-size) | |
338 | (label #$file-system-label) | |
339 | (uuid #$(and=> file-system-uuid | |
340 | uuid-bytevector)) | |
341 | (file-system #$file-system-type) | |
342 | (flags '(boot)) | |
343 | (initializer initialize))) | |
344 | ;; Append a small EFI System Partition for use with UEFI | |
04bbd072 | 345 | ;; bootloaders if we are not targeting ARM because UEFI |
00e39b2e MO |
346 | ;; support in U-Boot is experimental. |
347 | ;; | |
348 | ;; FIXME: ‘target-arm32?’ may be not operate on the right | |
349 | ;; system/target values. Rewrite using ‘let-system’ when | |
350 | ;; available. | |
351 | (if #$(target-arm32?) | |
352 | '() | |
353 | (list (partition | |
354 | ;; The standalone grub image is about 10MiB, but | |
355 | ;; leave some room for custom or multiple images. | |
356 | (size (* 40 (expt 2 20))) | |
357 | (label "GNU-ESP") ;cosmetic only | |
358 | ;; Use "vfat" here since this property is used | |
359 | ;; when mounting. The actual FAT-ness is based | |
162a1374 | 360 | ;; on file system size (16 in this case). |
00e39b2e MO |
361 | (file-system "vfat") |
362 | (flags '(esp)))))))) | |
fd129893 LC |
363 | (initialize-hard-disk "/dev/vda" |
364 | #:partitions partitions | |
ecf5d537 | 365 | #:grub-efi #$grub-efi |
9121ce55 MO |
366 | #:bootloader-package |
367 | #$(bootloader-package bootloader) | |
368 | #:bootcfg #$bootcfg-drv | |
369 | #:bootcfg-location | |
370 | #$(bootloader-configuration-file bootloader) | |
371 | #:bootloader-installer | |
372 | #$(bootloader-installer bootloader)) | |
fd129893 | 373 | (reboot))))) |
b53833b2 LC |
374 | #:system system |
375 | #:make-disk-image? #t | |
376 | #:disk-image-size disk-image-size | |
377 | #:disk-image-format disk-image-format | |
378 | #:references-graphs inputs)) | |
04086015 LC |
379 | |
380 | \f | |
381 | ;;; | |
1e77fedb | 382 | ;;; VM and disk images. |
04086015 LC |
383 | ;;; |
384 | ||
5f7fe1c5 LC |
385 | (define* (operating-system-uuid os #:optional (type 'dce)) |
386 | "Compute UUID object with a deterministic \"UUID\" for OS, of the given | |
387 | TYPE (one of 'iso9660 or 'dce). Return a UUID object." | |
388 | (if (eq? type 'iso9660) | |
389 | (let ((pad (compose (cut string-pad <> 2 #\0) | |
390 | number->string)) | |
391 | (h (hash (operating-system-services os) 3600))) | |
392 | (bytevector->uuid | |
393 | (string->iso9660-uuid | |
394 | (string-append "1970-01-01-" | |
395 | (pad (hash (operating-system-host-name os) 24)) "-" | |
396 | (pad (quotient h 60)) "-" | |
397 | (pad (modulo h 60)) "-" | |
398 | (pad (hash (operating-system-file-systems os) 100)))) | |
399 | 'iso9660)) | |
400 | (bytevector->uuid | |
401 | (uint-list->bytevector | |
402 | (list (hash file-system-type | |
b1a30793 | 403 | (- (expt 2 32) 1)) |
5f7fe1c5 | 404 | (hash (operating-system-host-name os) |
b1a30793 | 405 | (- (expt 2 32) 1)) |
5f7fe1c5 | 406 | (hash (operating-system-services os) |
b1a30793 | 407 | (- (expt 2 32) 1)) |
5f7fe1c5 | 408 | (hash (operating-system-file-systems os) |
b1a30793 | 409 | (- (expt 2 32) 1))) |
5f7fe1c5 LC |
410 | (endianness little) |
411 | 4) | |
412 | type))) | |
413 | ||
1e77fedb LC |
414 | (define* (system-disk-image os |
415 | #:key | |
56ef7fcc | 416 | (name "disk-image") |
1e77fedb LC |
417 | (file-system-type "ext4") |
418 | (disk-image-size (* 900 (expt 2 20))) | |
419 | (volatile? #t)) | |
420 | "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the | |
421 | system described by OS. Said image can be copied on a USB stick as is. When | |
422 | VOLATILE? is true, the root file system is made volatile; this is useful | |
423 | to USB sticks meant to be read-only." | |
651de2bd DM |
424 | (define normalize-label |
425 | ;; ISO labels are all-caps (case-insensitive), but since | |
426 | ;; 'find-partition-by-label' is case-sensitive, make it all-caps here. | |
427 | (if (string=? "iso9660" file-system-type) | |
428 | string-upcase | |
429 | identity)) | |
5f7fe1c5 | 430 | |
10ace2c4 | 431 | (define root-label |
5f7fe1c5 | 432 | ;; Volume name of the root file system. |
0862b954 | 433 | (normalize-label "GuixSD_image")) |
10ace2c4 | 434 | |
5f7fe1c5 LC |
435 | (define root-uuid |
436 | ;; UUID of the root file system, computed in a deterministic fashion. | |
437 | ;; This is what we use to locate the root file system so it has to be | |
438 | ;; different from the user's own file system UUIDs. | |
439 | (operating-system-uuid os | |
440 | (if (string=? file-system-type "iso9660") | |
441 | 'iso9660 | |
442 | 'dce))) | |
443 | ||
1e77fedb LC |
444 | (define file-systems-to-keep |
445 | (remove (lambda (fs) | |
446 | (string=? (file-system-mount-point fs) "/")) | |
447 | (operating-system-file-systems os))) | |
448 | ||
449 | (let ((os (operating-system (inherit os) | |
932e1f92 | 450 | ;; Since this is meant to be used on real hardware, don't |
493c245b LC |
451 | ;; install QEMU networking or anything like that. Assume USB |
452 | ;; mass storage devices (usb-storage.ko) are available. | |
52ac153e | 453 | (initrd (lambda (file-systems . rest) |
b8e77811 MO |
454 | (apply (operating-system-initrd os) |
455 | file-systems | |
52ac153e | 456 | #:volatile-root? #t |
52ac153e | 457 | rest))) |
1e77fedb | 458 | |
cf189709 DM |
459 | (bootloader (if (string=? "iso9660" file-system-type) |
460 | (bootloader-configuration | |
461 | (inherit (operating-system-bootloader os)) | |
462 | (bootloader grub-mkrescue-bootloader)) | |
463 | (operating-system-bootloader os))) | |
464 | ||
1e77fedb LC |
465 | ;; Force our own root file system. |
466 | (file-systems (cons (file-system | |
467 | (mount-point "/") | |
5f7fe1c5 LC |
468 | (device root-uuid) |
469 | (title 'uuid) | |
1e77fedb LC |
470 | (type file-system-type)) |
471 | file-systems-to-keep))))) | |
472 | ||
473 | (mlet* %store-monad ((os-drv (operating-system-derivation os)) | |
c76b3046 | 474 | (bootcfg (operating-system-bootcfg os))) |
be1033a3 DM |
475 | (if (string=? "iso9660" file-system-type) |
476 | (iso9660-image #:name name | |
acc0f6bb | 477 | #:file-system-label root-label |
5f7fe1c5 | 478 | #:file-system-uuid root-uuid |
be1033a3 | 479 | #:os-drv os-drv |
b069111f | 480 | #:register-closures? #t |
be1033a3 DM |
481 | #:bootcfg-drv bootcfg |
482 | #:bootloader (bootloader-configuration-bootloader | |
483 | (operating-system-bootloader os)) | |
484 | #:inputs `(("system" ,os-drv) | |
485 | ("bootcfg" ,bootcfg))) | |
486 | (qemu-image #:name name | |
487 | #:os-drv os-drv | |
488 | #:bootcfg-drv bootcfg | |
489 | #:bootloader (bootloader-configuration-bootloader | |
490 | (operating-system-bootloader os)) | |
491 | #:disk-image-size disk-image-size | |
492 | #:disk-image-format "raw" | |
4138e782 | 493 | #:file-system-type file-system-type |
be1033a3 | 494 | #:file-system-label root-label |
5f7fe1c5 | 495 | #:file-system-uuid root-uuid |
be1033a3 DM |
496 | #:copy-inputs? #t |
497 | #:register-closures? #t | |
498 | #:inputs `(("system" ,os-drv) | |
499 | ("bootcfg" ,bootcfg))))))) | |
1e77fedb | 500 | |
0b14d1d7 | 501 | (define* (system-qemu-image os |
66f23d66 LC |
502 | #:key |
503 | (file-system-type "ext4") | |
504 | (disk-image-size (* 900 (expt 2 20)))) | |
505 | "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes | |
506 | of the GNU system as described by OS." | |
1eeccc2f LC |
507 | (define file-systems-to-keep |
508 | ;; Keep only file systems other than root and not normally bound to real | |
509 | ;; devices. | |
510 | (remove (lambda (fs) | |
511 | (let ((target (file-system-mount-point fs)) | |
512 | (source (file-system-device fs))) | |
513 | (or (string=? target "/") | |
514 | (string-prefix? "/dev/" source)))) | |
515 | (operating-system-file-systems os))) | |
516 | ||
61b94b8c LC |
517 | (define root-uuid |
518 | ;; UUID of the root file system. | |
519 | (operating-system-uuid os | |
520 | (if (string=? file-system-type "iso9660") | |
521 | 'iso9660 | |
522 | 'dce))) | |
523 | ||
524 | ||
66f23d66 | 525 | (let ((os (operating-system (inherit os) |
eac026e5 | 526 | ;; Assume we have an initrd with the whole QEMU shebang. |
e84d8b30 | 527 | |
61b94b8c LC |
528 | ;; Force our own root file system. Refer to it by UUID so that |
529 | ;; it works regardless of how the image is used ("qemu -hda", | |
530 | ;; Xen, etc.). | |
1eeccc2f | 531 | (file-systems (cons (file-system |
66f23d66 | 532 | (mount-point "/") |
61b94b8c LC |
533 | (device root-uuid) |
534 | (title 'uuid) | |
1eeccc2f LC |
535 | (type file-system-type)) |
536 | file-systems-to-keep))))) | |
66f23d66 LC |
537 | (mlet* %store-monad |
538 | ((os-drv (operating-system-derivation os)) | |
c76b3046 | 539 | (bootcfg (operating-system-bootcfg os))) |
9121ce55 MO |
540 | (qemu-image #:os-drv os-drv |
541 | #:bootcfg-drv bootcfg | |
542 | #:bootloader (bootloader-configuration-bootloader | |
543 | (operating-system-bootloader os)) | |
66f23d66 LC |
544 | #:disk-image-size disk-image-size |
545 | #:file-system-type file-system-type | |
61b94b8c | 546 | #:file-system-uuid root-uuid |
b4140694 | 547 | #:inputs `(("system" ,os-drv) |
07f812c4 | 548 | ("bootcfg" ,bootcfg)) |
150e20dd | 549 | #:copy-inputs? #t)))) |
04086015 | 550 | |
fcf63cf8 LC |
551 | \f |
552 | ;;; | |
553 | ;;; VMs that share file systems with the host. | |
554 | ;;; | |
555 | ||
96ffa27b LC |
556 | (define (file-system->mount-tag fs) |
557 | "Return a 9p mount tag for host file system FS." | |
dffc5ab5 LC |
558 | ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain |
559 | ;; slashes, and cannot start with '_'. Compute an identifier that | |
560 | ;; corresponds to the rules. | |
96ffa27b | 561 | (string-append "TAG" |
dffc5ab5 LC |
562 | (string-drop (bytevector->base32-string |
563 | (sha1 (string->utf8 fs))) | |
564 | 4))) | |
96ffa27b | 565 | |
fcf63cf8 LC |
566 | (define (mapping->file-system mapping) |
567 | "Return a 9p file system that realizes MAPPING." | |
568 | (match mapping | |
569 | (($ <file-system-mapping> source target writable?) | |
570 | (file-system | |
571 | (mount-point target) | |
572 | (device (file-system->mount-tag source)) | |
573 | (type "9p") | |
574 | (flags (if writable? '() '(read-only))) | |
e0d96774 | 575 | (options "trans=virtio,cache=loose") |
fcf63cf8 LC |
576 | (check? #f) |
577 | (create-mount-point? #t))))) | |
578 | ||
909de139 | 579 | (define* (virtualized-operating-system os mappings #:optional (full-boot? #f)) |
83bcd0b8 | 580 | "Return an operating system based on OS suitable for use in a virtualized |
fcf63cf8 LC |
581 | environment with the store shared with the host. MAPPINGS is a list of |
582 | <file-system-mapping> to realize in the virtualized OS." | |
583 | (define user-file-systems | |
584 | ;; Remove file systems that conflict with those added below, or that are | |
585 | ;; normally bound to real devices. | |
586 | (remove (lambda (fs) | |
587 | (let ((target (file-system-mount-point fs)) | |
588 | (source (file-system-device fs))) | |
589 | (or (string=? target (%store-prefix)) | |
590 | (string=? target "/") | |
29824d80 | 591 | (and (eq? 'device (file-system-title fs)) |
f00515b4 LC |
592 | (string-prefix? "/dev/" source)) |
593 | ||
594 | ;; Labels and UUIDs are necessarily invalid in the VM. | |
595 | (and (file-system-mount? fs) | |
596 | (or (eq? 'label (file-system-title fs)) | |
597 | (eq? 'uuid (file-system-title fs)) | |
598 | (uuid? source)))))) | |
fcf63cf8 LC |
599 | (operating-system-file-systems os))) |
600 | ||
909de139 DC |
601 | (define virtual-file-systems |
602 | (cons (file-system | |
603 | (mount-point "/") | |
604 | (device "/dev/vda1") | |
605 | (type "ext4")) | |
606 | ||
607 | (append (map mapping->file-system mappings) | |
608 | user-file-systems))) | |
609 | ||
83bcd0b8 | 610 | (operating-system (inherit os) |
9b396c0c LC |
611 | |
612 | ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware), | |
613 | ;; force the traditional i386/BIOS method. | |
614 | ;; See <https://bugs.gnu.org/28768>. | |
615 | (bootloader (bootloader-configuration | |
616 | (bootloader grub-bootloader) | |
617 | (target "/dev/vda"))) | |
618 | ||
52ac153e | 619 | (initrd (lambda (file-systems . rest) |
b8e77811 MO |
620 | (apply (operating-system-initrd os) |
621 | file-systems | |
52ac153e | 622 | #:volatile-root? #t |
52ac153e | 623 | rest))) |
65fb4515 LC |
624 | |
625 | ;; Disable swap. | |
626 | (swap-devices '()) | |
627 | ||
909de139 DC |
628 | ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store |
629 | ;; since that would lead the bootloader config to look for the kernel and | |
630 | ;; initrd in it. | |
631 | (file-systems (if full-boot? | |
632 | virtual-file-systems | |
633 | (cons | |
634 | (file-system | |
635 | (inherit (mapping->file-system %store-mapping)) | |
636 | (needed-for-boot? #t)) | |
637 | virtual-file-systems))))) | |
83bcd0b8 | 638 | |
fd3bfc44 | 639 | (define* (system-qemu-image/shared-store |
0b14d1d7 | 640 | os |
6aa260af LC |
641 | #:key |
642 | full-boot? | |
4c0416ae | 643 | (disk-image-size (* (if full-boot? 500 30) (expt 2 20)))) |
fd3bfc44 | 644 | "Return a derivation that builds a QEMU image of OS that shares its store |
6aa260af LC |
645 | with the host. |
646 | ||
647 | When FULL-BOOT? is true, return an image that does a complete boot sequence, | |
648 | bootloaded included; thus, make a disk image that contains everything the | |
649 | bootloader refers to: OS kernel, initrd, bootloader data, etc." | |
650 | (mlet* %store-monad ((os-drv (operating-system-derivation os)) | |
c76b3046 | 651 | (bootcfg (operating-system-bootcfg os))) |
6aa260af | 652 | ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains |
07f812c4 | 653 | ;; BOOTCFG and all its dependencies, including the output of OS-DRV. |
6aa260af LC |
654 | ;; This is more than needed (we only need the kernel, initrd, GRUB for its |
655 | ;; font, and the background image), but it's hard to filter that. | |
9121ce55 MO |
656 | (qemu-image #:os-drv os-drv |
657 | #:bootcfg-drv bootcfg | |
658 | #:bootloader (bootloader-configuration-bootloader | |
659 | (operating-system-bootloader os)) | |
150e20dd | 660 | #:disk-image-size disk-image-size |
6aa260af | 661 | #:inputs (if full-boot? |
07f812c4 | 662 | `(("bootcfg" ,bootcfg)) |
6aa260af | 663 | '()) |
150e20dd LC |
664 | |
665 | ;; XXX: Passing #t here is too slow, so let it off by default. | |
666 | #:register-closures? #f | |
6aa260af | 667 | #:copy-inputs? full-boot?))) |
fd3bfc44 | 668 | |
96ffa27b LC |
669 | (define* (common-qemu-options image shared-fs) |
670 | "Return the a string-value gexp with the common QEMU options to boot IMAGE, | |
671 | with '-virtfs' options for the host file systems listed in SHARED-FS." | |
26a076ed | 672 | |
96ffa27b | 673 | (define (virtfs-option fs) |
26a076ed DC |
674 | #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s" |
675 | #$fs #$(file-system->mount-tag fs))) | |
96ffa27b | 676 | |
26a076ed | 677 | #~(;; Only enable kvm if we see /dev/kvm exists. |
944d2b17 CAW |
678 | ;; This allows users without hardware virtualization to still use these |
679 | ;; commands. | |
26a076ed DC |
680 | #$@(if (file-exists? "/dev/kvm") |
681 | '("-enable-kvm") | |
682 | '()) | |
683 | ||
684 | "-no-reboot" | |
685 | "-net nic,model=virtio" | |
2ca712bd LF |
686 | "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" |
687 | "-device" "virtio-rng-pci,rng=guixsd-vm-rng" | |
26a076ed DC |
688 | |
689 | #$@(map virtfs-option shared-fs) | |
690 | "-vga std" | |
691 | (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" | |
ebfb71d4 | 692 | #$image))) |
3c1f0e3b | 693 | |
ab11f0be LC |
694 | (define* (system-qemu-image/shared-store-script os |
695 | #:key | |
696 | (qemu qemu) | |
697 | (graphic? #t) | |
ebfb71d4 | 698 | (memory-size 256) |
fcf63cf8 | 699 | (mappings '()) |
6aa260af LC |
700 | full-boot? |
701 | (disk-image-size | |
9a1bfe76 | 702 | (* (if full-boot? 500 70) |
ed419fa0 LC |
703 | (expt 2 20))) |
704 | (options '())) | |
fd3bfc44 | 705 | "Return a derivation that builds a script to run a virtual machine image of |
ebfb71d4 JN |
706 | OS that shares its store with the host. The virtual machine runs with |
707 | MEMORY-SIZE MiB of memory. | |
6aa260af | 708 | |
fcf63cf8 LC |
709 | MAPPINGS is a list of <file-system-mapping> specifying mapping of host file |
710 | systems into the guest. | |
711 | ||
6aa260af LC |
712 | When FULL-BOOT? is true, the returned script runs everything starting from the |
713 | bootloader; otherwise it directly starts the operating system kernel. The | |
714 | DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image; | |
715 | it is mostly useful when FULL-BOOT? is true." | |
909de139 | 716 | (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?)) |
6aa260af LC |
717 | (os-drv (operating-system-derivation os)) |
718 | (image (system-qemu-image/shared-store | |
719 | os | |
720 | #:full-boot? full-boot? | |
721 | #:disk-image-size disk-image-size))) | |
26a076ed | 722 | (define kernel-arguments |
83071b05 DM |
723 | #~(list #$@(if graphic? #~() #~("console=ttyS0")) |
724 | #+@(operating-system-kernel-arguments os os-drv "/dev/vda1"))) | |
26a076ed DC |
725 | |
726 | (define qemu-exec | |
727 | #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system))) | |
728 | #$@(if full-boot? | |
729 | #~() | |
730 | #~("-kernel" #$(operating-system-kernel-file os) | |
731 | "-initrd" #$(file-append os-drv "/initrd") | |
732 | (format #f "-append ~s" | |
733 | (string-join #$kernel-arguments " ")))) | |
734 | #$@(common-qemu-options image | |
735 | (map file-system-mapping-source | |
ebfb71d4 | 736 | (cons %store-mapping mappings))) |
ed419fa0 LC |
737 | "-m " (number->string #$memory-size) |
738 | #$@options)) | |
26a076ed | 739 | |
fd3bfc44 | 740 | (define builder |
02100028 LC |
741 | #~(call-with-output-file #$output |
742 | (lambda (port) | |
26a076ed DC |
743 | (format port "#!~a~% exec ~a \"$@\"~%" |
744 | #$(file-append bash "/bin/sh") | |
745 | (string-join #$qemu-exec " ")) | |
02100028 LC |
746 | (chmod port #o555)))) |
747 | ||
748 | (gexp->derivation "run-vm.sh" builder))) | |
fd3bfc44 | 749 | |
ed419fa0 LC |
750 | \f |
751 | ;;; | |
752 | ;;; High-level abstraction. | |
753 | ;;; | |
754 | ||
755 | (define-record-type* <virtual-machine> %virtual-machine | |
756 | make-virtual-machine | |
757 | virtual-machine? | |
758 | (operating-system virtual-machine-operating-system) ;<operating-system> | |
759 | (qemu virtual-machine-qemu ;<package> | |
760 | (default qemu)) | |
761 | (graphic? virtual-machine-graphic? ;Boolean | |
762 | (default #f)) | |
763 | (memory-size virtual-machine-memory-size ;integer (MiB) | |
764 | (default 256)) | |
eb152070 CB |
765 | (disk-image-size virtual-machine-disk-image-size ;integer (bytes) |
766 | (default 'guess)) | |
ed419fa0 LC |
767 | (port-forwardings virtual-machine-port-forwardings ;list of integer pairs |
768 | (default '()))) | |
769 | ||
770 | (define-syntax virtual-machine | |
771 | (syntax-rules () | |
772 | "Declare a virtual machine running the specified OS, with the given | |
773 | options." | |
774 | ((_ os) ;shortcut | |
775 | (%virtual-machine (operating-system os))) | |
776 | ((_ fields ...) | |
777 | (%virtual-machine fields ...)))) | |
778 | ||
779 | (define (port-forwardings->qemu-options forwardings) | |
780 | "Return the QEMU option for the given port FORWARDINGS as a string, where | |
781 | FORWARDINGS is a list of host-port/guest-port pairs." | |
782 | (string-join | |
783 | (map (match-lambda | |
784 | ((host-port . guest-port) | |
785 | (string-append "hostfwd=tcp::" | |
786 | (number->string host-port) | |
787 | "-:" (number->string guest-port)))) | |
788 | forwardings) | |
789 | ",")) | |
790 | ||
791 | (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>) | |
792 | system target) | |
793 | ;; XXX: SYSTEM and TARGET are ignored. | |
794 | (match vm | |
eb152070 | 795 | (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ()) |
ed419fa0 LC |
796 | (system-qemu-image/shared-store-script os |
797 | #:qemu qemu | |
798 | #:graphic? graphic? | |
eb152070 CB |
799 | #:memory-size memory-size |
800 | #:disk-image-size | |
801 | disk-image-size)) | |
802 | (($ <virtual-machine> os qemu graphic? memory-size disk-image-size | |
803 | forwardings) | |
ed419fa0 LC |
804 | (let ((options |
805 | `("-net" ,(string-append | |
806 | "user," | |
807 | (port-forwardings->qemu-options forwardings))))) | |
808 | (system-qemu-image/shared-store-script os | |
809 | #:qemu qemu | |
810 | #:graphic? graphic? | |
811 | #:memory-size memory-size | |
eb152070 CB |
812 | #:disk-image-size |
813 | disk-image-size | |
ed419fa0 LC |
814 | #:options options))))) |
815 | ||
04086015 | 816 | ;;; vm.scm ends here |