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