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