gnu/build/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (gnu build vm)
  25   #:use-module (guix build utils)
  26   #:use-module (guix build store-copy)
  27   #:use-module (guix build syscalls)
  28   #:use-module (gnu build linux-boot)
  29   #:use-module (gnu build install)
  30   #:use-module (gnu system uuid)
  31   #:use-module (guix records)
  32   #:use-module ((guix combinators) #:select (fold2))
  33   #:use-module (ice-9 format)
  34   #:use-module (ice-9 match)
  35   #:use-module (ice-9 regex)
  36   #:use-module (srfi srfi-1)
  37   #:use-module (srfi srfi-9)
  38   #:use-module (srfi srfi-26)
  39   #:export (qemu-command
  40             load-in-linux-vm
  41             format-partition
  42
  43             partition
  44             partition?
  45             partition-device
  46             partition-size
  47             partition-file-system
  48             partition-label
  49             partition-flags
  50             partition-initializer
  51
  52             estimated-partition-size
  53             root-partition-initializer
  54             initialize-partition-table
  55             initialize-hard-disk
  56             make-iso9660-image))
  57
  58 ;;; Commentary:
  59 ;;;
  60 ;;; This module provides supporting code to run virtual machines and build
  61 ;;; virtual machine images using QEMU.
  62 ;;;
  63 ;;; Code:
  64
  65 (define* (qemu-command #:optional (system %host-type))
  66   "Return the default name of the QEMU command for SYSTEM."
  67   (let ((cpu (substring system 0
  68                         (string-index system #\-))))
  69     (string-append "qemu-system-"
  70                    (if (string-match "^i[3456]86$" cpu)
  71                        "i386"
  72                        cpu))))
  73
  74 (define* (load-in-linux-vm builder
  75                            #:key
  76                            output
  77                            (qemu (qemu-command)) (memory-size 512)
  78                            linux initrd
  79                            make-disk-image?
  80                            single-file-output?
  81                            target-arm32?
  82                            (disk-image-size (* 100 (expt 2 20)))
  83                            (disk-image-format "qcow2")
  84                            (references-graphs '()))
  85   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
  86 the result to OUTPUT.  If SINGLE-FILE-OUTPUT? is true, copy a single file from
  87 /xchg to OUTPUT.  Otherwise, copy the contents of /xchg to a new directory
  88 OUTPUT.
  89
  90 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
  91 DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
  92 access it via /dev/hda.
  93
  94 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
  95 the #:references-graphs parameter of 'derivation'."
  96
  97   (define arch-specific-flags
  98     `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
  99       ;; hardware limits imposed by other machines.
 100       ,@(if target-arm32? '("-M" "virt") '())
 101
 102       ;; Only enable kvm if we see /dev/kvm exists.  This allows users without
 103       ;; hardware virtualization to still use these commands.  KVM support is
 104       ;; still buggy on some ARM32 boards. Do not use it even if available.
 105       ,@(if (and (file-exists? "/dev/kvm")
 106                  (not target-arm32?))
 107             '("-enable-kvm")
 108             '())
 109
 110       ;; Pass "panic=1" so that the guest dies upon error.
 111       "-append"
 112       ,(string-append "panic=1 --load=" builder
 113
 114                       ;; The serial port name differs between emulated
 115                       ;; architectures/machines.
 116                       " console="
 117                       (if target-arm32? "ttyAMA0" "ttyS0"))
 118
 119       ;; NIC is not supported on ARM "virt" machine, so use a user mode
 120       ;; network stack instead.
 121       ,@(if target-arm32?
 122             '("-device" "virtio-net-pci,netdev=mynet"
 123               "-netdev" "user,id=mynet")
 124             '("-net" "nic,model=virtio"))))
 125
 126   (when make-disk-image?
 127     (format #t "creating ~a image of ~,2f MiB...~%"
 128             disk-image-format (/ disk-image-size (expt 2 20)))
 129     (force-output)
 130     (invoke "qemu-img" "create" "-f" disk-image-format output
 131              (number->string disk-image-size)))
 132
 133   (mkdir "xchg")
 134   (mkdir "tmp")
 135
 136   (match references-graphs
 137     ((graph-files ...)
 138      ;; Copy the reference-graph files under xchg/ so EXP can access it.
 139      (map (lambda (file)
 140             (copy-file file (string-append "xchg/" file)))
 141           graph-files))
 142     (_ #f))
 143
 144   (apply invoke qemu "-nographic" "-no-reboot"
 145          "-m" (number->string memory-size)
 146          "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
 147          "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
 148          "-virtfs"
 149          (string-append "local,id=store_dev,path="
 150                         (%store-directory)
 151                         ",security_model=none,mount_tag=store")
 152          "-virtfs"
 153          (string-append "local,id=xchg_dev,path=xchg"
 154                         ",security_model=none,mount_tag=xchg")
 155          "-virtfs"
 156          ;; Some programs require more space in /tmp than is normally
 157          ;; available in the guest.  Accommodate such programs by sharing a
 158          ;; temporary directory.
 159          (string-append "local,id=tmp_dev,path=tmp"
 160                         ",security_model=none,mount_tag=tmp")
 161          "-kernel" linux
 162          "-initrd" initrd
 163          (append
 164           (if make-disk-image?
 165               `("-device" "virtio-blk,drive=myhd"
 166                 "-drive" ,(string-append "if=none,file=" output
 167                                          ",format=" disk-image-format
 168                                          ",id=myhd"))
 169               '())
 170           arch-specific-flags))
 171
 172   ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
 173   (unless make-disk-image?
 174     (if single-file-output?
 175         (let ((graph? (lambda (name stat)
 176                         (member (basename name) references-graphs))))
 177           (match (find-files "xchg" (negate graph?))
 178             ((result)
 179              (copy-file result output))
 180             (x
 181              (error "did not find a single result file" x))))
 182         (begin
 183           (mkdir output)
 184           (copy-recursively "xchg" output)))))
 185
 186 \f
 187 ;;;
 188 ;;; Partitions.
 189 ;;;
 190
 191 (define-record-type* <partition> partition make-partition
 192   partition?
 193   (device      partition-device (default #f))
 194   (size        partition-size)
 195   (file-system partition-file-system (default "ext4"))
 196   (label       partition-label (default #f))
 197   (uuid        partition-uuid (default #f))
 198   (flags       partition-flags (default '()))
 199   (initializer partition-initializer (default (const #t))))
 200
 201 (define (estimated-partition-size graphs)
 202   "Return the estimated size of a partition that can store the store items
 203 given by GRAPHS, a list of file names produced by #:references-graphs."
 204   ;; Simply add a 25% overhead.
 205   (round (* 1.25 (closure-size graphs))))
 206
 207 (define* (initialize-partition-table device partitions
 208                                      #:key
 209                                      (label-type "msdos")
 210                                      (offset (expt 2 20)))
 211   "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
 212 PARTITIONS (a list of <partition> objects), starting at OFFSET bytes.  On
 213 success, return PARTITIONS with their 'device' field changed to reflect their
 214 actual /dev name based on DEVICE."
 215   (define (partition-options part offset index)
 216     (cons* "mkpart" "primary" "ext2"
 217            (format #f "~aB" offset)
 218            (format #f "~aB" (+ offset (partition-size part)))
 219            (append-map (lambda (flag)
 220                          (list "set" (number->string index)
 221                                (symbol->string flag) "on"))
 222                        (partition-flags part))))
 223
 224   (define (options partitions offset)
 225     (let loop ((partitions partitions)
 226                (offset     offset)
 227                (index      1)
 228                (result     '()))
 229       (match partitions
 230         (()
 231          (concatenate (reverse result)))
 232         ((head tail ...)
 233          (loop tail
 234                ;; Leave one sector (512B) between partitions to placate
 235                ;; Parted.
 236                (+ offset 512 (partition-size head))
 237                (+ 1 index)
 238                (cons (partition-options head offset index)
 239                      result))))))
 240
 241   (format #t "creating partition table with ~a partitions (~a)...\n"
 242           (length partitions)
 243           (string-join (map (compose (cut string-append <> " MiB")
 244                                      number->string
 245                                      (lambda (size)
 246                                        (round (/ size (expt 2. 20))))
 247                                      partition-size)
 248                             partitions)
 249                        ", "))
 250   (apply invoke "parted" "--script"
 251          device "mklabel" label-type
 252          (options partitions offset))
 253
 254   ;; Set the 'device' field of each partition.
 255   (reverse
 256    (fold2 (lambda (part result index)
 257             (values (cons  (partition
 258                             (inherit part)
 259                             (device (string-append device
 260                                                    (number->string index))))
 261                            result)
 262                     (+ 1 index)))
 263           '()
 264           1
 265           partitions)))
 266
 267 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 268
 269 (define* (create-ext-file-system partition type
 270                                  #:key label uuid)
 271   "Create an ext-family file system of TYPE on PARTITION.  If LABEL is true,
 272 use that as the volume name.  If UUID is true, use it as the partition UUID."
 273   (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
 274           type label (and uuid (uuid->string uuid)))
 275   (apply invoke (string-append "mkfs." type)
 276          "-F" partition
 277          `(,@(if label
 278                  `("-L" ,label)
 279                  '())
 280            ,@(if uuid
 281                  `("-U" ,(uuid->string uuid))
 282                  '()))))
 283
 284 (define* (create-fat-file-system partition
 285                                  #:key label uuid)
 286   "Create a FAT file system on PARTITION.  The number of File Allocation Tables
 287 will be determined based on file system size.  If LABEL is true, use that as the
 288 volume name."
 289   ;; FIXME: UUID is ignored!
 290   (format #t "creating FAT partition...\n")
 291   (apply invoke "mkfs.fat" partition
 292          (if label `("-n" ,label) '())))
 293
 294 (define* (format-partition partition type
 295                            #:key label uuid)
 296   "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
 297 volume name."
 298   (cond ((string-prefix? "ext" type)
 299          (create-ext-file-system partition type #:label label #:uuid uuid))
 300         ((or (string-prefix? "fat" type) (string= "vfat" type))
 301          (create-fat-file-system partition #:label label #:uuid uuid))
 302         (else (error "Unsupported file system."))))
 303
 304 (define (initialize-partition partition)
 305   "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
 306 it, run its initializer, and unmount it."
 307   (let ((target "/fs"))
 308    (format-partition (partition-device partition)
 309                      (partition-file-system partition)
 310                      #:label (partition-label partition)
 311                      #:uuid (partition-uuid partition))
 312    (mkdir-p target)
 313    (mount (partition-device partition) target
 314           (partition-file-system partition))
 315
 316    ((partition-initializer partition) target)
 317
 318    (umount target)
 319    partition))
 320
 321 (define* (root-partition-initializer #:key (closures '())
 322                                      copy-closures?
 323                                      (register-closures? #t)
 324                                      system-directory
 325                                      (deduplicate? #t))
 326   "Return a procedure to initialize a root partition.
 327
 328 If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
 329 store.  If DEDUPLICATE? is true, then also deduplicate files common to
 330 CLOSURES and the rest of the store when registering the closures.  If
 331 COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
 332 SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
 333   (lambda (target)
 334     (define target-store
 335       (string-append target (%store-directory)))
 336
 337     (when copy-closures?
 338       ;; Populate the store.
 339       (populate-store (map (cut string-append "/xchg/" <>) closures)
 340                       target))
 341
 342     ;; Populate /dev.
 343     (make-essential-device-nodes #:root target)
 344
 345     ;; Optionally, register the inputs in the image's store.
 346     (when register-closures?
 347       (unless copy-closures?
 348         ;; XXX: 'guix-register' wants to palpate the things it registers, so
 349         ;; bind-mount the store on the target.
 350         (mkdir-p target-store)
 351         (mount (%store-directory) target-store "" MS_BIND))
 352
 353       (display "registering closures...\n")
 354       (for-each (lambda (closure)
 355                   (register-closure target
 356                                     (string-append "/xchg/" closure)
 357                                     #:deduplicate? deduplicate?))
 358                 closures)
 359       (unless copy-closures?
 360         (umount target-store)))
 361
 362     ;; Add the non-store directories and files.
 363     (display "populating...\n")
 364     (populate-root-file-system system-directory target)
 365
 366     ;; 'guix-register' resets timestamps and everything, so no need to do it
 367     ;; once more in that case.
 368     (unless register-closures?
 369       (reset-timestamps target))))
 370
 371 (define (register-bootcfg-root target bootcfg)
 372   "On file system TARGET, register BOOTCFG as a GC root."
 373   (let ((directory (string-append target "/var/guix/gcroots")))
 374     (mkdir-p directory)
 375     (symlink bootcfg (string-append directory "/bootcfg"))))
 376
 377 (define (install-efi grub esp config-file)
 378   "Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
 379   (let* ((system %host-type)
 380          ;; Hard code the output location to a well-known path recognized by
 381          ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
 382          ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
 383          (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
 384          (efi-directory (string-append esp "/EFI/BOOT"))
 385          ;; Map grub target names to boot file names.
 386          (efi-targets (cond ((string-prefix? "x86_64" system)
 387                              '("x86_64-efi" . "BOOTX64.EFI"))
 388                             ((string-prefix? "i686" system)
 389                              '("i386-efi" . "BOOTIA32.EFI"))
 390                             ((string-prefix? "armhf" system)
 391                              '("arm-efi" . "BOOTARM.EFI"))
 392                             ((string-prefix? "aarch64" system)
 393                              '("arm64-efi" . "BOOTAA64.EFI")))))
 394     ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
 395     (setenv "TMPDIR" esp)
 396
 397     (mkdir-p efi-directory)
 398     (invoke grub-mkstandalone "-O" (car efi-targets)
 399             "-o" (string-append efi-directory "/"
 400                                 (cdr efi-targets))
 401             ;; Graft the configuration file onto the image.
 402             (string-append "boot/grub/grub.cfg=" config-file))))
 403
 404 (define* (make-iso9660-image grub config-file os-drv target
 405                              #:key (volume-id "GuixSD_image") (volume-uuid #f)
 406                              register-closures? (closures '()))
 407   "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
 408 GRUB configuration and OS-DRV as the stuff in it."
 409   (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue"))
 410         (target-store  (string-append "/tmp/root" (%store-directory))))
 411     (populate-root-file-system os-drv "/tmp/root")
 412
 413     (mount (%store-directory) target-store "" MS_BIND)
 414
 415     (when register-closures?
 416       (display "registering closures...\n")
 417       (for-each (lambda (closure)
 418                   (register-closure
 419                    "/tmp/root"
 420                    (string-append "/xchg/" closure)
 421                    ;; XXX: Using deduplication causes cross device link errors.
 422                    #:deduplicate? #f))
 423                 closures))
 424
 425     (apply invoke
 426            `(,grub-mkrescue "-o" ,target
 427                             ,(string-append "boot/grub/grub.cfg=" config-file)
 428                             ,(string-append "gnu/store=" os-drv "/..")
 429                             "etc=/tmp/root/etc"
 430                             "var=/tmp/root/var"
 431                             "run=/tmp/root/run"
 432                             ;; /mnt is used as part of the installation
 433                             ;; process, as the mount point for the target
 434                             ;; file system, so create it.
 435                             "mnt=/tmp/root/mnt"
 436                             "--"
 437                             "-volid" ,(string-upcase volume-id)
 438                             ,@(if volume-uuid
 439                                   `("-volume_date" "uuid"
 440                                     ,(string-filter (lambda (value)
 441                                                       (not (char=? #\- value)))
 442                                                     (iso9660-uuid->string
 443                                                      volume-uuid)))
 444                                   `())))))
 445
 446 (define* (initialize-hard-disk device
 447                                #:key
 448                                bootloader-package
 449                                bootcfg
 450                                bootcfg-location
 451                                bootloader-installer
 452                                (grub-efi #f)
 453                                (partitions '()))
 454   "Initialize DEVICE as a disk containing all the <partition> objects listed
 455 in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
 456
 457 Each partition is initialized by calling its 'initializer' procedure,
 458 passing it a directory name where it is mounted."
 459
 460   (define (partition-bootable? partition)
 461     "Return the first partition found with the boot flag set."
 462     (member 'boot (partition-flags partition)))
 463
 464   (define (partition-esp? partition)
 465     "Return the first EFI System Partition."
 466     (member 'esp (partition-flags partition)))
 467
 468   (let* ((partitions (initialize-partition-table device partitions))
 469          (root       (find partition-bootable? partitions))
 470          (esp        (find partition-esp? partitions))
 471          (target     "/fs"))
 472     (unless root
 473       (error "no bootable partition specified" partitions))
 474
 475     (for-each initialize-partition partitions)
 476
 477     (display "mounting root partition...\n")
 478     (mkdir-p target)
 479     (mount (partition-device root) target (partition-file-system root))
 480     (install-boot-config bootcfg bootcfg-location target)
 481     (when bootloader-installer
 482       (display "installing bootloader...\n")
 483       (bootloader-installer bootloader-package device target))
 484
 485     (when esp
 486       ;; Mount the ESP somewhere and install GRUB UEFI image.
 487       (let ((mount-point (string-append target "/boot/efi"))
 488             (grub-config (string-append target "/tmp/grub-standalone.cfg")))
 489         (display "mounting EFI system partition...\n")
 490         (mkdir-p mount-point)
 491         (mount (partition-device esp) mount-point
 492                (partition-file-system esp))
 493
 494         ;; Create a tiny configuration file telling the embedded grub
 495         ;; where to load the real thing.
 496         ;; XXX This is quite fragile, and can prevent the image from booting
 497         ;; when there's more than one volume with this label present.
 498         ;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
 499         (call-with-output-file grub-config
 500           (lambda (port)
 501             (format port
 502                     "insmod part_msdos~@
 503                     search --set=root --label GuixSD_image~@
 504                     configfile /boot/grub/grub.cfg~%")))
 505
 506         (display "creating EFI firmware image...")
 507         (install-efi grub-efi mount-point grub-config)
 508         (display "done.\n")
 509
 510         (delete-file grub-config)
 511         (umount mount-point)))
 512
 513     ;; Register BOOTCFG as a GC root.
 514     (register-bootcfg-root target bootcfg)
 515
 516     (umount target)))
 517
 518 ;;; vm.scm ends here