summaryrefslogtreecommitdiff
path: root/gnu/tests/virtualization.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/tests/virtualization.scm')
-rw-r--r--gnu/tests/virtualization.scm176
1 files changed, 140 insertions, 36 deletions
diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm
index 6ca88cbacd..c8b42eb1db 100644
--- a/gnu/tests/virtualization.scm
+++ b/gnu/tests/virtualization.scm
@@ -33,6 +33,7 @@
#:use-module (gnu services)
#:use-module (gnu services dbus)
#:use-module (gnu services networking)
+ #:use-module (gnu services ssh)
#:use-module (gnu services virtualization)
#:use-module (gnu packages ssh)
#:use-module (gnu packages virtualization)
@@ -42,7 +43,8 @@
#:use-module (guix modules)
#:export (%test-libvirt
%test-qemu-guest-agent
- %test-childhurd))
+ %test-childhurd
+ %test-build-vm))
;;;
@@ -241,6 +243,36 @@
(password "")) ;empty password
%base-user-accounts))))))))
+(define* (run-command-over-ssh command
+ #:key (port 10022) (user "test"))
+ "Return a program that runs COMMAND over SSH and prints the result on standard
+output."
+ (define run
+ (with-extensions (list guile-ssh)
+ #~(begin
+ (use-modules (ssh session)
+ (ssh auth)
+ (ssh popen)
+ (ice-9 match)
+ (ice-9 textual-ports))
+
+ (let ((session (make-session #:user #$user
+ #:port #$port
+ #:host "localhost"
+ #:timeout 120
+ #:log-verbosity 'rare)))
+ (match (connect! session)
+ ('ok
+ (userauth-password! session "")
+ (display
+ (get-string-all
+ (open-remote-input-pipe* session #$@command))))
+ (status
+ (error "could not connect to guest over SSH"
+ session status)))))))
+
+ (program-file "run-command-over-ssh" run))
+
(define (run-childhurd-test)
(define (import-module? module)
;; This module is optional and depends on Guile-Gcrypt, do skip it.
@@ -261,36 +293,6 @@
(operating-system os)
(memory-size (* 1024 3))))
- (define (run-command-over-ssh . command)
- ;; Program that runs COMMAND over SSH and prints the result on standard
- ;; output.
- (let ()
- (define run
- (with-extensions (list guile-ssh)
- #~(begin
- (use-modules (ssh session)
- (ssh auth)
- (ssh popen)
- (ice-9 match)
- (ice-9 textual-ports))
-
- (let ((session (make-session #:user "test"
- #:port 10022
- #:host "localhost"
- #:timeout 120
- #:log-verbosity 'rare)))
- (match (connect! session)
- ('ok
- (userauth-password! session "")
- (display
- (get-string-all
- (open-remote-input-pipe* session #$@command))))
- (status
- (error "could not connect to childhurd over SSH"
- session status)))))))
-
- (program-file "run-command-over-ssh" run)))
-
(define test
(with-imported-modules '((gnu build marionette))
#~(begin
@@ -356,21 +358,24 @@
;; 'uname' command.
(marionette-eval
'(begin
- (use-modules (ice-9 popen))
+ (use-modules (ice-9 popen)
+ (ice-9 textual-ports))
(get-string-all
- (open-input-pipe #$(run-command-over-ssh "uname" "-on"))))
+ (open-input-pipe #$(run-command-over-ssh '("uname" "-on")))))
marionette))
(test-assert "guix-daemon up and running"
(let ((drv (marionette-eval
'(begin
- (use-modules (ice-9 popen))
+ (use-modules (ice-9 popen)
+ (ice-9 textual-ports))
(get-string-all
(open-input-pipe
- #$(run-command-over-ssh "guix" "build" "coreutils"
- "--no-grafts" "-d"))))
+ #$(run-command-over-ssh
+ '("guix" "build" "coreutils"
+ "--no-grafts" "-d")))))
marionette)))
;; We cannot compare the .drv with (raw-derivation-file
;; coreutils) on the host: they may differ due to fixed-output
@@ -416,3 +421,102 @@
"Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making
sure that the childhurd boots and runs its SSH server.")
(value (run-childhurd-test))))
+
+
+;;;
+;;; Virtual build machine.
+;;;
+
+(define %build-vm-os
+ (simple-operating-system
+ (service virtual-build-machine-service-type
+ (virtual-build-machine
+ (cpu-count 1)
+ (memory-size (* 1 1024))))))
+
+(define (run-build-vm-test)
+ (define (import-module? module)
+ ;; This module is optional and depends on Guile-Gcrypt, do skip it.
+ (and (guix-module-name? module)
+ (not (equal? module '(guix store deduplication)))))
+
+ (define os
+ (marionette-operating-system
+ %build-vm-os
+ #:imported-modules (source-module-closure
+ '((gnu services herd)
+ (gnu build install))
+ #:select? import-module?)))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (memory-size (* 1024 3))))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (gnu build marionette)
+ (srfi srfi-64)
+ (ice-9 match))
+
+ (define marionette
+ ;; Emulate as much as the host CPU supports so that, possibly, KVM
+ ;; is available inside as well ("nested KVM"), provided
+ ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it.
+ (make-marionette (list #$vm "-cpu" "max")))
+
+ (test-runner-current (system-test-runner #$output))
+ (test-begin "build-vm")
+
+ (test-assert "service running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd)
+ (ice-9 match))
+
+ (start-service 'build-vm))
+ marionette))
+
+ (test-assert "guest SSH up and running"
+ ;; Note: Pass #:peek? #t because due to the way QEMU port
+ ;; forwarding works, connecting to 11022 always works even if the
+ ;; 'sshd' service hasn't been started yet in the guest.
+ (wait-for-tcp-port 11022 marionette
+ #:peek? #t))
+
+ (test-assert "copy-on-write store"
+ ;; Set up a writable store. The root partition is already an
+ ;; overlayfs, which is not suitable as the bottom part of this
+ ;; additional overlayfs; thus, create a tmpfs for the backing
+ ;; store.
+ ;; TODO: Remove this when <virtual-machine> creates a writable
+ ;; store.
+ (marionette-eval
+ '(begin
+ (use-modules (gnu build install)
+ (guix build syscalls))
+
+ (mkdir "/run/writable-store")
+ (mount "none" "/run/writable-store" "tmpfs")
+ (mount-cow-store "/run/writable-store" "/backing-store")
+ (system* "df" "-hT"))
+ marionette))
+
+ (test-equal "offloading"
+ 0
+ (marionette-eval
+ '(and (file-exists? "/etc/guix/machines.scm")
+ (system* "guix" "offload" "test"))
+ marionette))
+
+ (test-end))))
+
+ (gexp->derivation "build-vm-test" test))
+
+(define %test-build-vm
+ (system-test
+ (name "build-vm")
+ (description
+ "Offload to a virtual build machine over SSH.")
+ (value (run-build-vm-test))))