Commit | Line | Data |
---|---|---|
04086015 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu system vm) | |
93d44bd8 | 20 | #:use-module (guix config) |
04086015 LC |
21 | #:use-module (guix store) |
22 | #:use-module (guix derivations) | |
23 | #:use-module (guix packages) | |
d9f0a237 | 24 | #:use-module (guix monads) |
9f84f12f LC |
25 | #:use-module ((gnu packages base) |
26 | #:select (%final-inputs | |
27 | guile-final gcc-final glibc-final | |
4f62d8d6 | 28 | ld-wrapper binutils-final |
3141a8bd | 29 | coreutils findutils grep sed tzdata)) |
1b89a66e LC |
30 | #:use-module (gnu packages guile) |
31 | #:use-module (gnu packages bash) | |
4f62d8d6 | 32 | #:use-module (gnu packages less) |
04086015 LC |
33 | #:use-module (gnu packages qemu) |
34 | #:use-module (gnu packages parted) | |
5b16ff09 | 35 | #:use-module (gnu packages zile) |
04086015 LC |
36 | #:use-module (gnu packages grub) |
37 | #:use-module (gnu packages linux) | |
38 | #:use-module (gnu packages linux-initrd) | |
30f25b03 | 39 | #:use-module (gnu packages package-management) |
04086015 LC |
40 | #:use-module ((gnu packages make-bootstrap) |
41 | #:select (%guile-static-stripped)) | |
a843fe22 | 42 | #:use-module (gnu packages system) |
0ded70f3 LC |
43 | |
44 | #:use-module (gnu system shadow) | |
45 | #:use-module (gnu system linux) | |
46 | #:use-module (gnu system grub) | |
4646e30a | 47 | #:use-module (gnu system dmd) |
033adfe7 | 48 | #:use-module (gnu system) |
0ded70f3 | 49 | |
ca85d7bc | 50 | #:use-module (srfi srfi-1) |
04086015 LC |
51 | #:use-module (srfi srfi-26) |
52 | #:use-module (ice-9 match) | |
0ded70f3 | 53 | |
04086015 | 54 | #:export (expression->derivation-in-linux-vm |
aedb72fb LC |
55 | qemu-image |
56 | system-qemu-image)) | |
04086015 LC |
57 | |
58 | \f | |
59 | ;;; Commentary: | |
60 | ;;; | |
61 | ;;; Tools to evaluate build expressions within virtual machines. | |
62 | ;;; | |
63 | ;;; Code: | |
64 | ||
d9f0a237 | 65 | (define* (expression->derivation-in-linux-vm name exp |
04086015 | 66 | #:key |
2455085a LC |
67 | (system (%current-system)) |
68 | (inputs '()) | |
04086015 LC |
69 | (linux linux-libre) |
70 | (initrd qemu-initrd) | |
50731c51 | 71 | (qemu qemu/smb-shares) |
04086015 LC |
72 | (env-vars '()) |
73 | (modules '()) | |
74 | (guile-for-build | |
75 | (%guile-for-build)) | |
76 | ||
77 | (make-disk-image? #f) | |
ca85d7bc | 78 | (references-graphs #f) |
04086015 LC |
79 | (disk-image-size |
80 | (* 100 (expt 2 20)))) | |
81 | "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD. In the | |
82 | virtual machine, EXP has access to all of INPUTS from the store; it should put | |
83 | its output files in the `/xchg' directory, which is copied to the derivation's | |
84 | output when the VM terminates. | |
85 | ||
86 | When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of | |
ca85d7bc LC |
87 | DISK-IMAGE-SIZE bytes and return it. |
88 | ||
89 | When REFERENCES-GRAPHS is true, it must be a list of file name/store path | |
90 | pairs, as for `derivation'. The files containing the reference graphs are | |
91 | made available under the /xchg CIFS share." | |
8ab73e91 LC |
92 | ;; FIXME: Allow use of macros from other modules, as done in |
93 | ;; `build-expression->derivation'. | |
94 | ||
04086015 | 95 | (define input-alist |
d9f0a237 LC |
96 | (with-monad %store-monad |
97 | (map (match-lambda | |
98 | ((input (? package? package)) | |
99 | (mlet %store-monad ((out (package-file package #:system system))) | |
100 | (return `(,input . ,out)))) | |
101 | ((input (? package? package) sub-drv) | |
102 | (mlet %store-monad ((out (package-file package | |
103 | #:output sub-drv | |
104 | #:system system))) | |
105 | (return `(,input . ,out)))) | |
106 | ((input (? derivation? drv)) | |
107 | (return `(,input . ,(derivation->output-path drv)))) | |
108 | ((input (? derivation? drv) sub-drv) | |
109 | (return `(,input . ,(derivation->output-path drv sub-drv)))) | |
110 | ((input (and (? string?) (? store-path?) file)) | |
111 | (return `(,input . ,file)))) | |
112 | inputs))) | |
04086015 LC |
113 | |
114 | (define builder | |
115 | ;; Code that launches the VM that evaluates EXP. | |
ca85d7bc LC |
116 | `(let () |
117 | (use-modules (guix build utils) | |
118 | (srfi srfi-1) | |
119 | (ice-9 rdelim)) | |
04086015 LC |
120 | |
121 | (let ((out (assoc-ref %outputs "out")) | |
122 | (cu (string-append (assoc-ref %build-inputs "coreutils") | |
123 | "/bin")) | |
124 | (qemu (string-append (assoc-ref %build-inputs "qemu") | |
125 | "/bin/qemu-system-" | |
126 | (car (string-split ,system #\-)))) | |
127 | (img (string-append (assoc-ref %build-inputs "qemu") | |
128 | "/bin/qemu-img")) | |
129 | (linux (string-append (assoc-ref %build-inputs "linux") | |
130 | "/bzImage")) | |
131 | (initrd (string-append (assoc-ref %build-inputs "initrd") | |
132 | "/initrd")) | |
133 | (builder (assoc-ref %build-inputs "builder"))) | |
134 | ||
135 | ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB | |
136 | ;; directory, so it really needs `rm' in $PATH. | |
137 | (setenv "PATH" cu) | |
138 | ||
139 | ,(if make-disk-image? | |
30e45750 | 140 | `(zero? (system* img "create" "-f" "qcow2" "image.qcow2" |
04086015 LC |
141 | ,(number->string disk-image-size))) |
142 | '(begin)) | |
143 | ||
144 | (mkdir "xchg") | |
ca85d7bc LC |
145 | |
146 | ;; Copy the reference-graph files under xchg/ so EXP can access it. | |
147 | (begin | |
148 | ,@(match references-graphs | |
149 | (((graph-files . _) ...) | |
150 | (map (lambda (file) | |
151 | `(copy-file ,file | |
152 | ,(string-append "xchg/" file))) | |
153 | graph-files)) | |
154 | (#f '()))) | |
155 | ||
04086015 LC |
156 | (and (zero? |
157 | (system* qemu "-nographic" "-no-reboot" | |
158 | "-net" "nic,model=e1000" | |
159 | "-net" (string-append "user,smb=" (getcwd)) | |
160 | "-kernel" linux | |
161 | "-initrd" initrd | |
162 | "-append" (string-append "console=ttyS0 --load=" | |
163 | builder) | |
164 | ,@(if make-disk-image? | |
165 | '("-hda" "image.qcow2") | |
166 | '()))) | |
167 | ,(if make-disk-image? | |
168 | '(copy-file "image.qcow2" ; XXX: who mkdir'd OUT? | |
169 | out) | |
170 | '(begin | |
171 | (mkdir out) | |
172 | (copy-recursively "xchg" out))))))) | |
173 | ||
d9f0a237 LC |
174 | (mlet* %store-monad |
175 | ((input-alist (sequence %store-monad input-alist)) | |
176 | (exp* -> `(let ((%build-inputs ',input-alist)) | |
177 | ,exp)) | |
178 | (user-builder (text-file "builder-in-linux-vm" | |
179 | (object->string exp*))) | |
180 | (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) | |
181 | (inputs (lower-inputs `(("qemu" ,qemu) | |
182 | ("linux" ,linux) | |
183 | ("initrd" ,initrd) | |
184 | ("coreutils" ,coreutils) | |
185 | ("builder" ,user-builder) | |
186 | ,@inputs)))) | |
dd1a5a15 LC |
187 | (derivation-expression name builder |
188 | #:system system | |
189 | #:inputs inputs | |
d9f0a237 LC |
190 | #:env-vars env-vars |
191 | #:modules (delete-duplicates | |
192 | `((guix build utils) | |
193 | ,@modules)) | |
194 | #:guile-for-build guile-for-build | |
195 | #:references-graphs references-graphs))) | |
196 | ||
197 | (define* (qemu-image #:key | |
04086015 LC |
198 | (name "qemu-image") |
199 | (system (%current-system)) | |
200 | (disk-image-size (* 100 (expt 2 20))) | |
0e2ddecd | 201 | grub-configuration |
30f25b03 | 202 | (initialize-store? #f) |
785859d3 | 203 | (populate #f) |
93d44bd8 | 204 | (inputs '()) |
002e5ba8 | 205 | (inputs-to-copy '())) |
1b89a66e | 206 | "Return a bootable, stand-alone QEMU image. The returned image is a full |
0e2ddecd | 207 | disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its |
033adfe7 | 208 | configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) |
93d44bd8 LC |
209 | |
210 | INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied | |
30f25b03 LC |
211 | into the image being built. When INITIALIZE-STORE? is true, initialize the |
212 | store database in the image so that Guix can be used in the image. | |
785859d3 | 213 | |
d5d0f286 LC |
214 | POPULATE is a list of directives stating directories or symlinks to be created |
215 | in the disk image partition. It is evaluated once the image has been | |
216 | populated with INPUTS-TO-COPY. It can be used to provide additional files, | |
217 | such as /etc files." | |
d9f0a237 LC |
218 | (define (input->name+derivation tuple) |
219 | (with-monad %store-monad | |
220 | (match tuple | |
221 | ((name (? package? package)) | |
222 | (mlet %store-monad ((drv (package->derivation package system))) | |
223 | (return `(,name . ,(derivation->output-path drv))))) | |
224 | ((name (? package? package) sub-drv) | |
225 | (mlet %store-monad ((drv (package->derivation package system))) | |
226 | (return `(,name . ,(derivation->output-path drv sub-drv))))) | |
227 | ((name (? derivation? drv)) | |
228 | (return `(,name . ,(derivation->output-path drv)))) | |
229 | ((name (? derivation? drv) sub-drv) | |
230 | (return `(,name . ,(derivation->output-path drv sub-drv)))) | |
231 | ((input (and (? string?) (? store-path?) file)) | |
232 | (return `(,input . ,file)))))) | |
233 | ||
234 | (mlet %store-monad | |
235 | ((graph (sequence %store-monad | |
236 | (map input->name+derivation inputs-to-copy)))) | |
237 | (expression->derivation-in-linux-vm | |
238 | "qemu-image" | |
239 | `(let () | |
240 | (use-modules (ice-9 rdelim) | |
241 | (srfi srfi-1) | |
242 | (guix build utils) | |
243 | (guix build linux-initrd)) | |
244 | ||
245 | (let ((parted (string-append (assoc-ref %build-inputs "parted") | |
246 | "/sbin/parted")) | |
247 | (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs") | |
248 | "/sbin/mkfs.ext3")) | |
249 | (grub (string-append (assoc-ref %build-inputs "grub") | |
250 | "/sbin/grub-install")) | |
251 | (umount (string-append (assoc-ref %build-inputs "util-linux") | |
252 | "/bin/umount")) ; XXX: add to Guile | |
033adfe7 | 253 | (grub.cfg ,grub-configuration)) |
d9f0a237 LC |
254 | |
255 | (define (read-reference-graph port) | |
256 | ;; Return a list of store paths from the reference graph at PORT. | |
257 | ;; The data at PORT is the format produced by #:references-graphs. | |
258 | (let loop ((line (read-line port)) | |
259 | (result '())) | |
260 | (cond ((eof-object? line) | |
261 | (delete-duplicates result)) | |
262 | ((string-prefix? "/" line) | |
263 | (loop (read-line port) | |
264 | (cons line result))) | |
265 | (else | |
266 | (loop (read-line port) | |
267 | result))))) | |
268 | ||
269 | (define (things-to-copy) | |
270 | ;; Return the list of store files to copy to the image. | |
271 | (define (graph-from-file file) | |
272 | (call-with-input-file file | |
273 | read-reference-graph)) | |
274 | ||
275 | ,(match inputs-to-copy | |
276 | (((graph-files . _) ...) | |
277 | `(let* ((graph-files ',(map (cut string-append "/xchg/" <>) | |
278 | graph-files)) | |
279 | (paths (append-map graph-from-file graph-files))) | |
280 | (delete-duplicates paths))) | |
281 | (#f ''()))) | |
282 | ||
283 | ;; GRUB is full of shell scripts. | |
284 | (setenv "PATH" | |
285 | (string-append (dirname grub) ":" | |
286 | (assoc-ref %build-inputs "coreutils") "/bin:" | |
287 | (assoc-ref %build-inputs "findutils") "/bin:" | |
288 | (assoc-ref %build-inputs "sed") "/bin:" | |
289 | (assoc-ref %build-inputs "grep") "/bin:" | |
290 | (assoc-ref %build-inputs "gawk") "/bin")) | |
291 | ||
292 | (display "creating partition table...\n") | |
293 | (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" | |
294 | "mkpart" "primary" "ext2" "1MiB" | |
295 | ,(format #f "~aB" | |
296 | (- disk-image-size | |
297 | (* 5 (expt 2 20)))))) | |
298 | (begin | |
299 | (display "creating ext3 partition...\n") | |
300 | (and (zero? (system* mkfs "-F" "/dev/vda1")) | |
301 | (let ((store (string-append "/fs" ,%store-directory))) | |
302 | (display "mounting partition...\n") | |
303 | (mkdir "/fs") | |
304 | (mount "/dev/vda1" "/fs" "ext3") | |
305 | (mkdir-p "/fs/boot/grub") | |
306 | (symlink grub.cfg "/fs/boot/grub/grub.cfg") | |
307 | ||
308 | ;; Populate the image's store. | |
309 | (mkdir-p store) | |
310 | (chmod store #o1775) | |
311 | (for-each (lambda (thing) | |
312 | (copy-recursively thing | |
313 | (string-append "/fs" | |
314 | thing))) | |
033adfe7 | 315 | (things-to-copy)) |
d9f0a237 LC |
316 | |
317 | ;; Populate /dev. | |
318 | (make-essential-device-nodes #:root "/fs") | |
319 | ||
320 | ;; Optionally, register the inputs in the image's store. | |
321 | (let* ((guix (assoc-ref %build-inputs "guix")) | |
322 | (register (string-append guix | |
323 | "/sbin/guix-register"))) | |
324 | ,@(if initialize-store? | |
325 | (match inputs-to-copy | |
326 | (((graph-files . _) ...) | |
327 | (map (lambda (closure) | |
328 | `(system* register "--prefix" "/fs" | |
329 | ,(string-append "/xchg/" | |
330 | closure))) | |
331 | graph-files))) | |
332 | '(#f))) | |
333 | ||
334 | ;; Evaluate the POPULATE directives. | |
335 | ,@(let loop ((directives populate) | |
336 | (statements '())) | |
337 | (match directives | |
338 | (() | |
339 | (reverse statements)) | |
340 | ((('directory name) rest ...) | |
341 | (loop rest | |
342 | (cons `(mkdir-p ,(string-append "/fs" name)) | |
343 | statements))) | |
344 | ((('directory name uid gid) rest ...) | |
345 | (let ((dir (string-append "/fs" name))) | |
346 | (loop rest | |
347 | (cons* `(chown ,dir ,uid ,gid) | |
348 | `(mkdir-p ,dir) | |
349 | statements)))) | |
350 | (((new '-> old) rest ...) | |
351 | (loop rest | |
352 | (cons `(symlink ,old | |
353 | ,(string-append "/fs" new)) | |
354 | statements))))) | |
355 | ||
356 | (and=> (assoc-ref %build-inputs "populate") | |
357 | (lambda (populate) | |
358 | (chdir "/fs") | |
359 | (primitive-load populate) | |
360 | (chdir "/"))) | |
361 | ||
362 | (display "clearing file timestamps...\n") | |
363 | (for-each (lambda (file) | |
364 | (let ((s (lstat file))) | |
365 | ;; XXX: Guile uses libc's 'utime' function | |
366 | ;; (not 'futime'), so the timestamp of | |
367 | ;; symlinks cannot be changed, and there | |
368 | ;; are symlinks here pointing to | |
369 | ;; /nix/store, which is the host, | |
370 | ;; read-only store. | |
371 | (unless (eq? (stat:type s) 'symlink) | |
372 | (utime file 0 0 0 0)))) | |
373 | (find-files "/fs" ".*")) | |
374 | ||
375 | (and (zero? | |
376 | (system* grub "--no-floppy" | |
377 | "--boot-directory" "/fs/boot" | |
378 | "/dev/vda")) | |
379 | (zero? (system* umount "/fs")) | |
380 | (reboot)))))))) | |
381 | #:system system | |
382 | #:inputs `(("parted" ,parted) | |
383 | ("grub" ,grub) | |
384 | ("e2fsprogs" ,e2fsprogs) | |
d9f0a237 LC |
385 | |
386 | ;; For shell scripts. | |
387 | ("sed" ,(car (assoc-ref %final-inputs "sed"))) | |
388 | ("grep" ,(car (assoc-ref %final-inputs "grep"))) | |
389 | ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) | |
390 | ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) | |
391 | ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) | |
392 | ("util-linux" ,util-linux) | |
393 | ||
394 | ,@(if initialize-store? | |
395 | `(("guix" ,guix)) | |
396 | '()) | |
397 | ||
398 | ,@inputs-to-copy) | |
399 | #:make-disk-image? #t | |
400 | #:disk-image-size disk-image-size | |
401 | #:references-graphs graph | |
402 | #:modules '((guix build utils) | |
403 | (guix build linux-initrd))))) | |
04086015 LC |
404 | |
405 | \f | |
406 | ;;; | |
aedb72fb | 407 | ;;; Stand-alone VM image. |
04086015 LC |
408 | ;;; |
409 | ||
033adfe7 LC |
410 | (define %demo-operating-system |
411 | (operating-system | |
412 | (host-name "gnu") | |
413 | (timezone "Europe/Paris") | |
3141a8bd | 414 | (locale "en_US.UTF-8") |
033adfe7 LC |
415 | (users (list (user-account |
416 | (name "guest") | |
417 | (password "") | |
418 | (uid 1000) (gid 100) | |
419 | (comment "Guest of GNU") | |
78ed0038 | 420 | (home-directory "/home/guest")))) |
4f62d8d6 LC |
421 | (packages (list coreutils |
422 | bash | |
423 | guile-2.0 | |
424 | dmd | |
425 | gcc-final | |
426 | ld-wrapper ; must come before BINUTILS | |
427 | binutils-final | |
428 | glibc-final | |
429 | inetutils | |
430 | findutils | |
431 | grep | |
432 | sed | |
433 | procps | |
434 | psmisc | |
435 | zile | |
436 | less | |
3141a8bd | 437 | tzdata |
4f62d8d6 | 438 | guix)))) |
033adfe7 | 439 | |
22dd0438 LC |
440 | (define* (system-qemu-image #:optional (os %demo-operating-system) |
441 | #:key (disk-image-size (* 900 (expt 2 20)))) | |
442 | "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU | |
443 | system as described by OS." | |
0b8a376b | 444 | (mlet* %store-monad |
033adfe7 LC |
445 | ((os-drv (operating-system-derivation os)) |
446 | (os-dir -> (derivation->output-path os-drv)) | |
447 | (grub.cfg -> (string-append os-dir "/grub.cfg")) | |
448 | (build-user-gid (anym %store-monad ; XXX | |
449 | (lambda (service) | |
450 | (and (equal? '(guix-daemon) | |
451 | (service-provision service)) | |
452 | (match (service-user-groups service) | |
453 | ((group) | |
454 | (user-group-id group))))) | |
455 | (operating-system-services os))) | |
d9f0a237 LC |
456 | (populate -> `((directory "/nix/store" 0 ,build-user-gid) |
457 | (directory "/etc") | |
458 | (directory "/var/log") ; for dmd | |
459 | (directory "/var/run/nscd") | |
d9f0a237 | 460 | (directory "/var/nix/gcroots") |
033adfe7 | 461 | ("/var/nix/gcroots/system" -> ,os-dir) |
d9f0a237 LC |
462 | (directory "/tmp") |
463 | (directory "/var/nix/profiles/per-user/root" 0 0) | |
464 | (directory "/var/nix/profiles/per-user/guest" | |
465 | 1000 100) | |
033adfe7 | 466 | (directory "/home/guest" 1000 100)))) |
d9f0a237 LC |
467 | (qemu-image #:grub-configuration grub.cfg |
468 | #:populate populate | |
22dd0438 | 469 | #:disk-image-size disk-image-size |
d9f0a237 | 470 | #:initialize-store? #t |
033adfe7 | 471 | #:inputs-to-copy `(("system" ,os-drv))))) |
04086015 LC |
472 | |
473 | ;;; vm.scm ends here |