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