gnu/build/vm.scm

   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>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  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.
  16 ;;;
  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.
  21 ;;;
  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/>.
  24
  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
  46             load-in-linux-vm
  47             format-partition
  48
  49             partition
  50             partition?
  51             partition-device
  52             partition-size
  53             partition-file-system
  54             partition-label
  55             partition-flags
  56             partition-initializer
  57
  58             estimated-partition-size
  59             root-partition-initializer
  60             initialize-partition-table
  61             initialize-hard-disk))
  62
  63 ;;; Commentary:
  64 ;;;
  65 ;;; This module provides supporting code to run virtual machines and build
  66 ;;; virtual machine images using QEMU.
  67 ;;;
  68 ;;; Code:
  69
  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-"
  75                    (cond
  76                     ((string-match "^i[3456]86$" cpu) "i386")
  77                     ((string-match "armhf" cpu) "arm")
  78                     (else cpu)))))
  79
  80 (define* (load-in-linux-vm builder
  81                            #:key
  82                            output
  83                            (qemu (qemu-command)) (memory-size 512)
  84                            linux initrd
  85                            make-disk-image?
  86                            single-file-output?
  87                            (disk-image-size (* 100 (expt 2 20)))
  88                            (disk-image-format "qcow2")
  89                            (references-graphs '()))
  90   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
  91 the result to OUTPUT.  If SINGLE-FILE-OUTPUT? is true, copy a single file from
  92 /xchg to OUTPUT.  Otherwise, copy the contents of /xchg to a new directory
  93 OUTPUT.
  94
  95 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
  96 DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
  97 access it via /dev/hda.
  98
  99 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 100 the #:references-graphs parameter of 'derivation'."
 101
 102   (define target-arm32?
 103     (string-prefix? "arm-" %host-type))
 104
 105   (define target-aarch64?
 106     (string-prefix? "aarch64-" %host-type))
 107
 108   (define target-arm?
 109     (or target-arm32? target-aarch64?))
 110
 111   (define arch-specific-flags
 112     `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
 113       ;; hardware limits imposed by other machines.
 114       ,@(if target-arm?
 115             '("-M" "virt")
 116             '())
 117
 118       ;; On ARM32, if the kernel is built without LPAE support, ECAM conflicts
 119       ;; with VIRT_PCIE_MMIO causing PCI devices not to show up.  Disable
 120       ;; explicitely highmem to fix it.
 121       ;; See: https://bugs.launchpad.net/qemu/+bug/1790975.
 122       ,@(if target-arm32?
 123             '("-machine" "highmem=off")
 124             '())
 125
 126       ;; Only enable kvm if we see /dev/kvm exists.  This allows users without
 127       ;; hardware virtualization to still use these commands.  KVM support is
 128       ;; still buggy on some ARM boards. Do not use it even if available.
 129       ,@(if (and (file-exists? "/dev/kvm")
 130                  (not target-arm?))
 131             '("-enable-kvm")
 132             '())
 133
 134       ;; Pass "panic=1" so that the guest dies upon error.
 135       "-append"
 136       ,(string-append "panic=1 --load=" builder
 137
 138                       ;; The serial port name differs between emulated
 139                       ;; architectures/machines.
 140                       " console="
 141                       (if target-arm? "ttyAMA0" "ttyS0"))))
 142
 143   (when make-disk-image?
 144     (format #t "creating ~a image of ~,2f MiB...~%"
 145             disk-image-format (/ disk-image-size (expt 2 20)))
 146     (force-output)
 147     (invoke "qemu-img" "create" "-f" disk-image-format output
 148              (number->string disk-image-size)))
 149
 150   (mkdir "xchg")
 151   (mkdir "tmp")
 152
 153   (match references-graphs
 154     ((graph-files ...)
 155      ;; Copy the reference-graph files under xchg/ so EXP can access it.
 156      (map (lambda (file)
 157             (copy-file file (string-append "xchg/" file)))
 158           graph-files))
 159     (_ #f))
 160
 161   (apply invoke qemu "-nographic" "-no-reboot"
 162          ;; CPU "max" behaves as "host" when KVM is enabled, and like a system
 163          ;; CPU with the maximum possible feature set otherwise.
 164          "-cpu" "max"
 165          "-m" (number->string memory-size)
 166          "-nic" "user,model=virtio-net-pci"
 167          "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
 168          "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
 169          "-virtfs"
 170          (string-append "local,id=store_dev,path="
 171                         (%store-directory)
 172                         ",security_model=none,mount_tag=store")
 173          "-virtfs"
 174          (string-append "local,id=xchg_dev,path=xchg"
 175                         ",security_model=none,mount_tag=xchg")
 176          "-virtfs"
 177          ;; Some programs require more space in /tmp than is normally
 178          ;; available in the guest.  Accommodate such programs by sharing a
 179          ;; temporary directory.
 180          (string-append "local,id=tmp_dev,path=tmp"
 181                         ",security_model=none,mount_tag=tmp")
 182          "-kernel" linux
 183          "-initrd" initrd
 184          (append
 185           (if make-disk-image?
 186               `("-device" "virtio-blk,drive=myhd"
 187                 "-drive" ,(string-append "if=none,file=" output
 188                                          ",format=" disk-image-format
 189                                          ",id=myhd"))
 190               '())
 191           arch-specific-flags))
 192
 193   (unless (file-exists? "xchg/.exit-status")
 194     (error "VM did not produce an exit code"))
 195
 196   (match (call-with-input-file "xchg/.exit-status" read)
 197     (0 #t)
 198     (status (error "guest VM code exited with a non-zero status" status)))
 199
 200   (delete-file "xchg/.exit-status")
 201
 202   ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
 203   (unless make-disk-image?
 204     (if single-file-output?
 205         (let ((graph? (lambda (name stat)
 206                         (member (basename name) references-graphs))))
 207           (match (find-files "xchg" (negate graph?))
 208             ((result)
 209              (copy-file result output))
 210             (x
 211              (error "did not find a single result file" x))))
 212         (begin
 213           (mkdir output)
 214           (copy-recursively "xchg" output)))))
 215
 216 (define* (register-closure prefix closure
 217                            #:key
 218                            (deduplicate? #t) (reset-timestamps? #t)
 219                            (schema (sql-schema)))
 220   "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
 221 target store and CLOSURE is the name of a file containing a reference graph as
 222 produced by #:references-graphs..  As a side effect, if RESET-TIMESTAMPS? is
 223 true, reset timestamps on store files and, if DEDUPLICATE? is true,
 224 deduplicates files common to CLOSURE and the rest of PREFIX."
 225   (let ((items (call-with-input-file closure read-reference-graph)))
 226     (parameterize ((sql-schema schema))
 227       (with-database (store-database-file #:prefix prefix) db
 228         (register-items db items
 229                         #:prefix prefix
 230                         #:deduplicate? deduplicate?
 231                         #:reset-timestamps? reset-timestamps?
 232                         #:registration-time %epoch)))))
 233
 234 \f
 235 ;;;
 236 ;;; Partitions.
 237 ;;;
 238
 239 (define-record-type* <partition> partition make-partition
 240   partition?
 241   (device      partition-device (default #f))
 242   (size        partition-size)
 243   (file-system partition-file-system (default "ext4"))
 244   (file-system-options partition-file-system-options ;passed to 'mkfs.FS'
 245                        (default '()))
 246   (label       partition-label (default #f))
 247   (uuid        partition-uuid (default #f))
 248   (flags       partition-flags (default '()))
 249   (initializer partition-initializer (default (const #t))))
 250
 251 (define (estimated-partition-size graphs)
 252   "Return the estimated size of a partition that can store the store items
 253 given by GRAPHS, a list of file names produced by #:references-graphs."
 254   ;; Simply add a 25% overhead.
 255   (round (* 1.25 (closure-size graphs))))
 256
 257 (define* (initialize-partition-table device partitions
 258                                      #:key
 259                                      (label-type "msdos")
 260                                      (offset (expt 2 20)))
 261   "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
 262 PARTITIONS (a list of <partition> objects), starting at OFFSET bytes.  On
 263 success, return PARTITIONS with their 'device' field changed to reflect their
 264 actual /dev name based on DEVICE."
 265   (define (partition-options part offset index)
 266     (cons* "mkpart" "primary" "ext2"
 267            (format #f "~aB" offset)
 268            (format #f "~aB" (+ offset (partition-size part)))
 269            (append-map (lambda (flag)
 270                          (list "set" (number->string index)
 271                                (symbol->string flag) "on"))
 272                        (partition-flags part))))
 273
 274   (define (options partitions offset)
 275     (let loop ((partitions partitions)
 276                (offset     offset)
 277                (index      1)
 278                (result     '()))
 279       (match partitions
 280         (()
 281          (concatenate (reverse result)))
 282         ((head tail ...)
 283          (loop tail
 284                ;; Leave one sector (512B) between partitions to placate
 285                ;; Parted.
 286                (+ offset 512 (partition-size head))
 287                (+ 1 index)
 288                (cons (partition-options head offset index)
 289                      result))))))
 290
 291   (format #t "creating partition table with ~a partitions (~a)...\n"
 292           (length partitions)
 293           (string-join (map (compose (cut string-append <> " MiB")
 294                                      number->string
 295                                      (lambda (size)
 296                                        (round (/ size (expt 2. 20))))
 297                                      partition-size)
 298                             partitions)
 299                        ", "))
 300   (apply invoke "parted" "--script"
 301          device "mklabel" label-type
 302          (options partitions offset))
 303
 304   ;; Set the 'device' field of each partition.
 305   (reverse
 306    (fold2 (lambda (part result index)
 307             (values (cons  (partition
 308                             (inherit part)
 309                             (device (string-append device
 310                                                    (number->string index))))
 311                            result)
 312                     (+ 1 index)))
 313           '()
 314           1
 315           partitions)))
 316
 317 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 318
 319 (define* (create-ext-file-system partition type
 320                                  #:key label uuid (options '()))
 321   "Create an ext-family file system of TYPE on PARTITION.  If LABEL is true,
 322 use that as the volume name.  If UUID is true, use it as the partition UUID."
 323   (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
 324           type label (and uuid (uuid->string uuid)))
 325   (apply invoke (string-append "mkfs." type)
 326          "-F" partition
 327          `(,@(if label
 328                  `("-L" ,label)
 329                  '())
 330            ,@(if uuid
 331                  `("-U" ,(uuid->string uuid))
 332                  '())
 333            ,@options)))
 334
 335 (define* (create-fat-file-system partition
 336                                  #:key label uuid (options '()))
 337   "Create a FAT file system on PARTITION.  The number of File Allocation Tables
 338 will be determined based on file system size.  If LABEL is true, use that as the
 339 volume name."
 340   ;; FIXME: UUID is ignored!
 341   (format #t "creating FAT partition...\n")
 342   (apply invoke "mkfs.fat" partition
 343          (append (if label `("-n" ,label) '()) options)))
 344
 345 (define* (format-partition partition type
 346                            #:key label uuid (options '()))
 347   "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
 348 volume name.  Options is a list of command-line options passed to 'mkfs.FS'."
 349   (cond ((string-prefix? "ext" type)
 350          (create-ext-file-system partition type #:label label #:uuid uuid
 351                                  #:options options))
 352         ((or (string-prefix? "fat" type) (string= "vfat" type))
 353          (create-fat-file-system partition #:label label #:uuid uuid
 354                                  #:options options))
 355         (else (error "Unsupported file system."))))
 356
 357 (define (initialize-partition partition)
 358   "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
 359 it, run its initializer, and unmount it."
 360   (let ((target "/fs"))
 361    (format-partition (partition-device partition)
 362                      (partition-file-system partition)
 363                      #:label (partition-label partition)
 364                      #:uuid (partition-uuid partition)
 365                      #:options (partition-file-system-options partition))
 366    (mkdir-p target)
 367    (mount (partition-device partition) target
 368           (partition-file-system partition))
 369
 370    ((partition-initializer partition) target)
 371
 372    (umount target)
 373    partition))
 374
 375 (define* (root-partition-initializer #:key (closures '())
 376                                      copy-closures?
 377                                      (register-closures? #t)
 378                                      system-directory
 379                                      (deduplicate? #t)
 380                                      (make-device-nodes
 381                                       make-essential-device-nodes)
 382                                      (extra-directives '()))
 383   "Return a procedure to initialize a root partition.
 384
 385 If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
 386 store.  If DEDUPLICATE? is true, then also deduplicate files common to
 387 CLOSURES and the rest of the store when registering the closures.  If
 388 COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
 389 SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation.
 390
 391 EXTRA-DIRECTIVES is an optional list of directives to populate the root file
 392 system that is passed to 'populate-root-file-system'."
 393   (lambda (target)
 394     (define target-store
 395       (string-append target (%store-directory)))
 396
 397     (when copy-closures?
 398       ;; Populate the store.
 399       (populate-store (map (cut string-append "/xchg/" <>) closures)
 400                       target))
 401
 402     ;; Populate /dev.
 403     (make-device-nodes target)
 404
 405     ;; Optionally, register the inputs in the image's store.
 406     (when register-closures?
 407       (unless copy-closures?
 408         ;; XXX: 'register-closure' wants to palpate the things it registers, so
 409         ;; bind-mount the store on the target.
 410         (mkdir-p target-store)
 411         (mount (%store-directory) target-store "" MS_BIND))
 412
 413       (display "registering closures...\n")
 414       (for-each (lambda (closure)
 415                   (register-closure target
 416                                     (string-append "/xchg/" closure)
 417                                     #:reset-timestamps? copy-closures?
 418                                     #:deduplicate? deduplicate?))
 419                 closures)
 420       (unless copy-closures?
 421         (umount target-store)))
 422
 423     ;; Add the non-store directories and files.
 424     (display "populating...\n")
 425     (populate-root-file-system system-directory target
 426                                #:extras extra-directives)
 427
 428     ;; 'register-closure' resets timestamps and everything, so no need to do it
 429     ;; once more in that case.
 430     (unless register-closures?
 431       ;; 'reset-timestamps' also resets file permissions; do that everywhere
 432       ;; except on /dev so that /dev/null remains writable, etc.
 433       (for-each (lambda (directory)
 434                   (reset-timestamps (string-append target "/" directory)))
 435                 (scandir target
 436                          (match-lambda
 437                            ((or "." ".." "dev") #f)
 438                            (_ #t))))
 439       (reset-timestamps (string-append target "/dev")
 440                         #:preserve-permissions? #t))))
 441
 442 (define (register-bootcfg-root target bootcfg)
 443   "On file system TARGET, register BOOTCFG as a GC root."
 444   (let ((directory (string-append target "/var/guix/gcroots")))
 445     (mkdir-p directory)
 446     (symlink bootcfg (string-append directory "/bootcfg"))))
 447
 448 (define* (initialize-hard-disk device
 449                                #:key
 450                                bootloader-package
 451                                bootcfg
 452                                bootcfg-location
 453                                bootloader-installer
 454                                (grub-efi #f)
 455                                (partitions '()))
 456   "Initialize DEVICE as a disk containing all the <partition> objects listed
 457 in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
 458
 459 Each partition is initialized by calling its 'initializer' procedure,
 460 passing it a directory name where it is mounted."
 461
 462   (define (partition-bootable? partition)
 463     "Return the first partition found with the boot flag set."
 464     (member 'boot (partition-flags partition)))
 465
 466   (define (partition-esp? partition)
 467     "Return the first EFI System Partition."
 468     (member 'esp (partition-flags partition)))
 469
 470   (let* ((partitions (initialize-partition-table device partitions))
 471          (root       (find partition-bootable? partitions))
 472          (esp        (find partition-esp? partitions))
 473          (target     "/fs"))
 474     (unless root
 475       (error "no bootable partition specified" partitions))
 476
 477     (for-each initialize-partition partitions)
 478
 479     (display "mounting root partition...\n")
 480     (mkdir-p target)
 481     (mount (partition-device root) target (partition-file-system root))
 482     (install-boot-config bootcfg bootcfg-location target)
 483     (when bootloader-installer
 484       (display "installing bootloader...\n")
 485       (bootloader-installer bootloader-package device target))
 486
 487     (when esp
 488       ;; Mount the ESP somewhere and install GRUB UEFI image.
 489       (let ((mount-point (string-append target "/boot/efi")))
 490         (display "mounting EFI system partition...\n")
 491         (mkdir-p mount-point)
 492         (mount (partition-device esp) mount-point
 493                (partition-file-system esp))
 494
 495         (display "creating EFI firmware image...")
 496         (install-efi-loader grub-efi mount-point)
 497         (display "done.\n")
 498
 499         (umount mount-point)))
 500
 501     ;; Register BOOTCFG as a GC root.
 502     (register-bootcfg-root target bootcfg)
 503
 504     (umount target)))
 505
 506 ;;; vm.scm ends here