guix/build/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014 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 (guix build vm)
  20   #:use-module (guix build utils)
  21   #:use-module (guix build linux-initrd)
  22   #:use-module (guix build install)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 regex)
  25   #:use-module (ice-9 rdelim)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-26)
  28   #:export (qemu-command
  29             load-in-linux-vm
  30             format-partition
  31             initialize-root-partition
  32             initialize-partition-table
  33             initialize-hard-disk))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; This module provides supporting code to run virtual machines and build
  38 ;;; virtual machine images using QEMU.
  39 ;;;
  40 ;;; Code:
  41
  42 (define* (qemu-command #:optional (system %host-type))
  43   "Return the default name of the QEMU command for SYSTEM."
  44   (let ((cpu (substring %host-type 0
  45                         (string-index %host-type #\-))))
  46     (string-append "qemu-system-"
  47                    (if (string-match "^i[3456]86$" cpu)
  48                        "i386"
  49                        cpu))))
  50
  51 (define* (load-in-linux-vm builder
  52                            #:key
  53                            output
  54                            (qemu (qemu-command)) (memory-size 512)
  55                            linux initrd
  56                            make-disk-image? (disk-image-size 100)
  57                            (disk-image-format "qcow2")
  58                            (references-graphs '()))
  59   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
  60 the result to OUTPUT.
  61
  62 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
  63 DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access
  64 it via /dev/hda.
  65
  66 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
  67 the #:references-graphs parameter of 'derivation'."
  68   (define image-file
  69     (string-append "image." disk-image-format))
  70
  71   (when make-disk-image?
  72     (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
  73                             image-file
  74                             (number->string disk-image-size)))
  75       (error "qemu-img failed")))
  76
  77   (mkdir "xchg")
  78
  79   (match references-graphs
  80     ((graph-files ...)
  81      ;; Copy the reference-graph files under xchg/ so EXP can access it.
  82      (map (lambda (file)
  83             (copy-file file (string-append "xchg/" file)))
  84           graph-files))
  85     (_ #f))
  86
  87   (unless (zero?
  88            (apply system* qemu "-enable-kvm" "-nographic" "-no-reboot"
  89                   "-m" (number->string memory-size)
  90                   "-net" "nic,model=virtio"
  91                   "-virtfs"
  92                   (string-append "local,id=store_dev,path="
  93                                  (%store-directory)
  94                                  ",security_model=none,mount_tag=store")
  95                   "-virtfs"
  96                   (string-append "local,id=xchg_dev,path=xchg"
  97                                  ",security_model=none,mount_tag=xchg")
  98                   "-kernel" linux
  99                   "-initrd" initrd
 100                   "-append" (string-append "console=ttyS0 --load="
 101                                            builder)
 102                   (if make-disk-image?
 103                       `("-drive" ,(string-append "file=" image-file
 104                                                  ",if=virtio"))
 105                       '())))
 106     (error "qemu failed" qemu))
 107
 108   (if make-disk-image?
 109       (copy-file image-file output)
 110       (begin
 111         (mkdir output)
 112         (copy-recursively "xchg" output))))
 113
 114 (define (read-reference-graph port)
 115   "Return a list of store paths from the reference graph at PORT.
 116 The data at PORT is the format produced by #:references-graphs."
 117   (let loop ((line   (read-line port))
 118              (result '()))
 119     (cond ((eof-object? line)
 120            (delete-duplicates result))
 121           ((string-prefix? "/" line)
 122            (loop (read-line port)
 123                  (cons line result)))
 124           (else
 125            (loop (read-line port)
 126                  result)))))
 127
 128 (define* (initialize-partition-table device partition-size
 129                                      #:key
 130                                      (label-type "msdos")
 131                                      (offset (expt 2 20)))
 132   "Create on DEVICE a partition table of type LABEL-TYPE, with a single
 133 partition of PARTITION-SIZE bytes starting at OFFSET bytes.  Return #t on
 134 success."
 135   (format #t "creating partition table with a ~a B partition...\n"
 136           partition-size)
 137   (unless (zero? (system* "parted" device "mklabel" label-type
 138                           "mkpart" "primary" "ext2"
 139                           (format #f "~aB" offset)
 140                           (format #f "~aB" partition-size)))
 141     (error "failed to create partition table")))
 142
 143 (define* (populate-store reference-graphs target)
 144   "Populate the store under directory TARGET with the items specified in
 145 REFERENCE-GRAPHS, a list of reference-graph files."
 146   (define store
 147     (string-append target (%store-directory)))
 148
 149   (define (things-to-copy)
 150     ;; Return the list of store files to copy to the image.
 151     (define (graph-from-file file)
 152       (call-with-input-file file read-reference-graph))
 153
 154     (delete-duplicates (append-map graph-from-file reference-graphs)))
 155
 156   (mkdir-p store)
 157   (chmod store #o1775)
 158   (for-each (lambda (thing)
 159               (copy-recursively thing
 160                                 (string-append target thing)))
 161             (things-to-copy)))
 162
 163 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 164
 165 (define* (format-partition partition type
 166                            #:key label)
 167   "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
 168 volume name."
 169   (format #t "creating ~a partition...\n" type)
 170   (unless (zero? (apply system* (string-append "mkfs." type)
 171                         "-F" partition
 172                         (if label
 173                             `("-L" ,label)
 174                             '())))
 175     (error "failed to create partition")))
 176
 177 (define* (initialize-root-partition target-directory
 178                                     #:key copy-closures? register-closures?
 179                                     closures system-directory)
 180   "Initialize the root partition mounted at TARGET-DIRECTORY."
 181   (define target-store
 182     (string-append target-directory (%store-directory)))
 183
 184   (when copy-closures?
 185     ;; Populate the store.
 186     (populate-store (map (cut string-append "/xchg/" <>) closures)
 187                     target-directory))
 188
 189   ;; Populate /dev.
 190   (make-essential-device-nodes #:root target-directory)
 191
 192   ;; Optionally, register the inputs in the image's store.
 193   (when register-closures?
 194     (unless copy-closures?
 195       ;; XXX: 'guix-register' wants to palpate the things it registers, so
 196       ;; bind-mount the store on the target.
 197       (mkdir-p target-store)
 198       (mount (%store-directory) target-store "" MS_BIND))
 199
 200     (display "registering closures...\n")
 201     (for-each (lambda (closure)
 202                 (register-closure target-directory
 203                                   (string-append "/xchg/" closure)))
 204               closures)
 205     (unless copy-closures?
 206       (system* "umount" target-store)))
 207
 208   ;; Add the non-store directories and files.
 209   (display "populating...\n")
 210   (populate-root-file-system system-directory target-directory))
 211
 212 (define* (initialize-hard-disk device
 213                                #:key
 214                                system-directory
 215                                grub.cfg
 216                                disk-image-size
 217                                (file-system-type "ext4")
 218                                file-system-label
 219                                (closures '())
 220                                copy-closures?
 221                                (register-closures? #t))
 222   "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE
 223 partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with
 224 GRUB installed.  If REGISTER-CLOSURES? is true, register all of CLOSURES is
 225 the partition's store.  If COPY-CLOSURES? is true, copy all of CLOSURES to the
 226 partition.  SYSTEM-DIRECTORY is the name of the directory of the 'system'
 227 derivation."
 228   (define target-directory
 229     "/fs")
 230
 231   (define partition
 232     (string-append device "1"))
 233
 234   (initialize-partition-table device
 235                               (- disk-image-size (* 5 (expt 2 20))))
 236
 237   (format-partition partition file-system-type
 238                     #:label file-system-label)
 239
 240   (display "mounting partition...\n")
 241   (mkdir target-directory)
 242   (mount partition target-directory file-system-type)
 243
 244   (initialize-root-partition target-directory
 245                              #:system-directory system-directory
 246                              #:copy-closures? copy-closures?
 247                              #:register-closures? register-closures?
 248                              #:closures closures)
 249
 250   (install-grub grub.cfg device target-directory)
 251
 252   ;; 'guix-register' resets timestamps and everything, so no need to do it
 253   ;; once more in that case.
 254   (unless register-closures?
 255     (reset-timestamps target-directory))
 256
 257   (zero? (system* "umount" target-directory)))
 258
 259 ;;; vm.scm ends here