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) | |
1b89a66e LC |
24 | #:use-module ((gnu packages base) #:select (%final-inputs |
25 | guile-final | |
26 | coreutils)) | |
27 | #:use-module (gnu packages guile) | |
28 | #:use-module (gnu packages bash) | |
04086015 LC |
29 | #:use-module (gnu packages qemu) |
30 | #:use-module (gnu packages parted) | |
31 | #:use-module (gnu packages grub) | |
32 | #:use-module (gnu packages linux) | |
33 | #:use-module (gnu packages linux-initrd) | |
34 | #:use-module ((gnu packages make-bootstrap) | |
35 | #:select (%guile-static-stripped)) | |
a843fe22 | 36 | #:use-module (gnu packages system) |
0ded70f3 LC |
37 | |
38 | #:use-module (gnu system shadow) | |
39 | #:use-module (gnu system linux) | |
40 | #:use-module (gnu system grub) | |
41 | ||
ca85d7bc | 42 | #:use-module (srfi srfi-1) |
04086015 LC |
43 | #:use-module (srfi srfi-26) |
44 | #:use-module (ice-9 match) | |
0ded70f3 | 45 | |
04086015 | 46 | #:export (expression->derivation-in-linux-vm |
aedb72fb LC |
47 | qemu-image |
48 | system-qemu-image)) | |
04086015 LC |
49 | |
50 | \f | |
51 | ;;; Commentary: | |
52 | ;;; | |
53 | ;;; Tools to evaluate build expressions within virtual machines. | |
54 | ;;; | |
55 | ;;; Code: | |
56 | ||
2455085a | 57 | (define* (expression->derivation-in-linux-vm store name exp |
04086015 | 58 | #:key |
2455085a LC |
59 | (system (%current-system)) |
60 | (inputs '()) | |
04086015 LC |
61 | (linux linux-libre) |
62 | (initrd qemu-initrd) | |
50731c51 | 63 | (qemu qemu/smb-shares) |
04086015 LC |
64 | (env-vars '()) |
65 | (modules '()) | |
66 | (guile-for-build | |
67 | (%guile-for-build)) | |
68 | ||
69 | (make-disk-image? #f) | |
ca85d7bc | 70 | (references-graphs #f) |
04086015 LC |
71 | (disk-image-size |
72 | (* 100 (expt 2 20)))) | |
73 | "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD. In the | |
74 | virtual machine, EXP has access to all of INPUTS from the store; it should put | |
75 | its output files in the `/xchg' directory, which is copied to the derivation's | |
76 | output when the VM terminates. | |
77 | ||
78 | When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of | |
ca85d7bc LC |
79 | DISK-IMAGE-SIZE bytes and return it. |
80 | ||
81 | When REFERENCES-GRAPHS is true, it must be a list of file name/store path | |
82 | pairs, as for `derivation'. The files containing the reference graphs are | |
83 | made available under the /xchg CIFS share." | |
8ab73e91 LC |
84 | ;; FIXME: Allow use of macros from other modules, as done in |
85 | ;; `build-expression->derivation'. | |
86 | ||
04086015 LC |
87 | (define input-alist |
88 | (map (match-lambda | |
4c0f0673 | 89 | ((input (? package? package)) |
04086015 | 90 | `(,input . ,(package-output store package "out" system))) |
4c0f0673 LC |
91 | ((input (? package? package) sub-drv) |
92 | `(,input . ,(package-output store package sub-drv system))) | |
93 | ((input (and (? string?) (? store-path?) file)) | |
94 | `(,input . ,file))) | |
04086015 LC |
95 | inputs)) |
96 | ||
97 | (define exp* | |
98 | ;; EXP, but with INPUTS available. | |
99 | `(let ((%build-inputs ',input-alist)) | |
100 | ,exp)) | |
101 | ||
102 | (define builder | |
103 | ;; Code that launches the VM that evaluates EXP. | |
ca85d7bc LC |
104 | `(let () |
105 | (use-modules (guix build utils) | |
106 | (srfi srfi-1) | |
107 | (ice-9 rdelim)) | |
04086015 LC |
108 | |
109 | (let ((out (assoc-ref %outputs "out")) | |
110 | (cu (string-append (assoc-ref %build-inputs "coreutils") | |
111 | "/bin")) | |
112 | (qemu (string-append (assoc-ref %build-inputs "qemu") | |
113 | "/bin/qemu-system-" | |
114 | (car (string-split ,system #\-)))) | |
115 | (img (string-append (assoc-ref %build-inputs "qemu") | |
116 | "/bin/qemu-img")) | |
117 | (linux (string-append (assoc-ref %build-inputs "linux") | |
118 | "/bzImage")) | |
119 | (initrd (string-append (assoc-ref %build-inputs "initrd") | |
120 | "/initrd")) | |
121 | (builder (assoc-ref %build-inputs "builder"))) | |
122 | ||
123 | ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB | |
124 | ;; directory, so it really needs `rm' in $PATH. | |
125 | (setenv "PATH" cu) | |
126 | ||
127 | ,(if make-disk-image? | |
128 | `(zero? (system* img "create" "image.qcow2" | |
129 | ,(number->string disk-image-size))) | |
130 | '(begin)) | |
131 | ||
132 | (mkdir "xchg") | |
ca85d7bc LC |
133 | |
134 | ;; Copy the reference-graph files under xchg/ so EXP can access it. | |
135 | (begin | |
136 | ,@(match references-graphs | |
137 | (((graph-files . _) ...) | |
138 | (map (lambda (file) | |
139 | `(copy-file ,file | |
140 | ,(string-append "xchg/" file))) | |
141 | graph-files)) | |
142 | (#f '()))) | |
143 | ||
04086015 LC |
144 | (and (zero? |
145 | (system* qemu "-nographic" "-no-reboot" | |
146 | "-net" "nic,model=e1000" | |
147 | "-net" (string-append "user,smb=" (getcwd)) | |
148 | "-kernel" linux | |
149 | "-initrd" initrd | |
150 | "-append" (string-append "console=ttyS0 --load=" | |
151 | builder) | |
152 | ,@(if make-disk-image? | |
153 | '("-hda" "image.qcow2") | |
154 | '()))) | |
155 | ,(if make-disk-image? | |
156 | '(copy-file "image.qcow2" ; XXX: who mkdir'd OUT? | |
157 | out) | |
158 | '(begin | |
159 | (mkdir out) | |
160 | (copy-recursively "xchg" out))))))) | |
161 | ||
162 | (let ((user-builder (add-text-to-store store "builder-in-linux-vm" | |
163 | (object->string exp*) | |
164 | '())) | |
165 | (->drv (cut package-derivation store <> system)) | |
166 | (coreutils (car (assoc-ref %final-inputs "coreutils")))) | |
167 | (build-expression->derivation store name system builder | |
168 | `(("qemu" ,(->drv qemu)) | |
169 | ("linux" ,(->drv linux)) | |
170 | ("initrd" ,(->drv initrd)) | |
171 | ("coreutils" ,(->drv coreutils)) | |
172 | ("builder" ,user-builder) | |
173 | ,@(map (match-lambda | |
4c0f0673 LC |
174 | ((name (? package? package) |
175 | sub-drv ...) | |
04086015 | 176 | `(,name ,(->drv package) |
4c0f0673 LC |
177 | ,@sub-drv)) |
178 | ((name (? string? file)) | |
179 | `(,name ,file))) | |
04086015 LC |
180 | inputs)) |
181 | #:env-vars env-vars | |
ca85d7bc LC |
182 | #:modules (delete-duplicates |
183 | `((guix build utils) | |
184 | ,@modules)) | |
185 | #:guile-for-build guile-for-build | |
186 | #:references-graphs references-graphs))) | |
04086015 LC |
187 | |
188 | (define* (qemu-image store #:key | |
189 | (name "qemu-image") | |
190 | (system (%current-system)) | |
191 | (disk-image-size (* 100 (expt 2 20))) | |
0e2ddecd | 192 | grub-configuration |
785859d3 | 193 | (populate #f) |
93d44bd8 | 194 | (inputs '()) |
002e5ba8 | 195 | (inputs-to-copy '())) |
1b89a66e | 196 | "Return a bootable, stand-alone QEMU image. The returned image is a full |
0e2ddecd LC |
197 | disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its |
198 | configuration file. | |
93d44bd8 LC |
199 | |
200 | INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied | |
785859d3 LC |
201 | into the image being built. |
202 | ||
203 | When POPULATE is true, it must be the store file name of a Guile script to run | |
204 | in the disk image partition once it has been populated with INPUTS-TO-COPY. | |
205 | It can be used to provide additional files, such as /etc files." | |
93d44bd8 LC |
206 | (define input->name+derivation |
207 | (match-lambda | |
208 | ((name (? package? package)) | |
59688fc4 | 209 | `(,name . ,(derivation->output-path |
93d44bd8 LC |
210 | (package-derivation store package system)))) |
211 | ((name (? package? package) sub-drv) | |
59688fc4 | 212 | `(,name . ,(derivation->output-path |
93d44bd8 | 213 | (package-derivation store package system) |
1b89a66e LC |
214 | sub-drv))) |
215 | ((input (and (? string?) (? store-path?) file)) | |
216 | `(,input . ,file)))) | |
93d44bd8 | 217 | |
04086015 | 218 | (expression->derivation-in-linux-vm |
2455085a | 219 | store "qemu-image" |
93d44bd8 LC |
220 | `(let () |
221 | (use-modules (ice-9 rdelim) | |
222 | (srfi srfi-1) | |
7c1d8146 LC |
223 | (guix build utils) |
224 | (guix build linux-initrd)) | |
93d44bd8 LC |
225 | |
226 | (let ((parted (string-append (assoc-ref %build-inputs "parted") | |
227 | "/sbin/parted")) | |
228 | (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs") | |
229 | "/sbin/mkfs.ext3")) | |
230 | (grub (string-append (assoc-ref %build-inputs "grub") | |
231 | "/sbin/grub-install")) | |
232 | (umount (string-append (assoc-ref %build-inputs "util-linux") | |
233 | "/bin/umount")) ; XXX: add to Guile | |
0e2ddecd | 234 | (grub.cfg (assoc-ref %build-inputs "grub.cfg"))) |
93d44bd8 LC |
235 | |
236 | (define (read-reference-graph port) | |
237 | ;; Return a list of store paths from the reference graph at PORT. | |
238 | ;; The data at PORT is the format produced by #:references-graphs. | |
239 | (let loop ((line (read-line port)) | |
240 | (result '())) | |
241 | (cond ((eof-object? line) | |
242 | (delete-duplicates result)) | |
243 | ((string-prefix? "/" line) | |
244 | (loop (read-line port) | |
245 | (cons line result))) | |
246 | (else | |
247 | (loop (read-line port) | |
248 | result))))) | |
249 | ||
250 | (define (things-to-copy) | |
251 | ;; Return the list of store files to copy to the image. | |
252 | (define (graph-from-file file) | |
253 | (call-with-input-file file | |
254 | read-reference-graph)) | |
255 | ||
256 | ,(match inputs-to-copy | |
257 | (((graph-files . _) ...) | |
258 | `(let* ((graph-files ',(map (cut string-append "/xchg/" <>) | |
259 | graph-files)) | |
260 | (paths (append-map graph-from-file graph-files))) | |
261 | (delete-duplicates paths))) | |
262 | (#f ''()))) | |
263 | ||
264 | ;; GRUB is full of shell scripts. | |
265 | (setenv "PATH" | |
266 | (string-append (dirname grub) ":" | |
267 | (assoc-ref %build-inputs "coreutils") "/bin:" | |
268 | (assoc-ref %build-inputs "findutils") "/bin:" | |
269 | (assoc-ref %build-inputs "sed") "/bin:" | |
270 | (assoc-ref %build-inputs "grep") "/bin:" | |
271 | (assoc-ref %build-inputs "gawk") "/bin")) | |
272 | ||
273 | (display "creating partition table...\n") | |
93d44bd8 LC |
274 | (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" |
275 | "mkpart" "primary" "ext2" "1MiB" | |
276 | ,(format #f "~aB" | |
277 | (- disk-image-size | |
278 | (* 5 (expt 2 20)))))) | |
279 | (begin | |
280 | (display "creating ext3 partition...\n") | |
93d44bd8 LC |
281 | (and (zero? (system* mkfs "-F" "/dev/vda1")) |
282 | (begin | |
283 | (display "mounting partition...\n") | |
284 | (mkdir "/fs") | |
285 | (mount "/dev/vda1" "/fs" "ext3") | |
286 | (mkdir-p "/fs/boot/grub") | |
0e2ddecd | 287 | (symlink grub.cfg "/fs/boot/grub/grub.cfg") |
93d44bd8 LC |
288 | |
289 | ;; Populate the image's store. | |
290 | (mkdir-p (string-append "/fs" ,%store-directory)) | |
291 | (for-each (lambda (thing) | |
292 | (copy-recursively thing | |
293 | (string-append "/fs" | |
294 | thing))) | |
0e2ddecd | 295 | (cons grub.cfg (things-to-copy))) |
93d44bd8 | 296 | |
7c1d8146 LC |
297 | ;; Populate /dev. |
298 | (make-essential-device-nodes #:root "/fs") | |
299 | ||
785859d3 LC |
300 | (and=> (assoc-ref %build-inputs "populate") |
301 | (lambda (populate) | |
302 | (chdir "/fs") | |
303 | (primitive-load populate) | |
304 | (chdir "/"))) | |
305 | ||
8ab73e91 LC |
306 | (display "clearing file timestamps...\n") |
307 | (for-each (lambda (file) | |
308 | (let ((s (lstat file))) | |
309 | ;; XXX: Guile uses libc's 'utime' function | |
310 | ;; (not 'futime'), so the timestamp of | |
311 | ;; symlinks cannot be changed, and there | |
312 | ;; are symlinks here pointing to | |
313 | ;; /nix/store, which is the host, | |
314 | ;; read-only store. | |
315 | (unless (eq? (stat:type s) 'symlink) | |
316 | (utime file 0 0 0 0)))) | |
317 | (find-files "/fs" ".*")) | |
318 | ||
93d44bd8 LC |
319 | (and (zero? |
320 | (system* grub "--no-floppy" | |
321 | "--boot-directory" "/fs/boot" | |
322 | "/dev/vda")) | |
0e2ddecd | 323 | (zero? (system* umount "/fs")) |
93d44bd8 | 324 | (reboot)))))))) |
2455085a LC |
325 | #:system system |
326 | #:inputs `(("parted" ,parted) | |
327 | ("grub" ,grub) | |
328 | ("e2fsprogs" ,e2fsprogs) | |
0e2ddecd | 329 | ("grub.cfg" ,grub-configuration) |
93d44bd8 | 330 | |
2455085a LC |
331 | ;; For shell scripts. |
332 | ("sed" ,(car (assoc-ref %final-inputs "sed"))) | |
333 | ("grep" ,(car (assoc-ref %final-inputs "grep"))) | |
334 | ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) | |
335 | ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) | |
336 | ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) | |
93d44bd8 LC |
337 | ("util-linux" ,util-linux) |
338 | ||
785859d3 LC |
339 | ,@(if populate |
340 | `(("populate" ,populate)) | |
341 | '()) | |
342 | ||
93d44bd8 | 343 | ,@inputs-to-copy) |
04086015 | 344 | #:make-disk-image? #t |
93d44bd8 LC |
345 | #:disk-image-size disk-image-size |
346 | #:references-graphs (map input->name+derivation inputs-to-copy) | |
7c1d8146 LC |
347 | #:modules '((guix build utils) |
348 | (guix build linux-initrd)))) | |
04086015 LC |
349 | |
350 | \f | |
351 | ;;; | |
aedb72fb | 352 | ;;; Stand-alone VM image. |
04086015 LC |
353 | ;;; |
354 | ||
aedb72fb LC |
355 | (define (system-qemu-image store) |
356 | "Return the derivation of a QEMU image of the GNU system." | |
357 | (define %pam-services | |
358 | ;; Services known to PAM. | |
359 | (list %pam-other-services | |
360 | (unix-pam-service "login" #:allow-empty-passwords? #t))) | |
361 | ||
362 | (parameterize ((%guile-for-build (package-derivation store guile-final))) | |
363 | (let* ((bash-drv (package-derivation store bash)) | |
59688fc4 | 364 | (bash-file (string-append (derivation->output-path bash-drv) |
aedb72fb LC |
365 | "/bin/bash")) |
366 | (accounts (list (vector "root" "" 0 0 "System administrator" | |
367 | "/" bash-file))) | |
368 | (passwd (passwd-file store accounts)) | |
369 | (shadow (passwd-file store accounts #:shadow? #t)) | |
370 | (pam.d-drv (pam-services->directory store %pam-services)) | |
59688fc4 | 371 | (pam.d (derivation->output-path pam.d-drv)) |
aedb72fb LC |
372 | (populate |
373 | (add-text-to-store store "populate-qemu-image" | |
374 | (object->string | |
375 | `(begin | |
376 | (mkdir-p "etc") | |
377 | (symlink ,shadow "etc/shadow") | |
378 | (symlink ,passwd "etc/passwd") | |
379 | (symlink "/dev/null" | |
380 | "etc/login.defs") | |
381 | (symlink ,pam.d "etc/pam.d") | |
382 | (mkdir-p "var/run"))) | |
383 | (list passwd))) | |
59688fc4 | 384 | (out (derivation->output-path |
aedb72fb LC |
385 | (package-derivation store mingetty))) |
386 | (getty (string-append out "/sbin/mingetty")) | |
387 | (iu-drv (package-derivation store inetutils)) | |
59688fc4 | 388 | (syslogd (string-append (derivation->output-path iu-drv) |
aedb72fb LC |
389 | "/libexec/syslogd")) |
390 | (boot (add-text-to-store store "boot" | |
785859d3 LC |
391 | (object->string |
392 | `(begin | |
aedb72fb LC |
393 | ;; Become the session leader, |
394 | ;; so that mingetty can do | |
395 | ;; 'TIOCSCTTY'. | |
396 | (setsid) | |
397 | ||
398 | (when (zero? (primitive-fork)) | |
399 | (format #t "starting syslogd as ~a~%" | |
400 | (getpid)) | |
401 | (execl ,syslogd "syslogd")) | |
402 | ||
403 | ;; Directly into mingetty. XXX | |
404 | ;; (execl ,getty "mingetty" | |
405 | ;; "--noclear" "tty1") | |
406 | (execl ,bash-file "bash"))) | |
407 | (list out))) | |
408 | (entries (list (menu-entry | |
409 | (label "Boot-to-Guile! (GNU System technology preview)") | |
410 | (linux linux-libre) | |
411 | (linux-arguments `("--root=/dev/vda1" | |
412 | ,(string-append "--load=" boot))) | |
413 | (initrd gnu-system-initrd)))) | |
414 | (grub.cfg (grub-configuration-file store entries))) | |
415 | (build-derivations store (list pam.d-drv)) | |
416 | (qemu-image store | |
417 | #:grub-configuration grub.cfg | |
418 | #:populate populate | |
419 | #:disk-image-size (* 400 (expt 2 20)) | |
420 | #:inputs-to-copy `(("boot" ,boot) | |
421 | ("linux" ,linux-libre) | |
422 | ("initrd" ,gnu-system-initrd) | |
423 | ("coreutils" ,coreutils) | |
424 | ("bash" ,bash) | |
425 | ("guile" ,guile-2.0) | |
426 | ("mingetty" ,mingetty) | |
427 | ("inetutils" ,inetutils) | |
428 | ||
429 | ;; Configuration. | |
430 | ("etc-pam.d" ,pam.d) | |
431 | ("etc-passwd" ,passwd) | |
432 | ("etc-shadow" ,shadow)))))) | |
04086015 LC |
433 | |
434 | ;;; vm.scm ends here |