gnu/system/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 system vm)
  20   #:use-module (guix config)
  21   #:use-module (guix store)
  22   #:use-module (guix derivations)
  23   #:use-module (guix packages)
  24   #:use-module (guix monads)
  25   #:use-module ((gnu packages base)
  26                 #:select (%final-inputs
  27                           guile-final gcc-final glibc-final
  28                           ld-wrapper binutils-final
  29                           coreutils findutils grep sed tzdata))
  30   #:use-module (gnu packages guile)
  31   #:use-module (gnu packages bash)
  32   #:use-module (gnu packages less)
  33   #:use-module (gnu packages qemu)
  34   #:use-module (gnu packages parted)
  35   #:use-module (gnu packages zile)
  36   #:use-module (gnu packages grub)
  37   #:use-module (gnu packages linux)
  38   #:use-module (gnu packages package-management)
  39   #:use-module ((gnu packages make-bootstrap)
  40                 #:select (%guile-static-stripped))
  41   #:use-module (gnu packages admin)
  42
  43   #:use-module (gnu system shadow)
  44   #:use-module (gnu system linux)
  45   #:use-module (gnu system linux-initrd)
  46   #:use-module (gnu system grub)
  47   #:use-module (gnu system dmd)
  48   #:use-module (gnu system)
  49
  50   #:use-module (srfi srfi-1)
  51   #:use-module (srfi srfi-26)
  52   #:use-module (ice-9 match)
  53
  54   #:export (expression->derivation-in-linux-vm
  55             qemu-image
  56             system-qemu-image
  57             system-qemu-image/shared-store
  58             system-qemu-image/shared-store-script))
  59
  60 \f
  61 ;;; Commentary:
  62 ;;;
  63 ;;; Tools to evaluate build expressions within virtual machines.
  64 ;;;
  65 ;;; Code:
  66
  67 (define* (expression->derivation-in-linux-vm name exp
  68                                              #:key
  69                                              (system (%current-system))
  70                                              (inputs '())
  71                                              (linux linux-libre)
  72                                              initrd
  73                                              (qemu qemu/smb-shares)
  74                                              (env-vars '())
  75                                              (modules '())
  76                                              (guile-for-build
  77                                               (%guile-for-build))
  78
  79                                              (make-disk-image? #f)
  80                                              (references-graphs #f)
  81                                              (disk-image-size
  82                                               (* 100 (expt 2 20))))
  83   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
  84 derivation).  In the virtual machine, EXP has access to all of INPUTS from the
  85 store; it should put its output files in the `/xchg' directory, which is
  86 copied to the derivation's output when the VM terminates.
  87
  88 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
  89 DISK-IMAGE-SIZE bytes and return it.
  90
  91 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
  92 pairs, as for `derivation'.  The files containing the reference graphs are
  93 made available under the /xchg CIFS share."
  94   ;; FIXME: Allow use of macros from other modules, as done in
  95   ;; `build-expression->derivation'.
  96
  97   (define input-alist
  98     (with-monad %store-monad
  99       (map (match-lambda
 100             ((input (? package? package))
 101              (mlet %store-monad ((out (package-file package #:system system)))
 102                (return `(,input . ,out))))
 103             ((input (? package? package) sub-drv)
 104              (mlet %store-monad ((out (package-file package
 105                                                     #:output sub-drv
 106                                                     #:system system)))
 107                (return `(,input . ,out))))
 108             ((input (? derivation? drv))
 109              (return `(,input . ,(derivation->output-path drv))))
 110             ((input (? derivation? drv) sub-drv)
 111              (return `(,input . ,(derivation->output-path drv sub-drv))))
 112             ((input (and (? string?) (? store-path?) file))
 113              (return `(,input . ,file))))
 114            inputs)))
 115
 116   (define builder
 117     ;; Code that launches the VM that evaluates EXP.
 118     `(let ()
 119        (use-modules (guix build utils)
 120                     (srfi srfi-1)
 121                     (ice-9 rdelim))
 122
 123        (let ((out     (assoc-ref %outputs "out"))
 124              (cu      (string-append (assoc-ref %build-inputs "coreutils")
 125                                      "/bin"))
 126              (qemu    (string-append (assoc-ref %build-inputs "qemu")
 127                                      "/bin/qemu-system-"
 128                                      (car (string-split ,system #\-))))
 129              (img     (string-append (assoc-ref %build-inputs "qemu")
 130                                      "/bin/qemu-img"))
 131              (linux   (string-append (assoc-ref %build-inputs "linux")
 132                                      "/bzImage"))
 133              (initrd  (string-append (assoc-ref %build-inputs "initrd")
 134                                      "/initrd"))
 135              (builder (assoc-ref %build-inputs "builder")))
 136
 137          ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
 138          ;; directory, so it really needs `rm' in $PATH.
 139          (setenv "PATH" cu)
 140
 141          ,(if make-disk-image?
 142               `(zero? (system* img "create" "-f" "qcow2" "image.qcow2"
 143                                ,(number->string disk-image-size)))
 144               '(begin))
 145
 146          (mkdir "xchg")
 147
 148          ;; Copy the reference-graph files under xchg/ so EXP can access it.
 149          (begin
 150            ,@(match references-graphs
 151                (((graph-files . _) ...)
 152                 (map (lambda (file)
 153                        `(copy-file ,file
 154                                    ,(string-append "xchg/" file)))
 155                      graph-files))
 156                (#f '())))
 157
 158          (and (zero?
 159                (system* qemu "-enable-kvm" "-nographic" "-no-reboot"
 160                         "-net" "nic,model=e1000"
 161                         "-net" (string-append "user,smb=" (getcwd))
 162                         "-kernel" linux
 163                         "-initrd" initrd
 164                         "-append" (string-append "console=ttyS0 --load="
 165                                                  builder)
 166                         ,@(if make-disk-image?
 167                               '("-hda" "image.qcow2")
 168                               '())))
 169               ,(if make-disk-image?
 170                    '(copy-file "image.qcow2"      ; XXX: who mkdir'd OUT?
 171                                out)
 172                    '(begin
 173                       (mkdir out)
 174                       (copy-recursively "xchg" out)))))))
 175
 176   (mlet* %store-monad
 177       ((input-alist  (sequence %store-monad input-alist))
 178        (exp* ->      `(let ((%build-inputs ',input-alist))
 179                         ,exp))
 180        (user-builder (text-file "builder-in-linux-vm"
 181                                 (object->string exp*)))
 182        (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
 183        (initrd       (if initrd                   ; use the default initrd?
 184                          (return initrd)
 185                          (qemu-initrd #:guile-modules-in-chroot? #t)))
 186        (inputs       (lower-inputs `(("qemu" ,qemu)
 187                                      ("linux" ,linux)
 188                                      ("initrd" ,initrd)
 189                                      ("coreutils" ,coreutils)
 190                                      ("builder" ,user-builder)
 191                                      ,@inputs))))
 192     (derivation-expression name builder
 193                            ;; TODO: Require the "kvm" feature.
 194                            #:system system
 195                            #:inputs inputs
 196                            #:env-vars env-vars
 197                            #:modules (delete-duplicates
 198                                       `((guix build utils)
 199                                         ,@modules))
 200                            #:guile-for-build guile-for-build
 201                            #:references-graphs references-graphs)))
 202
 203 (define* (qemu-image #:key
 204                      (name "qemu-image")
 205                      (system (%current-system))
 206                      (disk-image-size (* 100 (expt 2 20)))
 207                      grub-configuration
 208                      (initialize-store? #f)
 209                      (populate #f)
 210                      (inputs '())
 211                      (inputs-to-copy '()))
 212   "Return a bootable, stand-alone QEMU image.  The returned image is a full
 213 disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
 214 configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 215
 216 INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
 217 into the image being built.  When INITIALIZE-STORE? is true, initialize the
 218 store database in the image so that Guix can be used in the image.
 219
 220 POPULATE is a list of directives stating directories or symlinks to be created
 221 in the disk image partition.  It is evaluated once the image has been
 222 populated with INPUTS-TO-COPY.  It can be used to provide additional files,
 223 such as /etc files."
 224   (define (input->name+derivation tuple)
 225     (with-monad %store-monad
 226       (match tuple
 227         ((name (? package? package))
 228          (mlet %store-monad ((drv (package->derivation package system)))
 229            (return `(,name . ,(derivation->output-path drv)))))
 230         ((name (? package? package) sub-drv)
 231          (mlet %store-monad ((drv (package->derivation package system)))
 232            (return `(,name . ,(derivation->output-path drv sub-drv)))))
 233         ((name (? derivation? drv))
 234          (return `(,name . ,(derivation->output-path drv))))
 235         ((name (? derivation? drv) sub-drv)
 236          (return `(,name . ,(derivation->output-path drv sub-drv))))
 237         ((input (and (? string?) (? store-path?) file))
 238          (return `(,input . ,file))))))
 239
 240   (mlet %store-monad
 241       ((graph (sequence %store-monad
 242                         (map input->name+derivation inputs-to-copy))))
 243    (expression->derivation-in-linux-vm
 244     "qemu-image"
 245     `(let ()
 246        (use-modules (ice-9 rdelim)
 247                     (srfi srfi-1)
 248                     (guix build utils)
 249                     (guix build linux-initrd))
 250
 251        (let ((parted  (string-append (assoc-ref %build-inputs "parted")
 252                                      "/sbin/parted"))
 253              (mkfs    (string-append (assoc-ref %build-inputs "e2fsprogs")
 254                                      "/sbin/mkfs.ext3"))
 255              (grub    (string-append (assoc-ref %build-inputs "grub")
 256                                      "/sbin/grub-install"))
 257              (umount  (string-append (assoc-ref %build-inputs "util-linux")
 258                                      "/bin/umount")) ; XXX: add to Guile
 259              (grub.cfg ,grub-configuration))
 260
 261          (define (read-reference-graph port)
 262            ;; Return a list of store paths from the reference graph at PORT.
 263            ;; The data at PORT is the format produced by #:references-graphs.
 264            (let loop ((line   (read-line port))
 265                       (result '()))
 266              (cond ((eof-object? line)
 267                     (delete-duplicates result))
 268                    ((string-prefix? "/" line)
 269                     (loop (read-line port)
 270                           (cons line result)))
 271                    (else
 272                     (loop (read-line port)
 273                           result)))))
 274
 275          (define (things-to-copy)
 276            ;; Return the list of store files to copy to the image.
 277            (define (graph-from-file file)
 278              (call-with-input-file file
 279                read-reference-graph))
 280
 281            ,(match inputs-to-copy
 282               (((graph-files . _) ...)
 283                `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
 284                                            graph-files))
 285                        (paths       (append-map graph-from-file graph-files)))
 286                   (delete-duplicates paths)))
 287               (#f ''())))
 288
 289          ;; GRUB is full of shell scripts.
 290          (setenv "PATH"
 291                  (string-append (dirname grub) ":"
 292                                 (assoc-ref %build-inputs "coreutils") "/bin:"
 293                                 (assoc-ref %build-inputs "findutils") "/bin:"
 294                                 (assoc-ref %build-inputs "sed") "/bin:"
 295                                 (assoc-ref %build-inputs "grep") "/bin:"
 296                                 (assoc-ref %build-inputs "gawk") "/bin"))
 297
 298          (display "creating partition table...\n")
 299          (and (zero? (system* parted "/dev/sda" "mklabel" "msdos"
 300                               "mkpart" "primary" "ext2" "1MiB"
 301                               ,(format #f "~aB"
 302                                        (- disk-image-size
 303                                           (* 5 (expt 2 20))))))
 304               (begin
 305                 (display "creating ext3 partition...\n")
 306                 (and (zero? (system* mkfs "-F" "/dev/sda1"))
 307                      (let ((store (string-append "/fs" ,%store-directory)))
 308                        (display "mounting partition...\n")
 309                        (mkdir "/fs")
 310                        (mount "/dev/sda1" "/fs" "ext3")
 311                        (mkdir-p "/fs/boot/grub")
 312                        (symlink grub.cfg "/fs/boot/grub/grub.cfg")
 313
 314                        ;; Populate the image's store.
 315                        (mkdir-p store)
 316                        (chmod store #o1775)
 317                        (for-each (lambda (thing)
 318                                    (copy-recursively thing
 319                                                      (string-append "/fs"
 320                                                                     thing)))
 321                                  (things-to-copy))
 322
 323                        ;; Populate /dev.
 324                        (make-essential-device-nodes #:root "/fs")
 325
 326                        ;; Optionally, register the inputs in the image's store.
 327                        (let* ((guix     (assoc-ref %build-inputs "guix"))
 328                               (register (and guix
 329                                              (string-append guix
 330                                                             "/sbin/guix-register"))))
 331                          ,@(if initialize-store?
 332                                (match inputs-to-copy
 333                                  (((graph-files . _) ...)
 334                                   (map (lambda (closure)
 335                                          `(system* register "--prefix" "/fs"
 336                                                    ,(string-append "/xchg/"
 337                                                                    closure)))
 338                                        graph-files)))
 339                                '(#f)))
 340
 341                        ;; Evaluate the POPULATE directives.
 342                        ,@(let loop ((directives populate)
 343                                     (statements '()))
 344                            (match directives
 345                              (()
 346                               (reverse statements))
 347                              ((('directory name) rest ...)
 348                               (loop rest
 349                                     (cons `(mkdir-p ,(string-append "/fs" name))
 350                                           statements)))
 351                              ((('directory name uid gid) rest ...)
 352                               (let ((dir (string-append "/fs" name)))
 353                                 (loop rest
 354                                       (cons* `(chown ,dir ,uid ,gid)
 355                                              `(mkdir-p ,dir)
 356                                              statements))))
 357                              (((new '-> old) rest ...)
 358                               (loop rest
 359                                     (cons `(symlink ,old
 360                                                     ,(string-append "/fs" new))
 361                                           statements)))))
 362
 363                        (and=> (assoc-ref %build-inputs "populate")
 364                               (lambda (populate)
 365                                 (chdir "/fs")
 366                                 (primitive-load populate)
 367                                 (chdir "/")))
 368
 369                        (display "clearing file timestamps...\n")
 370                        (for-each (lambda (file)
 371                                    (let ((s (lstat file)))
 372                                      ;; XXX: Guile uses libc's 'utime' function
 373                                      ;; (not 'futime'), so the timestamp of
 374                                      ;; symlinks cannot be changed, and there
 375                                      ;; are symlinks here pointing to
 376                                      ;; /nix/store, which is the host,
 377                                      ;; read-only store.
 378                                      (unless (eq? (stat:type s) 'symlink)
 379                                        (utime file 0 0 0 0))))
 380                                  (find-files "/fs" ".*"))
 381
 382                        (and (zero?
 383                              (system* grub "--no-floppy"
 384                                       "--boot-directory" "/fs/boot"
 385                                       "/dev/sda"))
 386                             (zero? (system* umount "/fs"))
 387                             (reboot))))))))
 388     #:system system
 389     #:inputs `(("parted" ,parted)
 390                ("grub" ,grub)
 391                ("e2fsprogs" ,e2fsprogs)
 392
 393                ;; For shell scripts.
 394                ("sed" ,(car (assoc-ref %final-inputs "sed")))
 395                ("grep" ,(car (assoc-ref %final-inputs "grep")))
 396                ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
 397                ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
 398                ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
 399                ("util-linux" ,util-linux)
 400
 401                ,@(if initialize-store?
 402                      `(("guix" ,guix))
 403                      '())
 404
 405                ,@inputs-to-copy)
 406     #:make-disk-image? #t
 407     #:disk-image-size disk-image-size
 408     #:references-graphs graph
 409     #:modules '((guix build utils)
 410                 (guix build linux-initrd)))))
 411
 412 \f
 413 ;;;
 414 ;;; Stand-alone VM image.
 415 ;;;
 416
 417 (define %demo-operating-system
 418   (operating-system
 419    (host-name "gnu")
 420    (timezone "Europe/Paris")
 421    (locale "en_US.UTF-8")
 422    (users (list (user-account
 423                  (name "guest")
 424                  (password "")
 425                  (uid 1000) (gid 100)
 426                  (comment "Guest of GNU")
 427                  (home-directory "/home/guest"))))
 428    (packages (list coreutils
 429                    bash
 430                    guile-2.0
 431                    dmd
 432                    gcc-final
 433                    ld-wrapper                    ; must come before BINUTILS
 434                    binutils-final
 435                    glibc-final
 436                    inetutils
 437                    findutils
 438                    grep
 439                    sed
 440                    procps
 441                    psmisc
 442                    zile
 443                    less
 444                    tzdata
 445                    guix))))
 446
 447 (define (operating-system-build-gid os)
 448   "Return as a monadic value the group id for build users of OS, or #f."
 449   (anym %store-monad
 450         (lambda (service)
 451           (and (equal? '(guix-daemon)
 452                        (service-provision service))
 453                (match (service-user-groups service)
 454                  ((group)
 455                   (user-group-id group)))))
 456         (operating-system-services os)))
 457
 458 (define (operating-system-default-contents os)
 459   "Return a list of directives suitable for 'system-qemu-image' describing the
 460 basic contents of the root file system of OS."
 461   (mlet* %store-monad ((os-drv         (operating-system-derivation os))
 462                        (os-dir      -> (derivation->output-path os-drv))
 463                        (build-user-gid (operating-system-build-gid os)))
 464     (return `((directory "/nix/store" 0 ,(or build-user-gid 0))
 465               (directory "/etc")
 466               (directory "/var/log")                     ; for dmd
 467               (directory "/var/run/nscd")
 468               (directory "/var/nix/gcroots")
 469               ("/var/nix/gcroots/system" -> ,os-dir)
 470               (directory "/tmp")
 471               (directory "/var/nix/profiles/per-user/root" 0 0)
 472               (directory "/var/nix/profiles/per-user/guest"
 473                          1000 100)
 474               (directory "/home/guest" 1000 100)))))
 475
 476 (define* (system-qemu-image #:optional (os %demo-operating-system)
 477                             #:key (disk-image-size (* 900 (expt 2 20))))
 478   "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
 479 system as described by OS."
 480   (mlet* %store-monad
 481       ((os-drv      (operating-system-derivation os))
 482        (os-dir   -> (derivation->output-path os-drv))
 483        (grub.cfg -> (string-append os-dir "/grub.cfg"))
 484        (populate    (operating-system-default-contents os)))
 485     (qemu-image  #:grub-configuration grub.cfg
 486                  #:populate populate
 487                  #:disk-image-size disk-image-size
 488                  #:initialize-store? #t
 489                  #:inputs-to-copy `(("system" ,os-drv)))))
 490
 491 (define* (system-qemu-image/shared-store
 492           #:optional (os %demo-operating-system)
 493           #:key (disk-image-size (* 15 (expt 2 20))))
 494   "Return a derivation that builds a QEMU image of OS that shares its store
 495 with the host."
 496   (mlet* %store-monad
 497       ((os-drv      (operating-system-derivation os))
 498        (os-dir   -> (derivation->output-path os-drv))
 499        (grub.cfg -> (string-append os-dir "/grub.cfg"))
 500        (populate    (operating-system-default-contents os)))
 501     ;; TODO: Initialize the database so Guix can be used in the guest.
 502     (qemu-image #:grub-configuration grub.cfg
 503                 #:populate populate
 504                 #:disk-image-size disk-image-size)))
 505
 506 (define* (system-qemu-image/shared-store-script
 507           #:optional (os %demo-operating-system)
 508           #:key
 509           (qemu (package (inherit qemu)
 510                   ;; FIXME/TODO: Use 9p instead of this hack.
 511                   (source (package-source qemu/smb-shares))))
 512           (graphic? #t))
 513   "Return a derivation that builds a script to run a virtual machine image of
 514 OS that shares its store with the host."
 515   (let* ((initrd (qemu-initrd #:mounts `((cifs "/store" ,(%store-prefix)))
 516                               #:volatile-root? #t))
 517          (os     (operating-system (inherit os) (initrd initrd))))
 518     (define builder
 519       (mlet %store-monad ((image  (system-qemu-image/shared-store os))
 520                           (qemu   (package-file qemu
 521                                                 "bin/qemu-system-x86_64"))
 522                           (bash   (package-file bash "bin/sh"))
 523                           (kernel (package-file (operating-system-kernel os)
 524                                                 "bzImage"))
 525                           (initrd initrd)
 526                           (os-drv (operating-system-derivation os)))
 527         (return `(let ((out (assoc-ref %outputs "out")))
 528                    (call-with-output-file out
 529                      (lambda (port)
 530                        (display
 531                         (string-append "#!" ,bash "
 532 # TODO: -virtfs local,path=XXX,security_model=none,mount_tag=store
 533 exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \
 534   -net user,smb=$PWD \
 535   -kernel " ,kernel " -initrd "
 536   ,(string-append (derivation->output-path initrd) "/initrd") " \
 537 -append \"" ,(if graphic? "" "console=ttyS0 ")
 538 "--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \
 539   -drive file=" ,(derivation->output-path image)
 540   ",if=virtio,cache=writeback,werror=report,readonly\n")
 541                         port)))
 542                    (chmod out #o555)
 543                    #t))))
 544
 545     (mlet %store-monad ((image   (system-qemu-image/shared-store os))
 546                         (initrd  initrd)
 547                         (qemu    (package->derivation qemu))
 548                         (bash    (package->derivation bash))
 549                         (os      (operating-system-derivation os))
 550                         (builder builder))
 551       (derivation-expression "run-vm.sh" builder
 552                              #:inputs `(("qemu" ,qemu)
 553                                         ("image" ,image)
 554                                         ("bash" ,bash)
 555                                         ("initrd" ,initrd)
 556                                         ("os" ,os))))))
 557
 558 ;;; vm.scm ends here