gnu/build/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   4 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu build vm)
  22   #:use-module (guix build utils)
  23   #:use-module (guix build store-copy)
  24   #:use-module (gnu build linux-boot)
  25   #:use-module (gnu build install)
  26   #:use-module (guix records)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 regex)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-9)
  31   #:use-module (srfi srfi-26)
  32   #:export (qemu-command
  33             load-in-linux-vm
  34             format-partition
  35
  36             partition
  37             partition?
  38             partition-device
  39             partition-size
  40             partition-file-system
  41             partition-label
  42             partition-bootable?
  43             partition-initializer
  44
  45             root-partition-initializer
  46             initialize-partition-table
  47             initialize-hard-disk))
  48
  49 ;;; Commentary:
  50 ;;;
  51 ;;; This module provides supporting code to run virtual machines and build
  52 ;;; virtual machine images using QEMU.
  53 ;;;
  54 ;;; Code:
  55
  56 (define* (qemu-command #:optional (system %host-type))
  57   "Return the default name of the QEMU command for SYSTEM."
  58   (let ((cpu (substring system 0
  59                         (string-index system #\-))))
  60     (string-append "qemu-system-"
  61                    (if (string-match "^i[3456]86$" cpu)
  62                        "i386"
  63                        cpu))))
  64
  65 (define* (load-in-linux-vm builder
  66                            #:key
  67                            output
  68                            (qemu (qemu-command)) (memory-size 512)
  69                            linux initrd
  70                            make-disk-image? (disk-image-size 100)
  71                            (disk-image-format "qcow2")
  72                            (references-graphs '()))
  73   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
  74 the result to OUTPUT.
  75
  76 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
  77 DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access
  78 it via /dev/hda.
  79
  80 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
  81 the #:references-graphs parameter of 'derivation'."
  82   (when make-disk-image?
  83     (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
  84                             output
  85                             (number->string disk-image-size)))
  86       (error "qemu-img failed")))
  87
  88   (mkdir "xchg")
  89
  90   (match references-graphs
  91     ((graph-files ...)
  92      ;; Copy the reference-graph files under xchg/ so EXP can access it.
  93      (map (lambda (file)
  94             (copy-file file (string-append "xchg/" file)))
  95           graph-files))
  96     (_ #f))
  97
  98   (unless (zero?
  99            (apply system* qemu "-nographic" "-no-reboot"
 100                   "-m" (number->string memory-size)
 101                   "-net" "nic,model=virtio"
 102                   "-virtfs"
 103                   (string-append "local,id=store_dev,path="
 104                                  (%store-directory)
 105                                  ",security_model=none,mount_tag=store")
 106                   "-virtfs"
 107                   (string-append "local,id=xchg_dev,path=xchg"
 108                                  ",security_model=none,mount_tag=xchg")
 109                   "-kernel" linux
 110                   "-initrd" initrd
 111                   "-append" (string-append "console=ttyS0 --load="
 112                                            builder)
 113                   (append
 114                    (if make-disk-image?
 115                        `("-drive" ,(string-append "file=" output
 116                                                   ",if=virtio"))
 117                        '())
 118                    ;; Only enable kvm if we see /dev/kvm exists.
 119                    ;; This allows users without hardware virtualization to still
 120                    ;; use these commands.
 121                    (if (file-exists? "/dev/kvm")
 122                        '("-enable-kvm")
 123                        '()))))
 124     (error "qemu failed" qemu))
 125
 126   ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
 127   (unless make-disk-image?
 128     (mkdir output)
 129     (copy-recursively "xchg" output)))
 130
 131 \f
 132 ;;;
 133 ;;; Partitions.
 134 ;;;
 135
 136 (define-record-type* <partition> partition make-partition
 137   partition?
 138   (device      partition-device (default #f))
 139   (size        partition-size)
 140   (file-system partition-file-system (default "ext4"))
 141   (label       partition-label (default #f))
 142   (bootable?   partition-bootable? (default #f))
 143   (initializer partition-initializer (default (const #t))))
 144
 145 (define (fold2 proc seed1 seed2 lst)              ;TODO: factorize
 146   "Like `fold', but with a single list and two seeds."
 147   (let loop ((result1 seed1)
 148              (result2 seed2)
 149              (lst     lst))
 150     (if (null? lst)
 151         (values result1 result2)
 152         (call-with-values
 153             (lambda () (proc (car lst) result1 result2))
 154           (lambda (result1 result2)
 155             (loop result1 result2 (cdr lst)))))))
 156
 157 (define* (initialize-partition-table device partitions
 158                                      #:key
 159                                      (label-type "msdos")
 160                                      (offset (expt 2 20)))
 161   "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
 162 PARTITIONS (a list of <partition> objects), starting at OFFSET bytes.  On
 163 success, return PARTITIONS with their 'device' field changed to reflect their
 164 actual /dev name based on DEVICE."
 165   (define (partition-options part offset index)
 166     (cons* "mkpart" "primary" "ext2"
 167            (format #f "~aB" offset)
 168            (format #f "~aB" (+ offset (partition-size part)))
 169            (if (partition-bootable? part)
 170                `("set" ,(number->string index) "boot" "on")
 171                '())))
 172
 173   (define (options partitions offset)
 174     (let loop ((partitions partitions)
 175                (offset     offset)
 176                (index      1)
 177                (result     '()))
 178       (match partitions
 179         (()
 180          (concatenate (reverse result)))
 181         ((head tail ...)
 182          (loop tail
 183                ;; Leave one sector (512B) between partitions to placate
 184                ;; Parted.
 185                (+ offset 512 (partition-size head))
 186                (+ 1 index)
 187                (cons (partition-options head offset index)
 188                      result))))))
 189
 190   (format #t "creating partition table with ~a partitions...\n"
 191           (length partitions))
 192   (unless (zero? (apply system* "parted" "--script"
 193                         device "mklabel" label-type
 194                         (options partitions offset)))
 195     (error "failed to create partition table"))
 196
 197   ;; Set the 'device' field of each partition.
 198   (reverse
 199    (fold2 (lambda (part result index)
 200             (values (cons  (partition
 201                             (inherit part)
 202                             (device (string-append device
 203                                                    (number->string index))))
 204                            result)
 205                     (+ 1 index)))
 206           '()
 207           1
 208           partitions)))
 209
 210 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 211
 212 (define* (format-partition partition type
 213                            #:key label)
 214   "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
 215 volume name."
 216   (format #t "creating ~a partition...\n" type)
 217   (unless (zero? (apply system* (string-append "mkfs." type)
 218                         "-F" partition
 219                         (if label
 220                             `("-L" ,label)
 221                             '())))
 222     (error "failed to create partition")))
 223
 224 (define (initialize-partition partition)
 225   "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
 226 it, run its initializer, and unmount it."
 227   (let ((target "/fs"))
 228    (format-partition (partition-device partition)
 229                      (partition-file-system partition)
 230                      #:label (partition-label partition))
 231    (mkdir-p target)
 232    (mount (partition-device partition) target
 233           (partition-file-system partition))
 234
 235    ((partition-initializer partition) target)
 236
 237    (umount target)
 238    partition))
 239
 240 (define* (root-partition-initializer #:key (closures '())
 241                                      copy-closures?
 242                                      (register-closures? #t)
 243                                      system-directory)
 244   "Return a procedure to initialize a root partition.
 245
 246 If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's
 247 store.  If COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
 248 SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
 249   (lambda (target)
 250     (define target-store
 251       (string-append target (%store-directory)))
 252
 253     (when copy-closures?
 254       ;; Populate the store.
 255       (populate-store (map (cut string-append "/xchg/" <>) closures)
 256                       target))
 257
 258     ;; Populate /dev.
 259     (make-essential-device-nodes #:root target)
 260
 261     ;; Optionally, register the inputs in the image's store.
 262     (when register-closures?
 263       (unless copy-closures?
 264         ;; XXX: 'guix-register' wants to palpate the things it registers, so
 265         ;; bind-mount the store on the target.
 266         (mkdir-p target-store)
 267         (mount (%store-directory) target-store "" MS_BIND))
 268
 269       (display "registering closures...\n")
 270       (for-each (lambda (closure)
 271                   (register-closure target
 272                                     (string-append "/xchg/" closure)))
 273                 closures)
 274       (unless copy-closures?
 275         (umount target-store)))
 276
 277     ;; Add the non-store directories and files.
 278     (display "populating...\n")
 279     (populate-root-file-system system-directory target)
 280
 281     ;; 'guix-register' resets timestamps and everything, so no need to do it
 282     ;; once more in that case.
 283     (unless register-closures?
 284       (reset-timestamps target))))
 285
 286 (define (register-grub.cfg-root target grub.cfg)
 287   "On file system TARGET, register GRUB.CFG as a GC root."
 288   (let ((directory (string-append target "/var/guix/gcroots")))
 289     (mkdir-p directory)
 290     (symlink grub.cfg (string-append directory "/grub.cfg"))))
 291
 292 (define* (initialize-hard-disk device
 293                                #:key
 294                                grub.cfg
 295                                (partitions '()))
 296   "Initialize DEVICE as a disk containing all the <partition> objects listed
 297 in PARTITIONS, and using GRUB.CFG as its bootloader configuration file.
 298
 299 Each partition is initialized by calling its 'initializer' procedure,
 300 passing it a directory name where it is mounted."
 301   (let* ((partitions (initialize-partition-table device partitions))
 302          (root       (find partition-bootable? partitions))
 303          (target     "/fs"))
 304     (unless root
 305       (error "no bootable partition specified" partitions))
 306
 307     (for-each initialize-partition partitions)
 308
 309     (display "mounting root partition...\n")
 310     (mkdir-p target)
 311     (mount (partition-device root) target (partition-file-system root))
 312     (install-grub grub.cfg device target)
 313
 314     ;; Register GRUB.CFG as a GC root.
 315     (register-grub.cfg-root target grub.cfg)
 316
 317     (umount target)))
 318
 319 ;;; vm.scm ends here