gnu/build/vm.scm

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