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