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 | |
28 | coreutils findutils grep sed)) | |
1b89a66e LC |
29 | #:use-module (gnu packages guile) |
30 | #:use-module (gnu packages bash) | |
04086015 LC |
31 | #:use-module (gnu packages qemu) |
32 | #:use-module (gnu packages parted) | |
5b16ff09 | 33 | #:use-module (gnu packages zile) |
04086015 LC |
34 | #:use-module (gnu packages grub) |
35 | #:use-module (gnu packages linux) | |
36 | #:use-module (gnu packages linux-initrd) | |
30f25b03 | 37 | #:use-module (gnu packages package-management) |
04086015 LC |
38 | #:use-module ((gnu packages make-bootstrap) |
39 | #:select (%guile-static-stripped)) | |
a843fe22 | 40 | #:use-module (gnu packages system) |
0ded70f3 LC |
41 | |
42 | #:use-module (gnu system shadow) | |
43 | #:use-module (gnu system linux) | |
44 | #:use-module (gnu system grub) | |
4646e30a | 45 | #:use-module (gnu system dmd) |
0ded70f3 | 46 | |
ca85d7bc | 47 | #:use-module (srfi srfi-1) |
04086015 LC |
48 | #:use-module (srfi srfi-26) |
49 | #:use-module (ice-9 match) | |
0ded70f3 | 50 | |
04086015 | 51 | #:export (expression->derivation-in-linux-vm |
aedb72fb LC |
52 | qemu-image |
53 | system-qemu-image)) | |
04086015 LC |
54 | |
55 | \f | |
56 | ;;; Commentary: | |
57 | ;;; | |
58 | ;;; Tools to evaluate build expressions within virtual machines. | |
59 | ;;; | |
60 | ;;; Code: | |
61 | ||
0b8a376b LC |
62 | (define (lower-inputs inputs) |
63 | "Turn any package from INPUTS into a derivation; return the corresponding | |
64 | input list as a monadic value." | |
65 | (with-monad %store-monad | |
66 | (sequence %store-monad | |
67 | (map (match-lambda | |
68 | ((name (? package? package) sub-drv ...) | |
69 | (mlet %store-monad ((drv (package->derivation package))) | |
70 | (return `(,name ,drv ,@sub-drv)))) | |
71 | ((name (? string? file)) | |
72 | (return `(,name ,file))) | |
73 | (tuple | |
74 | (return tuple))) | |
75 | inputs)))) | |
76 | ||
d9f0a237 | 77 | (define* (expression->derivation-in-linux-vm name exp |
04086015 | 78 | #:key |
2455085a LC |
79 | (system (%current-system)) |
80 | (inputs '()) | |
04086015 LC |
81 | (linux linux-libre) |
82 | (initrd qemu-initrd) | |
50731c51 | 83 | (qemu qemu/smb-shares) |
04086015 LC |
84 | (env-vars '()) |
85 | (modules '()) | |
86 | (guile-for-build | |
87 | (%guile-for-build)) | |
88 | ||
89 | (make-disk-image? #f) | |
ca85d7bc | 90 | (references-graphs #f) |
04086015 LC |
91 | (disk-image-size |
92 | (* 100 (expt 2 20)))) | |
93 | "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD. In the | |
94 | virtual machine, EXP has access to all of INPUTS from the store; it should put | |
95 | its output files in the `/xchg' directory, which is copied to the derivation's | |
96 | output when the VM terminates. | |
97 | ||
98 | When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of | |
ca85d7bc LC |
99 | DISK-IMAGE-SIZE bytes and return it. |
100 | ||
101 | When REFERENCES-GRAPHS is true, it must be a list of file name/store path | |
102 | pairs, as for `derivation'. The files containing the reference graphs are | |
103 | made available under the /xchg CIFS share." | |
8ab73e91 LC |
104 | ;; FIXME: Allow use of macros from other modules, as done in |
105 | ;; `build-expression->derivation'. | |
106 | ||
04086015 | 107 | (define input-alist |
d9f0a237 LC |
108 | (with-monad %store-monad |
109 | (map (match-lambda | |
110 | ((input (? package? package)) | |
111 | (mlet %store-monad ((out (package-file package #:system system))) | |
112 | (return `(,input . ,out)))) | |
113 | ((input (? package? package) sub-drv) | |
114 | (mlet %store-monad ((out (package-file package | |
115 | #:output sub-drv | |
116 | #:system system))) | |
117 | (return `(,input . ,out)))) | |
118 | ((input (? derivation? drv)) | |
119 | (return `(,input . ,(derivation->output-path drv)))) | |
120 | ((input (? derivation? drv) sub-drv) | |
121 | (return `(,input . ,(derivation->output-path drv sub-drv)))) | |
122 | ((input (and (? string?) (? store-path?) file)) | |
123 | (return `(,input . ,file)))) | |
124 | inputs))) | |
04086015 LC |
125 | |
126 | (define builder | |
127 | ;; Code that launches the VM that evaluates EXP. | |
ca85d7bc LC |
128 | `(let () |
129 | (use-modules (guix build utils) | |
130 | (srfi srfi-1) | |
131 | (ice-9 rdelim)) | |
04086015 LC |
132 | |
133 | (let ((out (assoc-ref %outputs "out")) | |
134 | (cu (string-append (assoc-ref %build-inputs "coreutils") | |
135 | "/bin")) | |
136 | (qemu (string-append (assoc-ref %build-inputs "qemu") | |
137 | "/bin/qemu-system-" | |
138 | (car (string-split ,system #\-)))) | |
139 | (img (string-append (assoc-ref %build-inputs "qemu") | |
140 | "/bin/qemu-img")) | |
141 | (linux (string-append (assoc-ref %build-inputs "linux") | |
142 | "/bzImage")) | |
143 | (initrd (string-append (assoc-ref %build-inputs "initrd") | |
144 | "/initrd")) | |
145 | (builder (assoc-ref %build-inputs "builder"))) | |
146 | ||
147 | ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB | |
148 | ;; directory, so it really needs `rm' in $PATH. | |
149 | (setenv "PATH" cu) | |
150 | ||
151 | ,(if make-disk-image? | |
30e45750 | 152 | `(zero? (system* img "create" "-f" "qcow2" "image.qcow2" |
04086015 LC |
153 | ,(number->string disk-image-size))) |
154 | '(begin)) | |
155 | ||
156 | (mkdir "xchg") | |
ca85d7bc LC |
157 | |
158 | ;; Copy the reference-graph files under xchg/ so EXP can access it. | |
159 | (begin | |
160 | ,@(match references-graphs | |
161 | (((graph-files . _) ...) | |
162 | (map (lambda (file) | |
163 | `(copy-file ,file | |
164 | ,(string-append "xchg/" file))) | |
165 | graph-files)) | |
166 | (#f '()))) | |
167 | ||
04086015 LC |
168 | (and (zero? |
169 | (system* qemu "-nographic" "-no-reboot" | |
170 | "-net" "nic,model=e1000" | |
171 | "-net" (string-append "user,smb=" (getcwd)) | |
172 | "-kernel" linux | |
173 | "-initrd" initrd | |
174 | "-append" (string-append "console=ttyS0 --load=" | |
175 | builder) | |
176 | ,@(if make-disk-image? | |
177 | '("-hda" "image.qcow2") | |
178 | '()))) | |
179 | ,(if make-disk-image? | |
180 | '(copy-file "image.qcow2" ; XXX: who mkdir'd OUT? | |
181 | out) | |
182 | '(begin | |
183 | (mkdir out) | |
184 | (copy-recursively "xchg" out))))))) | |
185 | ||
d9f0a237 LC |
186 | (mlet* %store-monad |
187 | ((input-alist (sequence %store-monad input-alist)) | |
188 | (exp* -> `(let ((%build-inputs ',input-alist)) | |
189 | ,exp)) | |
190 | (user-builder (text-file "builder-in-linux-vm" | |
191 | (object->string exp*))) | |
192 | (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) | |
193 | (inputs (lower-inputs `(("qemu" ,qemu) | |
194 | ("linux" ,linux) | |
195 | ("initrd" ,initrd) | |
196 | ("coreutils" ,coreutils) | |
197 | ("builder" ,user-builder) | |
198 | ,@inputs)))) | |
dd1a5a15 LC |
199 | (derivation-expression name builder |
200 | #:system system | |
201 | #:inputs inputs | |
d9f0a237 LC |
202 | #:env-vars env-vars |
203 | #:modules (delete-duplicates | |
204 | `((guix build utils) | |
205 | ,@modules)) | |
206 | #:guile-for-build guile-for-build | |
207 | #:references-graphs references-graphs))) | |
208 | ||
209 | (define* (qemu-image #:key | |
04086015 LC |
210 | (name "qemu-image") |
211 | (system (%current-system)) | |
212 | (disk-image-size (* 100 (expt 2 20))) | |
0e2ddecd | 213 | grub-configuration |
30f25b03 | 214 | (initialize-store? #f) |
785859d3 | 215 | (populate #f) |
93d44bd8 | 216 | (inputs '()) |
002e5ba8 | 217 | (inputs-to-copy '())) |
1b89a66e | 218 | "Return a bootable, stand-alone QEMU image. The returned image is a full |
0e2ddecd LC |
219 | disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its |
220 | configuration file. | |
93d44bd8 LC |
221 | |
222 | INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied | |
30f25b03 LC |
223 | into the image being built. When INITIALIZE-STORE? is true, initialize the |
224 | store database in the image so that Guix can be used in the image. | |
785859d3 | 225 | |
d5d0f286 LC |
226 | POPULATE is a list of directives stating directories or symlinks to be created |
227 | in the disk image partition. It is evaluated once the image has been | |
228 | populated with INPUTS-TO-COPY. It can be used to provide additional files, | |
229 | such as /etc files." | |
d9f0a237 LC |
230 | (define (input->name+derivation tuple) |
231 | (with-monad %store-monad | |
232 | (match tuple | |
233 | ((name (? package? package)) | |
234 | (mlet %store-monad ((drv (package->derivation package system))) | |
235 | (return `(,name . ,(derivation->output-path drv))))) | |
236 | ((name (? package? package) sub-drv) | |
237 | (mlet %store-monad ((drv (package->derivation package system))) | |
238 | (return `(,name . ,(derivation->output-path drv sub-drv))))) | |
239 | ((name (? derivation? drv)) | |
240 | (return `(,name . ,(derivation->output-path drv)))) | |
241 | ((name (? derivation? drv) sub-drv) | |
242 | (return `(,name . ,(derivation->output-path drv sub-drv)))) | |
243 | ((input (and (? string?) (? store-path?) file)) | |
244 | (return `(,input . ,file)))))) | |
245 | ||
246 | (mlet %store-monad | |
247 | ((graph (sequence %store-monad | |
248 | (map input->name+derivation inputs-to-copy)))) | |
249 | (expression->derivation-in-linux-vm | |
250 | "qemu-image" | |
251 | `(let () | |
252 | (use-modules (ice-9 rdelim) | |
253 | (srfi srfi-1) | |
254 | (guix build utils) | |
255 | (guix build linux-initrd)) | |
256 | ||
257 | (let ((parted (string-append (assoc-ref %build-inputs "parted") | |
258 | "/sbin/parted")) | |
259 | (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs") | |
260 | "/sbin/mkfs.ext3")) | |
261 | (grub (string-append (assoc-ref %build-inputs "grub") | |
262 | "/sbin/grub-install")) | |
263 | (umount (string-append (assoc-ref %build-inputs "util-linux") | |
264 | "/bin/umount")) ; XXX: add to Guile | |
265 | (grub.cfg (assoc-ref %build-inputs "grub.cfg"))) | |
266 | ||
267 | (define (read-reference-graph port) | |
268 | ;; Return a list of store paths from the reference graph at PORT. | |
269 | ;; The data at PORT is the format produced by #:references-graphs. | |
270 | (let loop ((line (read-line port)) | |
271 | (result '())) | |
272 | (cond ((eof-object? line) | |
273 | (delete-duplicates result)) | |
274 | ((string-prefix? "/" line) | |
275 | (loop (read-line port) | |
276 | (cons line result))) | |
277 | (else | |
278 | (loop (read-line port) | |
279 | result))))) | |
280 | ||
281 | (define (things-to-copy) | |
282 | ;; Return the list of store files to copy to the image. | |
283 | (define (graph-from-file file) | |
284 | (call-with-input-file file | |
285 | read-reference-graph)) | |
286 | ||
287 | ,(match inputs-to-copy | |
288 | (((graph-files . _) ...) | |
289 | `(let* ((graph-files ',(map (cut string-append "/xchg/" <>) | |
290 | graph-files)) | |
291 | (paths (append-map graph-from-file graph-files))) | |
292 | (delete-duplicates paths))) | |
293 | (#f ''()))) | |
294 | ||
295 | ;; GRUB is full of shell scripts. | |
296 | (setenv "PATH" | |
297 | (string-append (dirname grub) ":" | |
298 | (assoc-ref %build-inputs "coreutils") "/bin:" | |
299 | (assoc-ref %build-inputs "findutils") "/bin:" | |
300 | (assoc-ref %build-inputs "sed") "/bin:" | |
301 | (assoc-ref %build-inputs "grep") "/bin:" | |
302 | (assoc-ref %build-inputs "gawk") "/bin")) | |
303 | ||
304 | (display "creating partition table...\n") | |
305 | (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" | |
306 | "mkpart" "primary" "ext2" "1MiB" | |
307 | ,(format #f "~aB" | |
308 | (- disk-image-size | |
309 | (* 5 (expt 2 20)))))) | |
310 | (begin | |
311 | (display "creating ext3 partition...\n") | |
312 | (and (zero? (system* mkfs "-F" "/dev/vda1")) | |
313 | (let ((store (string-append "/fs" ,%store-directory))) | |
314 | (display "mounting partition...\n") | |
315 | (mkdir "/fs") | |
316 | (mount "/dev/vda1" "/fs" "ext3") | |
317 | (mkdir-p "/fs/boot/grub") | |
318 | (symlink grub.cfg "/fs/boot/grub/grub.cfg") | |
319 | ||
320 | ;; Populate the image's store. | |
321 | (mkdir-p store) | |
322 | (chmod store #o1775) | |
323 | (for-each (lambda (thing) | |
324 | (copy-recursively thing | |
325 | (string-append "/fs" | |
326 | thing))) | |
327 | (cons grub.cfg (things-to-copy))) | |
328 | ||
329 | ;; Populate /dev. | |
330 | (make-essential-device-nodes #:root "/fs") | |
331 | ||
332 | ;; Optionally, register the inputs in the image's store. | |
333 | (let* ((guix (assoc-ref %build-inputs "guix")) | |
334 | (register (string-append guix | |
335 | "/sbin/guix-register"))) | |
336 | ,@(if initialize-store? | |
337 | (match inputs-to-copy | |
338 | (((graph-files . _) ...) | |
339 | (map (lambda (closure) | |
340 | `(system* register "--prefix" "/fs" | |
341 | ,(string-append "/xchg/" | |
342 | closure))) | |
343 | graph-files))) | |
344 | '(#f))) | |
345 | ||
346 | ;; Evaluate the POPULATE directives. | |
347 | ,@(let loop ((directives populate) | |
348 | (statements '())) | |
349 | (match directives | |
350 | (() | |
351 | (reverse statements)) | |
352 | ((('directory name) rest ...) | |
353 | (loop rest | |
354 | (cons `(mkdir-p ,(string-append "/fs" name)) | |
355 | statements))) | |
356 | ((('directory name uid gid) rest ...) | |
357 | (let ((dir (string-append "/fs" name))) | |
358 | (loop rest | |
359 | (cons* `(chown ,dir ,uid ,gid) | |
360 | `(mkdir-p ,dir) | |
361 | statements)))) | |
362 | (((new '-> old) rest ...) | |
363 | (loop rest | |
364 | (cons `(symlink ,old | |
365 | ,(string-append "/fs" new)) | |
366 | statements))))) | |
367 | ||
368 | (and=> (assoc-ref %build-inputs "populate") | |
369 | (lambda (populate) | |
370 | (chdir "/fs") | |
371 | (primitive-load populate) | |
372 | (chdir "/"))) | |
373 | ||
374 | (display "clearing file timestamps...\n") | |
375 | (for-each (lambda (file) | |
376 | (let ((s (lstat file))) | |
377 | ;; XXX: Guile uses libc's 'utime' function | |
378 | ;; (not 'futime'), so the timestamp of | |
379 | ;; symlinks cannot be changed, and there | |
380 | ;; are symlinks here pointing to | |
381 | ;; /nix/store, which is the host, | |
382 | ;; read-only store. | |
383 | (unless (eq? (stat:type s) 'symlink) | |
384 | (utime file 0 0 0 0)))) | |
385 | (find-files "/fs" ".*")) | |
386 | ||
387 | (and (zero? | |
388 | (system* grub "--no-floppy" | |
389 | "--boot-directory" "/fs/boot" | |
390 | "/dev/vda")) | |
391 | (zero? (system* umount "/fs")) | |
392 | (reboot)))))))) | |
393 | #:system system | |
394 | #:inputs `(("parted" ,parted) | |
395 | ("grub" ,grub) | |
396 | ("e2fsprogs" ,e2fsprogs) | |
397 | ("grub.cfg" ,grub-configuration) | |
398 | ||
399 | ;; For shell scripts. | |
400 | ("sed" ,(car (assoc-ref %final-inputs "sed"))) | |
401 | ("grep" ,(car (assoc-ref %final-inputs "grep"))) | |
402 | ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) | |
403 | ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) | |
404 | ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) | |
405 | ("util-linux" ,util-linux) | |
406 | ||
407 | ,@(if initialize-store? | |
408 | `(("guix" ,guix)) | |
409 | '()) | |
410 | ||
411 | ,@inputs-to-copy) | |
412 | #:make-disk-image? #t | |
413 | #:disk-image-size disk-image-size | |
414 | #:references-graphs graph | |
415 | #:modules '((guix build utils) | |
416 | (guix build linux-initrd))))) | |
04086015 LC |
417 | |
418 | \f | |
419 | ;;; | |
aedb72fb | 420 | ;;; Stand-alone VM image. |
04086015 LC |
421 | ;;; |
422 | ||
d9f0a237 | 423 | (define* (union inputs |
0b86a82d LC |
424 | #:key (guile (%guile-for-build)) (system (%current-system)) |
425 | (name "union")) | |
426 | "Return a derivation that builds the union of INPUTS. INPUTS is a list of | |
427 | input tuples." | |
428 | (define builder | |
d9f0a237 | 429 | '(begin |
0b86a82d LC |
430 | (use-modules (guix build union)) |
431 | ||
432 | (setvbuf (current-output-port) _IOLBF) | |
433 | (setvbuf (current-error-port) _IOLBF) | |
434 | ||
435 | (let ((output (assoc-ref %outputs "out")) | |
436 | (inputs (map cdr %build-inputs))) | |
437 | (format #t "building union `~a' with ~a packages...~%" | |
438 | output (length inputs)) | |
439 | (union-build output inputs)))) | |
440 | ||
d9f0a237 LC |
441 | (mlet %store-monad |
442 | ((inputs (sequence %store-monad | |
443 | (map (match-lambda | |
444 | ((name (? package? p)) | |
445 | (mlet %store-monad | |
446 | ((drv (package->derivation p system))) | |
447 | (return `(,name ,drv)))) | |
448 | ((name (? package? p) output) | |
449 | (mlet %store-monad | |
450 | ((drv (package->derivation p system))) | |
451 | (return `(,name ,drv ,output)))) | |
452 | (x | |
453 | (return x))) | |
454 | inputs)))) | |
dd1a5a15 LC |
455 | (derivation-expression name builder |
456 | #:system system | |
457 | #:inputs inputs | |
d9f0a237 LC |
458 | #:modules '((guix build union)) |
459 | #:guile-for-build guile))) | |
460 | ||
0b8a376b LC |
461 | (define* (file-union files |
462 | #:key (inputs '()) (name "file-union")) | |
463 | "Return a derivation that builds a directory containing all of FILES. Each | |
464 | item in FILES must be a list where the first element is the file name to use | |
465 | in the new directory, and the second element is the target file. | |
466 | ||
467 | The subset of FILES corresponding to plain store files is automatically added | |
468 | as an inputs; additional inputs, such as derivations, are taken from INPUTS." | |
469 | (mlet %store-monad ((inputs (lower-inputs inputs))) | |
f0387dd1 LC |
470 | (let* ((outputs (append-map (match-lambda |
471 | ((_ (? derivation? drv)) | |
472 | (list (derivation->output-path drv))) | |
473 | ((_ (? derivation? drv) sub-drv ...) | |
474 | (map (cut derivation->output-path drv <>) | |
475 | sub-drv)) | |
476 | (_ '())) | |
477 | inputs)) | |
478 | (inputs (append inputs | |
479 | (filter (match-lambda | |
480 | ((_ file) | |
481 | ;; Elements of FILES that are store | |
482 | ;; files and that do not correspond to | |
483 | ;; the output of INPUTS are considered | |
484 | ;; inputs (still here?). | |
485 | (and (direct-store-path? file) | |
486 | (not (member file outputs))))) | |
487 | files)))) | |
0b8a376b LC |
488 | (derivation-expression name |
489 | `(let ((out (assoc-ref %outputs "out"))) | |
490 | (mkdir out) | |
491 | (chdir out) | |
492 | ,@(map (match-lambda | |
493 | ((name target) | |
494 | `(symlink ,target ,name))) | |
495 | files)) | |
496 | ||
497 | #:inputs inputs)))) | |
498 | ||
499 | (define* (etc-directory #:key | |
500 | (accounts '()) | |
501 | (groups '()) | |
502 | (pam-services '()) | |
503 | (profile "/var/run/current-system/profile")) | |
504 | "Return a derivation that builds the static part of the /etc directory." | |
d9f0a237 | 505 | (mlet* %store-monad |
0b8a376b LC |
506 | ((services (package-file net-base "etc/services")) |
507 | (protocols (package-file net-base "etc/protocols")) | |
508 | (rpc (package-file net-base "etc/rpc")) | |
509 | (passwd (passwd-file accounts)) | |
510 | (shadow (passwd-file accounts #:shadow? #t)) | |
511 | (group (group-file groups)) | |
512 | (pam.d (pam-services->directory pam-services)) | |
513 | (login.defs (text-file "login.defs" "# Empty for now.\n")) | |
514 | (issue (text-file "issue" " | |
515 | This is an alpha preview of the GNU system. Welcome. | |
43a27798 | 516 | |
0b8a376b LC |
517 | This image features the GNU Guix package manager, which was used to |
518 | build it (http://www.gnu.org/software/guix/). The init system is | |
519 | GNU dmd (http://www.gnu.org/software/dmd/). | |
520 | ||
521 | You can log in as 'guest' or 'root' with no password. | |
43a27798 LC |
522 | ")) |
523 | ||
0b8a376b LC |
524 | ;; TODO: Generate bashrc from packages' search-paths. |
525 | (bashrc (text-file "bashrc" (string-append " | |
526 | export PS1='\\u@\\h\\$ ' | |
527 | export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin | |
528 | export CPATH=$HOME/.guix-profile/include:" profile "/include | |
529 | export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib | |
530 | alias ls='ls -p --color' | |
531 | alias ll='ls -l' | |
532 | "))) | |
0b8a376b LC |
533 | |
534 | (files -> `(("services" ,services) | |
535 | ("protocols" ,protocols) | |
536 | ("rpc" ,rpc) | |
537 | ("pam.d" ,(derivation->output-path pam.d)) | |
538 | ("login.defs" ,login.defs) | |
539 | ("issue" ,issue) | |
540 | ("profile" ,bashrc) | |
541 | ("passwd" ,passwd) | |
542 | ("shadow" ,shadow) | |
a348b09e | 543 | ("group" ,group)))) |
0b8a376b LC |
544 | (file-union files |
545 | #:inputs `(("net" ,net-base) | |
546 | ("pam.d" ,pam.d)) | |
547 | #:name "etc"))) | |
548 | ||
549 | (define (system-qemu-image) | |
550 | "Return the derivation of a QEMU image of the GNU system." | |
0b8a376b LC |
551 | (mlet* %store-monad |
552 | ((services (listm %store-monad | |
d9f0a237 LC |
553 | (host-name-service "gnu") |
554 | (mingetty-service "tty1") | |
555 | (mingetty-service "tty2") | |
556 | (mingetty-service "tty3") | |
557 | (mingetty-service "tty4") | |
558 | (mingetty-service "tty5") | |
559 | (mingetty-service "tty6") | |
560 | (syslog-service) | |
561 | (guix-service) | |
562 | (nscd-service) | |
563 | ||
564 | ;; QEMU networking settings. | |
565 | (static-networking-service "eth0" "10.0.2.10" | |
a348b09e | 566 | #:name-servers '("10.0.2.3") |
d9f0a237 | 567 | #:gateway "10.0.2.2"))) |
0b8a376b LC |
568 | (motd (text-file "motd" " |
569 | Happy birthday, GNU! http://www.gnu.org/gnu30 | |
d9f0a237 | 570 | |
0b8a376b LC |
571 | ")) |
572 | (pam-services -> | |
573 | ;; Services known to PAM. | |
f7d6fafa LC |
574 | (delete-duplicates |
575 | (cons %pam-other-services | |
576 | (append-map service-pam-services services)))) | |
d9f0a237 | 577 | |
d9f0a237 LC |
578 | (bash-file (package-file bash "bin/bash")) |
579 | (dmd-file (package-file dmd "bin/dmd")) | |
d9f0a237 LC |
580 | (accounts -> (cons* (user-account |
581 | (name "root") | |
582 | (password "") | |
583 | (uid 0) (gid 0) | |
584 | (comment "System administrator") | |
585 | (home-directory "/") | |
586 | (shell bash-file)) | |
587 | (user-account | |
588 | (name "guest") | |
589 | (password "") | |
590 | (uid 1000) (gid 100) | |
591 | (comment "Guest of GNU") | |
592 | (home-directory "/home/guest") | |
593 | (shell bash-file)) | |
18fb40e4 LC |
594 | (append-map service-user-accounts |
595 | services))) | |
596 | (groups -> (cons* (user-group | |
597 | (name "root") | |
598 | (id 0)) | |
599 | (user-group | |
600 | (name "users") | |
601 | (id 100) | |
602 | (members '("guest"))) | |
603 | (append-map service-user-groups services))) | |
604 | (build-user-gid -> (any (lambda (service) | |
605 | (and (equal? '(guix-daemon) | |
606 | (service-provision service)) | |
607 | (match (service-user-groups service) | |
608 | ((group) | |
609 | (user-group-id group))))) | |
610 | services)) | |
d9f0a237 LC |
611 | (packages -> `(("coreutils" ,coreutils) |
612 | ("bash" ,bash) | |
613 | ("guile" ,guile-2.0) | |
614 | ("dmd" ,dmd) | |
615 | ("gcc" ,gcc-final) | |
616 | ("libc" ,glibc-final) | |
617 | ("inetutils" ,inetutils) | |
618 | ("findutils" ,findutils) | |
619 | ("grep" ,grep) | |
620 | ("sed" ,sed) | |
621 | ("procps" ,procps) | |
622 | ("psmisc" ,psmisc) | |
623 | ("zile" ,zile) | |
624 | ("guix" ,guix))) | |
625 | ||
626 | ;; TODO: Replace with a real profile with a manifest. | |
d9f0a237 LC |
627 | (profile-drv (union packages |
628 | #:name "default-profile")) | |
629 | (profile -> (derivation->output-path profile-drv)) | |
0b8a376b LC |
630 | (etc-drv (etc-directory #:accounts accounts #:groups groups |
631 | #:pam-services pam-services | |
632 | #:profile profile)) | |
633 | (etc -> (derivation->output-path etc-drv)) | |
9b0ac802 | 634 | (dmd-conf (dmd-configuration-file services etc)) |
0b86a82d | 635 | |
43a27798 | 636 | |
d9f0a237 LC |
637 | (populate -> `((directory "/nix/store" 0 ,build-user-gid) |
638 | (directory "/etc") | |
639 | (directory "/var/log") ; for dmd | |
640 | (directory "/var/run/nscd") | |
d9f0a237 LC |
641 | (directory "/var/nix/gcroots") |
642 | ("/var/nix/gcroots/default-profile" -> ,profile) | |
643 | (directory "/tmp") | |
644 | (directory "/var/nix/profiles/per-user/root" 0 0) | |
645 | (directory "/var/nix/profiles/per-user/guest" | |
646 | 1000 100) | |
647 | (directory "/home/guest" 1000 100))) | |
648 | (boot (text-file "boot" (object->string | |
649 | `(execl ,dmd-file "dmd" | |
650 | "--config" ,dmd-conf)))) | |
651 | (entries -> (list (return (menu-entry | |
652 | (label (string-append | |
653 | "GNU system with Linux-Libre " | |
654 | (package-version linux-libre) | |
655 | " (technology preview)")) | |
656 | (linux linux-libre) | |
657 | (linux-arguments `("--root=/dev/vda1" | |
658 | ,(string-append "--load=" boot))) | |
659 | (initrd gnu-system-initrd))))) | |
660 | (grub.cfg (grub-configuration-file entries))) | |
661 | (qemu-image #:grub-configuration grub.cfg | |
662 | #:populate populate | |
663 | #:disk-image-size (* 550 (expt 2 20)) | |
664 | #:initialize-store? #t | |
665 | #:inputs-to-copy `(("boot" ,boot) | |
666 | ("linux" ,linux-libre) | |
667 | ("initrd" ,gnu-system-initrd) | |
d9f0a237 | 668 | ("dmd.conf" ,dmd-conf) |
0b8a376b LC |
669 | ("profile" ,profile-drv) |
670 | ("etc" ,etc-drv) | |
d9f0a237 LC |
671 | ,@(append-map service-inputs |
672 | services))))) | |
04086015 LC |
673 | |
674 | ;;; vm.scm ends here |