mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
vm: Add (guix build vm) module.
* guix/build/vm.scm: New file. * Makefile.am (MODULES): Add it. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Use it.
This commit is contained in:
Ludovic Courtès
parent
772d63658e
commit
e1a87b904a
3 changed files with 114 additions and 55 deletions
|
|
@ -69,6 +69,7 @@ MODULES = \
|
|||
guix/build/pull.scm \
|
||||
guix/build/rpath.scm \
|
||||
guix/build/svn.scm \
|
||||
guix/build/vm.scm \
|
||||
guix/packages.scm \
|
||||
guix/snix.scm \
|
||||
guix/scripts/download.scm \
|
||||
|
|
|
|||
|
|
@ -119,67 +119,27 @@ (define builder
|
|||
;; Code that launches the VM that evaluates EXP.
|
||||
`(let ()
|
||||
(use-modules (guix build utils)
|
||||
(srfi srfi-1)
|
||||
(ice-9 rdelim))
|
||||
(guix build vm))
|
||||
|
||||
(let ((out (assoc-ref %outputs "out"))
|
||||
(cu (string-append (assoc-ref %build-inputs "coreutils")
|
||||
"/bin"))
|
||||
(qemu (string-append (assoc-ref %build-inputs "qemu")
|
||||
"/bin/qemu-system-"
|
||||
(car (string-split ,system #\-))))
|
||||
(img (string-append (assoc-ref %build-inputs "qemu")
|
||||
"/bin/qemu-img"))
|
||||
(linux (string-append (assoc-ref %build-inputs "linux")
|
||||
(let ((linux (string-append (assoc-ref %build-inputs "linux")
|
||||
"/bzImage"))
|
||||
(initrd (string-append (assoc-ref %build-inputs "initrd")
|
||||
"/initrd"))
|
||||
(builder (assoc-ref %build-inputs "builder")))
|
||||
(builder (assoc-ref %build-inputs "builder"))
|
||||
(graphs ',(match references-graphs
|
||||
(((graph-files . _) ...) graph-files)
|
||||
(_ #f))))
|
||||
|
||||
;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
|
||||
;; directory, so it really needs `rm' in $PATH.
|
||||
(setenv "PATH" cu)
|
||||
(set-path-environment-variable "PATH" '("bin")
|
||||
(map cdr %build-inputs))
|
||||
|
||||
,(if make-disk-image?
|
||||
`(zero? (system* img "create" "-f" "qcow2" "image.qcow2"
|
||||
,(number->string disk-image-size)))
|
||||
'(begin))
|
||||
|
||||
(mkdir "xchg")
|
||||
|
||||
;; Copy the reference-graph files under xchg/ so EXP can access it.
|
||||
(begin
|
||||
,@(match references-graphs
|
||||
(((graph-files . _) ...)
|
||||
(map (lambda (file)
|
||||
`(copy-file ,file
|
||||
,(string-append "xchg/" file)))
|
||||
graph-files))
|
||||
(#f '())))
|
||||
|
||||
(and (zero?
|
||||
(system* qemu "-enable-kvm" "-nographic" "-no-reboot"
|
||||
"-m" ,(number->string memory-size)
|
||||
"-net" "nic,model=virtio"
|
||||
"-virtfs"
|
||||
,(string-append "local,id=store_dev,path=" (%store-prefix)
|
||||
",security_model=none,mount_tag=store")
|
||||
"-virtfs"
|
||||
,(string-append "local,id=xchg_dev,path=xchg"
|
||||
",security_model=none,mount_tag=xchg")
|
||||
"-kernel" linux
|
||||
"-initrd" initrd
|
||||
"-append" (string-append "console=ttyS0 --load="
|
||||
builder)
|
||||
,@(if make-disk-image?
|
||||
'("-hda" "image.qcow2")
|
||||
'())))
|
||||
,(if make-disk-image?
|
||||
'(copy-file "image.qcow2" ; XXX: who mkdir'd OUT?
|
||||
out)
|
||||
'(begin
|
||||
(mkdir out)
|
||||
(copy-recursively "xchg" out)))))))
|
||||
(load-in-linux-vm builder
|
||||
#:output (assoc-ref %outputs "out")
|
||||
#:linux linux #:initrd initrd
|
||||
#:memory-size ,memory-size
|
||||
#:make-disk-image? ,make-disk-image?
|
||||
#:disk-image-size ,disk-image-size
|
||||
#:references-graphs graphs))))
|
||||
|
||||
(mlet* %store-monad
|
||||
((input-alist (sequence %store-monad input-alist))
|
||||
|
|
@ -206,6 +166,7 @@ (define builder
|
|||
#:env-vars env-vars
|
||||
#:modules (delete-duplicates
|
||||
`((guix build utils)
|
||||
(guix build vm)
|
||||
,@modules))
|
||||
#:guile-for-build guile-for-build
|
||||
#:references-graphs references-graphs)))
|
||||
|
|
|
|||
97
guix/build/vm.scm
Normal file
97
guix/build/vm.scm
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix build vm)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (guix build utils)
|
||||
#:export (load-in-linux-vm))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This module provides supporting code to run virtual machines and build
|
||||
;;; virtual machine images using QEMU.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define (qemu-command)
|
||||
"Return the default name of the QEMU command for the current host."
|
||||
(string-append "qemu-system-"
|
||||
(substring %host-type 0
|
||||
(string-index %host-type #\-))))
|
||||
|
||||
|
||||
(define* (load-in-linux-vm builder
|
||||
#:key
|
||||
output
|
||||
(qemu (qemu-command)) (memory-size 512)
|
||||
linux initrd
|
||||
make-disk-image? (disk-image-size 100)
|
||||
(references-graphs '()))
|
||||
"Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
|
||||
the result to OUTPUT.
|
||||
|
||||
When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
|
||||
DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access
|
||||
it via /dev/hda.
|
||||
|
||||
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
|
||||
the #:references-graphs parameter of 'derivation'."
|
||||
|
||||
(when make-disk-image?
|
||||
(unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2"
|
||||
(number->string disk-image-size)))
|
||||
(error "qemu-img failed")))
|
||||
|
||||
(mkdir "xchg")
|
||||
|
||||
(match references-graphs
|
||||
((graph-files ...)
|
||||
;; Copy the reference-graph files under xchg/ so EXP can access it.
|
||||
(map (lambda (file)
|
||||
(copy-file file (string-append "xchg/" file)))
|
||||
graph-files))
|
||||
(_ #f))
|
||||
|
||||
(unless (zero?
|
||||
(apply system* qemu "-enable-kvm" "-nographic" "-no-reboot"
|
||||
"-m" (number->string memory-size)
|
||||
"-net" "nic,model=virtio"
|
||||
"-virtfs"
|
||||
(string-append "local,id=store_dev,path="
|
||||
(%store-directory)
|
||||
",security_model=none,mount_tag=store")
|
||||
"-virtfs"
|
||||
(string-append "local,id=xchg_dev,path=xchg"
|
||||
",security_model=none,mount_tag=xchg")
|
||||
"-kernel" linux
|
||||
"-initrd" initrd
|
||||
"-append" (string-append "console=ttyS0 --load="
|
||||
builder)
|
||||
(if make-disk-image?
|
||||
'("-hda" "image.qcow2")
|
||||
'())))
|
||||
(error "qemu failed" qemu))
|
||||
|
||||
(if make-disk-image?
|
||||
(copy-file "image.qcow2" ; XXX: who mkdir'd OUTPUT?
|
||||
output)
|
||||
(begin
|
||||
(mkdir output)
|
||||
(copy-recursively "xchg" output))))
|
||||
|
||||
;;; vm.scm ends here
|
||||
Loading…
Reference in a new issue