1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
6 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
7 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
8 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
10 ;;; This file is part of GNU Guix.
12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
13 ;;; under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 3 of the License, or (at
15 ;;; your option) any later version.
17 ;;; GNU Guix is distributed in the hope that it will be useful, but
18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
25 (define-module (gnu build vm)
26 #:use-module (guix build utils)
27 #:use-module (guix build store-copy)
28 #:use-module (guix build syscalls)
29 #:use-module (guix store database)
30 #:use-module (gnu build bootloader)
31 #:use-module (gnu build linux-boot)
32 #:use-module (gnu build install)
33 #:use-module (gnu system uuid)
34 #:use-module (guix records)
35 #:use-module ((guix combinators) #:select (fold2))
36 #:use-module (ice-9 format)
37 #:use-module (ice-9 ftw)
38 #:use-module (ice-9 match)
39 #:use-module (ice-9 regex)
40 #:use-module (ice-9 popen)
41 #:use-module (srfi srfi-1)
42 #:use-module (srfi srfi-9)
43 #:use-module (srfi srfi-19)
44 #:use-module (srfi srfi-26)
45 #:export (qemu-command
58 estimated-partition-size
59 root-partition-initializer
60 initialize-partition-table
61 initialize-hard-disk))
65 ;;; This module provides supporting code to run virtual machines and build
66 ;;; virtual machine images using QEMU.
70 (define* (qemu-command #:optional (system %host-type))
71 "Return the default name of the QEMU command for SYSTEM."
72 (let ((cpu (substring system 0
73 (string-index system #\-))))
74 (string-append "qemu-system-"
76 ((string-match "^i[3456]86$" cpu) "i386")
77 ((string-match "armhf" cpu) "arm")
80 (define* (load-in-linux-vm builder
83 (qemu (qemu-command)) (memory-size 512)
89 (disk-image-size (* 100 (expt 2 20)))
90 (disk-image-format "qcow2")
91 (references-graphs '()))
92 "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
93 the result to OUTPUT. If SINGLE-FILE-OUTPUT? is true, copy a single file from
94 /xchg to OUTPUT. Otherwise, copy the contents of /xchg to a new directory
97 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
98 DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
99 access it via /dev/hda.
101 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
102 the #:references-graphs parameter of 'derivation'."
104 (define target-arm? (or target-arm32? target-aarch64?))
106 (define arch-specific-flags
107 `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
108 ;; hardware limits imposed by other machines.
113 ;; On ARM32, if the kernel is built without LPAE support, ECAM conflicts
114 ;; with VIRT_PCIE_MMIO causing PCI devices not to show up. Disable
115 ;; explicitely highmem to fix it.
116 ;; See: https://bugs.launchpad.net/qemu/+bug/1790975.
118 '("-machine" "highmem=off")
121 ;; Only enable kvm if we see /dev/kvm exists. This allows users without
122 ;; hardware virtualization to still use these commands. KVM support is
123 ;; still buggy on some ARM boards. Do not use it even if available.
124 ,@(if (and (file-exists? "/dev/kvm")
129 ;; Pass "panic=1" so that the guest dies upon error.
131 ,(string-append "panic=1 --load=" builder
133 ;; The serial port name differs between emulated
134 ;; architectures/machines.
136 (if target-arm? "ttyAMA0" "ttyS0"))))
138 (when make-disk-image?
139 (format #t "creating ~a image of ~,2f MiB...~%"
140 disk-image-format (/ disk-image-size (expt 2 20)))
142 (invoke "qemu-img" "create" "-f" disk-image-format output
143 (number->string disk-image-size)))
148 (match references-graphs
150 ;; Copy the reference-graph files under xchg/ so EXP can access it.
152 (copy-file file (string-append "xchg/" file)))
156 (apply invoke qemu "-nographic" "-no-reboot"
157 ;; CPU "max" behaves as "host" when KVM is enabled, and like a system
158 ;; CPU with the maximum possible feature set otherwise.
160 "-m" (number->string memory-size)
161 "-nic" "user,model=virtio-net-pci"
162 "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
163 "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
165 (string-append "local,id=store_dev,path="
167 ",security_model=none,mount_tag=store")
169 (string-append "local,id=xchg_dev,path=xchg"
170 ",security_model=none,mount_tag=xchg")
172 ;; Some programs require more space in /tmp than is normally
173 ;; available in the guest. Accommodate such programs by sharing a
174 ;; temporary directory.
175 (string-append "local,id=tmp_dev,path=tmp"
176 ",security_model=none,mount_tag=tmp")
181 `("-device" "virtio-blk,drive=myhd"
182 "-drive" ,(string-append "if=none,file=" output
183 ",format=" disk-image-format
186 arch-specific-flags))
188 (unless (file-exists? "xchg/.exit-status")
189 (error "VM did not produce an exit code"))
191 (match (call-with-input-file "xchg/.exit-status" read)
193 (status (error "guest VM code exited with a non-zero status" status)))
195 (delete-file "xchg/.exit-status")
197 ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
198 (unless make-disk-image?
199 (if single-file-output?
200 (let ((graph? (lambda (name stat)
201 (member (basename name) references-graphs))))
202 (match (find-files "xchg" (negate graph?))
204 (copy-file result output))
206 (error "did not find a single result file" x))))
209 (copy-recursively "xchg" output)))))
211 (define* (register-closure prefix closure
213 (deduplicate? #t) (reset-timestamps? #t)
214 (schema (sql-schema)))
215 "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
216 target store and CLOSURE is the name of a file containing a reference graph as
217 produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
218 true, reset timestamps on store files and, if DEDUPLICATE? is true,
219 deduplicates files common to CLOSURE and the rest of PREFIX."
220 (let ((items (call-with-input-file closure read-reference-graph)))
221 (register-items items
223 #:deduplicate? deduplicate?
224 #:reset-timestamps? reset-timestamps?
225 #:registration-time %epoch
233 (define-record-type* <partition> partition make-partition
235 (device partition-device (default #f))
236 (size partition-size)
237 (file-system partition-file-system (default "ext4"))
238 (file-system-options partition-file-system-options ;passed to 'mkfs.FS'
240 (label partition-label (default #f))
241 (uuid partition-uuid (default #f))
242 (flags partition-flags (default '()))
243 (initializer partition-initializer (default (const #t))))
245 (define (estimated-partition-size graphs)
246 "Return the estimated size of a partition that can store the store items
247 given by GRAPHS, a list of file names produced by #:references-graphs."
248 ;; Simply add a 25% overhead.
249 (round (* 1.25 (closure-size graphs))))
251 (define* (initialize-partition-table device partitions
254 (offset (expt 2 20)))
255 "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
256 PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On
257 success, return PARTITIONS with their 'device' field changed to reflect their
258 actual /dev name based on DEVICE."
259 (define (partition-options part offset index)
260 (cons* "mkpart" "primary" "ext2"
261 (format #f "~aB" offset)
262 (format #f "~aB" (+ offset (partition-size part)))
263 (append-map (lambda (flag)
264 (list "set" (number->string index)
265 (symbol->string flag) "on"))
266 (partition-flags part))))
268 (define (options partitions offset)
269 (let loop ((partitions partitions)
275 (concatenate (reverse result)))
278 ;; Leave one sector (512B) between partitions to placate
280 (+ offset 512 (partition-size head))
282 (cons (partition-options head offset index)
285 (format #t "creating partition table with ~a partitions (~a)...\n"
287 (string-join (map (compose (cut string-append <> " MiB")
290 (round (/ size (expt 2. 20))))
294 (apply invoke "parted" "--script"
295 device "mklabel" label-type
296 (options partitions offset))
298 ;; Set the 'device' field of each partition.
300 (fold2 (lambda (part result index)
301 (values (cons (partition
303 (device (string-append device
304 (number->string index))))
311 (define MS_BIND 4096) ; <sys/mounts.h> again!
313 (define* (create-ext-file-system partition type
314 #:key label uuid (options '()))
315 "Create an ext-family file system of TYPE on PARTITION. If LABEL is true,
316 use that as the volume name. If UUID is true, use it as the partition UUID."
317 (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
318 type label (and uuid (uuid->string uuid)))
319 (apply invoke (string-append "mkfs." type)
325 `("-U" ,(uuid->string uuid))
329 (define* (create-fat-file-system partition
330 #:key label uuid (options '()))
331 "Create a FAT file system on PARTITION. The number of File Allocation Tables
332 will be determined based on file system size. If LABEL is true, use that as the
334 ;; FIXME: UUID is ignored!
335 (format #t "creating FAT partition...\n")
336 (apply invoke "mkfs.fat" partition
337 (append (if label `("-n" ,label) '()) options)))
339 (define* (format-partition partition type
340 #:key label uuid (options '()))
341 "Create a file system TYPE on PARTITION. If LABEL is true, use that as the
342 volume name. Options is a list of command-line options passed to 'mkfs.FS'."
343 (cond ((string-prefix? "ext" type)
344 (create-ext-file-system partition type #:label label #:uuid uuid
346 ((or (string-prefix? "fat" type) (string= "vfat" type))
347 (create-fat-file-system partition #:label label #:uuid uuid
349 (else (error "Unsupported file system."))))
351 (define (initialize-partition partition)
352 "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
353 it, run its initializer, and unmount it."
354 (let ((target "/fs"))
355 (format-partition (partition-device partition)
356 (partition-file-system partition)
357 #:label (partition-label partition)
358 #:uuid (partition-uuid partition)
359 #:options (partition-file-system-options partition))
361 (mount (partition-device partition) target
362 (partition-file-system partition))
364 ((partition-initializer partition) target)
369 (define* (root-partition-initializer #:key (closures '())
371 (register-closures? #t)
375 make-essential-device-nodes)
376 (extra-directives '()))
377 "Return a procedure to initialize a root partition.
379 If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
380 store. If DEDUPLICATE? is true, then also deduplicate files common to
381 CLOSURES and the rest of the store when registering the closures. If
382 COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
383 SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation.
385 EXTRA-DIRECTIVES is an optional list of directives to populate the root file
386 system that is passed to 'populate-root-file-system'."
389 (string-append target (%store-directory)))
392 ;; Populate the store.
393 (populate-store (map (cut string-append "/xchg/" <>) closures)
397 (make-device-nodes target)
399 ;; Optionally, register the inputs in the image's store.
400 (when register-closures?
401 (unless copy-closures?
402 ;; XXX: 'register-closure' wants to palpate the things it registers, so
403 ;; bind-mount the store on the target.
404 (mkdir-p target-store)
405 (mount (%store-directory) target-store "" MS_BIND))
407 (display "registering closures...\n")
408 (for-each (lambda (closure)
409 (register-closure target
410 (string-append "/xchg/" closure)
411 #:reset-timestamps? copy-closures?
412 #:deduplicate? deduplicate?))
414 (unless copy-closures?
415 (umount target-store)))
417 ;; Add the non-store directories and files.
418 (display "populating...\n")
419 (populate-root-file-system system-directory target
420 #:extras extra-directives)
422 ;; 'register-closure' resets timestamps and everything, so no need to do it
423 ;; once more in that case.
424 (unless register-closures?
425 ;; 'reset-timestamps' also resets file permissions; do that everywhere
426 ;; except on /dev so that /dev/null remains writable, etc.
427 (for-each (lambda (directory)
428 (reset-timestamps (string-append target "/" directory)))
431 ((or "." ".." "dev") #f)
433 (reset-timestamps (string-append target "/dev")
434 #:preserve-permissions? #t))))
436 (define (register-bootcfg-root target bootcfg)
437 "On file system TARGET, register BOOTCFG as a GC root."
438 (let ((directory (string-append target "/var/guix/gcroots")))
440 (symlink bootcfg (string-append directory "/bootcfg"))))
442 (define* (initialize-hard-disk device
450 "Initialize DEVICE as a disk containing all the <partition> objects listed
451 in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
453 Each partition is initialized by calling its 'initializer' procedure,
454 passing it a directory name where it is mounted."
456 (define (partition-bootable? partition)
457 "Return the first partition found with the boot flag set."
458 (member 'boot (partition-flags partition)))
460 (define (partition-esp? partition)
461 "Return the first EFI System Partition."
462 (member 'esp (partition-flags partition)))
464 (let* ((partitions (initialize-partition-table device partitions))
465 (root (find partition-bootable? partitions))
466 (esp (find partition-esp? partitions))
469 (error "no bootable partition specified" partitions))
471 (for-each initialize-partition partitions)
473 (display "mounting root partition...\n")
475 (mount (partition-device root) target (partition-file-system root))
476 (install-boot-config bootcfg bootcfg-location target)
477 (when bootloader-installer
478 (display "installing bootloader...\n")
479 (bootloader-installer bootloader-package device target))
482 ;; Mount the ESP somewhere and install GRUB UEFI image.
483 (let ((mount-point (string-append target "/boot/efi")))
484 (display "mounting EFI system partition...\n")
485 (mkdir-p mount-point)
486 (mount (partition-device esp) mount-point
487 (partition-file-system esp))
489 (display "creating EFI firmware image...")
490 (install-efi-loader grub-efi mount-point)
493 (umount mount-point)))
495 ;; Register BOOTCFG as a GC root.
496 (register-bootcfg-root target bootcfg)