gnu/build/vm.scm

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