gnu/system/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013 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 system vm)
  20   #:use-module (guix store)
  21   #:use-module (guix derivations)
  22   #:use-module (guix packages)
  23   #:use-module ((gnu packages base) #:select (%final-inputs guile-final))
  24   #:use-module (gnu packages qemu)
  25   #:use-module (gnu packages parted)
  26   #:use-module (gnu packages grub)
  27   #:use-module (gnu packages linux)
  28   #:use-module (gnu packages linux-initrd)
  29   #:use-module ((gnu packages make-bootstrap)
  30                 #:select (%guile-static-stripped))
  31   #:use-module (srfi srfi-26)
  32   #:use-module (ice-9 match)
  33   #:export (expression->derivation-in-linux-vm
  34             qemu-image))
  35
  36 \f
  37 ;;; Commentary:
  38 ;;;
  39 ;;; Tools to evaluate build expressions within virtual machines.
  40 ;;;
  41 ;;; Code:
  42
  43 (define* (expression->derivation-in-linux-vm store name system exp inputs
  44                                              #:key
  45                                              (linux linux-libre)
  46                                              (initrd qemu-initrd)
  47                                              (qemu qemu-kvm/smb-shares)
  48                                              (env-vars '())
  49                                              (modules '())
  50                                              (guile-for-build
  51                                               (%guile-for-build))
  52
  53                                              (make-disk-image? #f)
  54                                              (disk-image-size
  55                                               (* 100 (expt 2 20))))
  56   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD.  In the
  57 virtual machine, EXP has access to all of INPUTS from the store; it should put
  58 its output files in the `/xchg' directory, which is copied to the derivation's
  59 output when the VM terminates.
  60
  61 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
  62 DISK-IMAGE-SIZE bytes and return it."
  63   (define input-alist
  64     (map (match-lambda
  65           ((input package)
  66            `(,input . ,(package-output store package "out" system)))
  67           ((input package sub-drv)
  68            `(,input . ,(package-output store package sub-drv system))))
  69          inputs))
  70
  71   (define exp*
  72     ;; EXP, but with INPUTS available.
  73     `(let ((%build-inputs ',input-alist))
  74        ,exp))
  75
  76   (define builder
  77     ;; Code that launches the VM that evaluates EXP.
  78     `(begin
  79        (use-modules (guix build utils))
  80
  81        (let ((out     (assoc-ref %outputs "out"))
  82              (cu      (string-append (assoc-ref %build-inputs "coreutils")
  83                                      "/bin"))
  84              (qemu    (string-append (assoc-ref %build-inputs "qemu")
  85                                      "/bin/qemu-system-"
  86                                      (car (string-split ,system #\-))))
  87              (img     (string-append (assoc-ref %build-inputs "qemu")
  88                                      "/bin/qemu-img"))
  89              (linux   (string-append (assoc-ref %build-inputs "linux")
  90                                      "/bzImage"))
  91              (initrd  (string-append (assoc-ref %build-inputs "initrd")
  92                                      "/initrd"))
  93              (builder (assoc-ref %build-inputs "builder")))
  94
  95          ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
  96          ;; directory, so it really needs `rm' in $PATH.
  97          (setenv "PATH" cu)
  98
  99          ,(if make-disk-image?
 100               `(zero? (system* img "create" "image.qcow2"
 101                                ,(number->string disk-image-size)))
 102               '(begin))
 103
 104          (mkdir "xchg")
 105          (and (zero?
 106                (system* qemu "-nographic" "-no-reboot"
 107                         "-net" "nic,model=e1000"
 108                         "-net" (string-append "user,smb=" (getcwd))
 109                         "-kernel" linux
 110                         "-initrd" initrd
 111                         "-append" (string-append "console=ttyS0 --load="
 112                                                  builder)
 113                         ,@(if make-disk-image?
 114                               '("-hda" "image.qcow2")
 115                               '())))
 116               ,(if make-disk-image?
 117                    '(copy-file "image.qcow2"      ; XXX: who mkdir'd OUT?
 118                                out)
 119                    '(begin
 120                       (mkdir out)
 121                       (copy-recursively "xchg" out)))))))
 122
 123   (let ((user-builder (add-text-to-store store "builder-in-linux-vm"
 124                                          (object->string exp*)
 125                                          '()))
 126         (->drv        (cut package-derivation store <> system))
 127         (coreutils    (car (assoc-ref %final-inputs "coreutils"))))
 128     (build-expression->derivation store name system builder
 129                                   `(("qemu" ,(->drv qemu))
 130                                     ("linux" ,(->drv linux))
 131                                     ("initrd" ,(->drv initrd))
 132                                     ("coreutils" ,(->drv coreutils))
 133                                     ("builder" ,user-builder)
 134                                     ,@(map (match-lambda
 135                                             ((name package sub-drv ...)
 136                                              `(,name ,(->drv package)
 137                                                      ,@sub-drv)))
 138                                            inputs))
 139                                   #:env-vars env-vars
 140                                   #:modules `((guix build utils)
 141                                               ,@modules)
 142                                   #:guile-for-build guile-for-build)))
 143
 144 (define* (qemu-image store #:key
 145                      (name "qemu-image")
 146                      (system (%current-system))
 147                      (disk-image-size (* 100 (expt 2 20)))
 148                      (linux linux-libre)
 149                      (initrd qemu-initrd)
 150                      (inputs '()))
 151   "Return a bootable, stand-alone QEMU image."
 152   (expression->derivation-in-linux-vm
 153    store "qemu-image" system
 154    `(let ((parted  (string-append (assoc-ref %build-inputs "parted")
 155                                   "/sbin/parted"))
 156           (mkfs    (string-append (assoc-ref %build-inputs "e2fsprogs")
 157                                   "/sbin/mkfs.ext3"))
 158           (grub    (string-append (assoc-ref %build-inputs "grub")
 159                                   "/sbin/grub-install"))
 160           (umount  (string-append (assoc-ref %build-inputs "util-linux")
 161                                   "/bin/umount")) ; XXX: add to Guile
 162           (initrd  (string-append (assoc-ref %build-inputs "initrd")
 163                                   "/initrd"))
 164           (linux   (string-append (assoc-ref %build-inputs "linux")
 165                                   "/bzImage"))
 166           (makedev (lambda (major minor)
 167                      (+ (* major 256) minor))))
 168
 169       ;; GRUB is full of shell scripts.
 170       (setenv "PATH"
 171               (string-append (dirname grub) ":"
 172                              (assoc-ref %build-inputs "coreutils") "/bin:"
 173                              (assoc-ref %build-inputs "findutils") "/bin:"
 174                              (assoc-ref %build-inputs "sed") "/bin:"
 175                              (assoc-ref %build-inputs "grep") "/bin:"
 176                              (assoc-ref %build-inputs "gawk") "/bin"))
 177
 178       (display "creating partition table...\n")
 179       (mknod "/dev/vda" 'block-special #o644 (makedev 8 0))
 180       (and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
 181                            "mkpart" "primary" "ext2" "1MiB"
 182                            ,(format #f "~aB"
 183                                     (- disk-image-size
 184                                        (* 5 (expt 2 20))))))
 185            (begin
 186              (display "creating ext3 partition...\n")
 187              (mknod "/dev/vda1" 'block-special #o644 (makedev 8 1))
 188              (and (zero? (system* mkfs "-F" "/dev/vda1"))
 189                   (begin
 190                     (display "mounting partition...\n")
 191                     (mkdir "/fs")
 192                     (mount "/dev/vda1" "/fs" "ext3")
 193                     (mkdir "/fs/boot")
 194                     (mkdir "/fs/boot/grub")
 195                     (copy-file linux "/fs/boot/bzImage")
 196                     (copy-file initrd "/fs/boot/initrd")
 197                     (call-with-output-file "/fs/boot/grub/grub.cfg"
 198                       (lambda (p)
 199                         (display "
 200 set timeout=10
 201 search.file /boot/bzImage
 202
 203 menuentry \"Boot-to-Guile! Happy Birthday Guile 2.0! (Guile, Guix & co.)\" {
 204   linux /boot/bzImage --repl
 205   initrd /boot/initrd
 206 }" p)))
 207                     (and (zero?
 208                           (system* grub "--no-floppy"
 209                                    "--boot-directory" "/fs/boot"
 210                                    "/dev/vda"))
 211                          (zero?
 212                           (system* umount "/fs"))))))))
 213    `(("parted" ,parted)
 214      ("grub" ,grub)
 215      ("e2fsprogs" ,e2fsprogs)
 216      ("linux" ,linux-libre)
 217      ("initrd" ,qemu-initrd)
 218
 219      ;; For shell scripts.
 220      ("sed" ,(car (assoc-ref %final-inputs "sed")))
 221      ("grep" ,(car (assoc-ref %final-inputs "grep")))
 222      ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
 223      ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
 224      ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
 225      ("util-linux" ,util-linux))
 226    #:make-disk-image? #t
 227    #:disk-image-size disk-image-size))
 228
 229 \f
 230 ;;;
 231 ;;; Guile 2.0 potluck examples.
 232 ;;;
 233
 234 (define (example1)
 235   (let ((store #f))
 236     (dynamic-wind
 237       (lambda ()
 238         (set! store (open-connection)))
 239       (lambda ()
 240         (parameterize ((%guile-for-build (package-derivation store guile-final)))
 241           (expression->derivation-in-linux-vm
 242            store "vm-test" (%current-system)
 243            '(begin
 244               (display "hello from boot!\n")
 245               (call-with-output-file "/xchg/hello"
 246                 (lambda (p)
 247                   (display "world" p))))
 248            '())))
 249       (lambda ()
 250         (close-connection store)))))
 251
 252 (define (example2)
 253   (let ((store #f))
 254     (dynamic-wind
 255       (lambda ()
 256         (set! store (open-connection)))
 257       (lambda ()
 258         (parameterize ((%guile-for-build (package-derivation store guile-final)))
 259           (qemu-image store #:disk-image-size (* 30 (expt 2 20)))))
 260       (lambda ()
 261         (close-connection store)))))
 262
 263 ;;; vm.scm ends here