1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
6 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
8 ;;; This file is part of GNU Guix.
10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
11 ;;; under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or (at
13 ;;; your option) any later version.
15 ;;; GNU Guix is distributed in the hope that it will be useful, but
16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
23 (define-module (gnu build vm)
24 #:use-module (guix build utils)
25 #:use-module (guix build store-copy)
26 #:use-module (guix build syscalls)
27 #:use-module (gnu build linux-boot)
28 #:use-module (gnu build install)
29 #:use-module (gnu build file-systems)
30 #:use-module (guix records)
31 #:use-module ((guix combinators) #:select (fold2))
32 #:use-module (ice-9 format)
33 #:use-module (ice-9 match)
34 #:use-module (ice-9 regex)
35 #:use-module (srfi srfi-1)
36 #:use-module (srfi srfi-9)
37 #:use-module (srfi srfi-26)
38 #:export (qemu-command
51 estimated-partition-size
52 root-partition-initializer
53 initialize-partition-table
59 ;;; This module provides supporting code to run virtual machines and build
60 ;;; virtual machine images using QEMU.
64 (define* (qemu-command #:optional (system %host-type))
65 "Return the default name of the QEMU command for SYSTEM."
66 (let ((cpu (substring system 0
67 (string-index system #\-))))
68 (string-append "qemu-system-"
69 (if (string-match "^i[3456]86$" cpu)
73 (define* (load-in-linux-vm builder
76 (qemu (qemu-command)) (memory-size 512)
80 (disk-image-size (* 100 (expt 2 20)))
81 (disk-image-format "qcow2")
82 (references-graphs '()))
83 "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
84 the result to OUTPUT. If SINGLE-FILE-OUTPUT? is true, copy a single file from
85 /xchg to OUTPUT. Otherwise, copy the contents of /xchg to a new directory
88 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
89 DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
90 access it via /dev/hda.
92 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
93 the #:references-graphs parameter of 'derivation'."
94 (when make-disk-image?
95 (format #t "creating ~a image of ~,2f MiB...~%"
96 disk-image-format (/ disk-image-size (expt 2 20)))
98 (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
100 (number->string disk-image-size)))
101 (error "qemu-img failed")))
105 (match references-graphs
107 ;; Copy the reference-graph files under xchg/ so EXP can access it.
109 (copy-file file (string-append "xchg/" file)))
114 (apply system* qemu "-nographic" "-no-reboot"
115 "-m" (number->string memory-size)
116 "-net" "nic,model=virtio"
118 (string-append "local,id=store_dev,path="
120 ",security_model=none,mount_tag=store")
122 (string-append "local,id=xchg_dev,path=xchg"
123 ",security_model=none,mount_tag=xchg")
126 "-append" (string-append "console=ttyS0 --load="
130 `("-drive" ,(string-append "file=" output
133 ;; Only enable kvm if we see /dev/kvm exists.
134 ;; This allows users without hardware virtualization to still
135 ;; use these commands.
136 (if (file-exists? "/dev/kvm")
139 (error "qemu failed" qemu))
141 ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
142 (unless make-disk-image?
143 (if single-file-output?
144 (let ((graph? (lambda (name stat)
145 (member (basename name) references-graphs))))
146 (match (find-files "xchg" (negate graph?))
148 (copy-file result output))
150 (error "did not find a single result file" x))))
153 (copy-recursively "xchg" output)))))
160 (define-record-type* <partition> partition make-partition
162 (device partition-device (default #f))
163 (size partition-size)
164 (file-system partition-file-system (default "ext4"))
165 (label partition-label (default #f))
166 (flags partition-flags (default '()))
167 (initializer partition-initializer (default (const #t))))
169 (define (estimated-partition-size graphs)
170 "Return the estimated size of a partition that can store the store items
171 given by GRAPHS, a list of file names produced by #:references-graphs."
172 ;; Simply add a 25% overhead.
173 (round (* 1.25 (closure-size graphs))))
175 (define* (initialize-partition-table device partitions
178 (offset (expt 2 20)))
179 "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
180 PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On
181 success, return PARTITIONS with their 'device' field changed to reflect their
182 actual /dev name based on DEVICE."
183 (define (partition-options part offset index)
184 (cons* "mkpart" "primary" "ext2"
185 (format #f "~aB" offset)
186 (format #f "~aB" (+ offset (partition-size part)))
187 (append-map (lambda (flag)
188 (list "set" (number->string index)
189 (symbol->string flag) "on"))
190 (partition-flags part))))
192 (define (options partitions offset)
193 (let loop ((partitions partitions)
199 (concatenate (reverse result)))
202 ;; Leave one sector (512B) between partitions to placate
204 (+ offset 512 (partition-size head))
206 (cons (partition-options head offset index)
209 (format #t "creating partition table with ~a partitions (~a)...\n"
211 (string-join (map (compose (cut string-append <> " MiB")
214 (round (/ size (expt 2. 20))))
218 (unless (zero? (apply system* "parted" "--script"
219 device "mklabel" label-type
220 (options partitions offset)))
221 (error "failed to create partition table"))
223 ;; Set the 'device' field of each partition.
225 (fold2 (lambda (part result index)
226 (values (cons (partition
228 (device (string-append device
229 (number->string index))))
236 (define MS_BIND 4096) ; <sys/mounts.h> again!
238 (define* (create-ext-file-system partition type
240 "Create an ext-family filesystem of TYPE on PARTITION. If LABEL is true,
241 use that as the volume name."
242 (format #t "creating ~a partition...\n" type)
243 (unless (zero? (apply system* (string-append "mkfs." type)
248 (error "failed to create partition")))
250 (define* (create-fat-file-system partition
252 "Create a FAT filesystem on PARTITION. The number of File Allocation Tables
253 will be determined based on filesystem size. If LABEL is true, use that as the
255 (format #t "creating FAT partition...\n")
256 (unless (zero? (apply system* "mkfs.fat" partition
260 (error "failed to create FAT partition")))
262 (define* (format-partition partition type
264 "Create a file system TYPE on PARTITION. If LABEL is true, use that as the
266 (cond ((string-prefix? "ext" type)
267 (create-ext-file-system partition type #:label label))
268 ((or (string-prefix? "fat" type) (string= "vfat" type))
269 (create-fat-file-system partition #:label label))
270 (else (error "Unsupported file system."))))
272 (define (initialize-partition partition)
273 "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
274 it, run its initializer, and unmount it."
275 (let ((target "/fs"))
276 (format-partition (partition-device partition)
277 (partition-file-system partition)
278 #:label (partition-label partition))
280 (mount (partition-device partition) target
281 (partition-file-system partition))
283 ((partition-initializer partition) target)
288 (define* (root-partition-initializer #:key (closures '())
290 (register-closures? #t)
292 "Return a procedure to initialize a root partition.
294 If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's
295 store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
296 SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
299 (string-append target (%store-directory)))
302 ;; Populate the store.
303 (populate-store (map (cut string-append "/xchg/" <>) closures)
307 (make-essential-device-nodes #:root target)
309 ;; Optionally, register the inputs in the image's store.
310 (when register-closures?
311 (unless copy-closures?
312 ;; XXX: 'guix-register' wants to palpate the things it registers, so
313 ;; bind-mount the store on the target.
314 (mkdir-p target-store)
315 (mount (%store-directory) target-store "" MS_BIND))
317 (display "registering closures...\n")
318 (for-each (lambda (closure)
319 (register-closure target
320 (string-append "/xchg/" closure)))
322 (unless copy-closures?
323 (umount target-store)))
325 ;; Add the non-store directories and files.
326 (display "populating...\n")
327 (populate-root-file-system system-directory target)
329 ;; 'guix-register' resets timestamps and everything, so no need to do it
330 ;; once more in that case.
331 (unless register-closures?
332 (reset-timestamps target))))
334 (define (register-bootcfg-root target bootcfg)
335 "On file system TARGET, register BOOTCFG as a GC root."
336 (let ((directory (string-append target "/var/guix/gcroots")))
338 (symlink bootcfg (string-append directory "/bootcfg"))))
340 (define (install-efi grub esp config-file)
341 "Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
342 (let* ((system %host-type)
343 ;; Hard code the output location to a well-known path recognized by
344 ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
345 ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
346 (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
347 (efi-directory (string-append esp "/EFI/BOOT"))
348 ;; Map grub target names to boot file names.
349 (efi-targets (cond ((string-prefix? "x86_64" system)
350 '("x86_64-efi" . "BOOTX64.EFI"))
351 ((string-prefix? "i686" system)
352 '("i386-efi" . "BOOTIA32.EFI"))
353 ((string-prefix? "armhf" system)
354 '("arm-efi" . "BOOTARM.EFI"))
355 ((string-prefix? "aarch64" system)
356 '("arm64-efi" . "BOOTAA64.EFI")))))
357 ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
358 (setenv "TMPDIR" esp)
360 (mkdir-p efi-directory)
361 (unless (zero? (system* grub-mkstandalone "-O" (car efi-targets)
362 "-o" (string-append efi-directory "/"
364 ;; Graft the configuration file onto the image.
365 (string-append "boot/grub/grub.cfg=" config-file)))
366 (error "failed to create GRUB EFI image"))))
368 (define* (make-iso9660-image grub config-file os-drv target
369 #:key (volume-id "GuixSD_image") (volume-uuid #f))
370 "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
371 GRUB configuration and OS-DRV as the stuff in it."
372 (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue")))
373 (mkdir-p "/tmp/root/var/run")
374 (mkdir-p "/tmp/root/run")
375 (unless (zero? (apply system*
376 `(,grub-mkrescue "-o" ,target
377 ,(string-append "boot/grub/grub.cfg=" config-file)
378 ,(string-append "gnu/store=" os-drv "/..")
382 ;; Store two copies of the headers.
383 ;; The resulting ISO-9660 image has a DOS MBR and
384 ;; one protective partition (with type 0xCD).
385 ;; Because GuixSD only uses actual partitions
386 ;; rather than what /proc/partitions returns, work
387 ;; around it by storing the primary volume
388 ;; descriptor twice, once where it should be and
389 ;; once in the partition.
390 ;; Allegedly, otherwise, many other GNU tools
391 ;; (automounters etc) would also be confused by
392 ;; the extra partition so it makes sense to
393 ;; store two copies in any case.
394 "-boot_image" "any" "partition_offset=16"
395 "-volid" ,(string-upcase volume-id)
397 `("-volume_date" "uuid"
398 ,(string-filter (lambda (value)
399 (not (char=? #\- value)))
400 (iso9660-uuid->string
403 (error "failed to create ISO9660 image"))))
405 (define* (initialize-hard-disk device
413 "Initialize DEVICE as a disk containing all the <partition> objects listed
414 in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
416 Each partition is initialized by calling its 'initializer' procedure,
417 passing it a directory name where it is mounted."
419 (define (partition-bootable? partition)
420 "Return the first partition found with the boot flag set."
421 (member 'boot (partition-flags partition)))
423 (define (partition-esp? partition)
424 "Return the first EFI System Partition."
425 (member 'esp (partition-flags partition)))
427 (let* ((partitions (initialize-partition-table device partitions))
428 (root (find partition-bootable? partitions))
429 (esp (find partition-esp? partitions))
432 (error "no bootable partition specified" partitions))
434 (for-each initialize-partition partitions)
436 (display "mounting root partition...\n")
438 (mount (partition-device root) target (partition-file-system root))
439 (install-boot-config bootcfg bootcfg-location target)
440 (when bootloader-installer
441 (display "installing bootloader...\n")
442 (bootloader-installer bootloader-package device target))
445 ;; Mount the ESP somewhere and install GRUB UEFI image.
446 (let ((mount-point (string-append target "/boot/efi"))
447 (grub-config (string-append target "/tmp/grub-standalone.cfg")))
448 (display "mounting EFI system partition...\n")
449 (mkdir-p mount-point)
450 (mount (partition-device esp) mount-point
451 (partition-file-system esp))
453 ;; Create a tiny configuration file telling the embedded grub
454 ;; where to load the real thing.
455 ;; XXX This is quite fragile, and can prevent the image from booting
456 ;; when there's more than one volume with this label present.
457 ;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
458 (call-with-output-file grub-config
462 search --set=root --label GuixSD_image~@
463 configfile /boot/grub/grub.cfg~%")))
465 (display "creating EFI firmware image...")
466 (install-efi grub-efi mount-point grub-config)
469 (delete-file grub-config)
470 (umount mount-point)))
472 ;; Register BOOTCFG as a GC root.
473 (register-bootcfg-root target bootcfg)