Commit | Line | Data |
---|---|---|
c075c8fd CB |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> | |
c11c19bd | 3 | ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> |
18e76f89 | 4 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
c075c8fd CB |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (gnu tests virtualization) | |
22 | #:use-module (gnu tests) | |
18e76f89 | 23 | #:use-module (gnu image) |
c075c8fd CB |
24 | #:use-module (gnu system) |
25 | #:use-module (gnu system file-systems) | |
18e76f89 JN |
26 | #:use-module (gnu system image) |
27 | #:use-module (gnu system images hurd) | |
c075c8fd CB |
28 | #:use-module (gnu system vm) |
29 | #:use-module (gnu services) | |
30 | #:use-module (gnu services dbus) | |
31 | #:use-module (gnu services networking) | |
32 | #:use-module (gnu services virtualization) | |
33 | #:use-module (gnu packages virtualization) | |
c11c19bd | 34 | #:use-module (gnu packages ssh) |
c075c8fd | 35 | #:use-module (guix gexp) |
18e76f89 | 36 | #:use-module (guix records) |
c075c8fd | 37 | #:use-module (guix store) |
c11c19bd LC |
38 | #:export (%test-libvirt |
39 | %test-childhurd)) | |
40 | ||
41 | \f | |
42 | ;;; | |
43 | ;;; Libvirt. | |
44 | ;;; | |
c075c8fd CB |
45 | |
46 | (define %libvirt-os | |
47 | (simple-operating-system | |
39d7fdce | 48 | (service dhcp-client-service-type) |
c075c8fd CB |
49 | (dbus-service) |
50 | (polkit-service) | |
51 | (service libvirt-service-type))) | |
52 | ||
53 | (define (run-libvirt-test) | |
54 | "Run tests in %LIBVIRT-OS." | |
55 | (define os | |
56 | (marionette-operating-system | |
57 | %libvirt-os | |
58 | #:imported-modules '((gnu services herd) | |
59 | (guix combinators)))) | |
60 | ||
61 | (define vm | |
62 | (virtual-machine | |
63 | (operating-system os) | |
64 | (port-forwardings '()))) | |
65 | ||
66 | (define test | |
67 | (with-imported-modules '((gnu build marionette)) | |
68 | #~(begin | |
69 | (use-modules (srfi srfi-11) (srfi srfi-64) | |
70 | (gnu build marionette)) | |
71 | ||
72 | (define marionette | |
73 | (make-marionette (list #$vm))) | |
74 | ||
75 | (mkdir #$output) | |
76 | (chdir #$output) | |
77 | ||
78 | (test-begin "libvirt") | |
79 | ||
80 | (test-assert "service running" | |
81 | (marionette-eval | |
82 | '(begin | |
83 | (use-modules (gnu services herd)) | |
84 | (match (start-service 'libvirtd) | |
85 | (#f #f) | |
86 | (('service response-parts ...) | |
87 | (match (assq-ref response-parts 'running) | |
88 | ((pid) (number? pid)))))) | |
89 | marionette)) | |
90 | ||
91 | (test-eq "fetch version" | |
92 | 0 | |
93 | (marionette-eval | |
94 | `(begin | |
95 | (system* ,(string-append #$libvirt "/bin/virsh") | |
96 | "-c" "qemu:///system" "version")) | |
97 | marionette)) | |
98 | ||
99 | (test-end) | |
100 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
101 | ||
102 | (gexp->derivation "libvirt-test" test)) | |
103 | ||
104 | (define %test-libvirt | |
105 | (system-test | |
106 | (name "libvirt") | |
107 | (description "Connect to the running LIBVIRT service.") | |
108 | (value (run-libvirt-test)))) | |
c11c19bd LC |
109 | |
110 | \f | |
111 | ;;; | |
112 | ;;; GNU/Hurd virtual machines, aka. childhurds. | |
113 | ;;; | |
114 | ||
18e76f89 JN |
115 | ;; Copy of `hurd-vm-disk-image', using plain disk-image for test |
116 | (define (hurd-vm-disk-image-raw config) | |
117 | (let ((os ((@@ (gnu services virtualization) secret-service-operating-system) | |
118 | (hurd-vm-configuration-os config))) | |
119 | (disk-size (hurd-vm-configuration-disk-size config))) | |
120 | (system-image | |
121 | (image | |
122 | (inherit hurd-disk-image) | |
123 | (format 'disk-image) | |
124 | (size disk-size) | |
125 | (operating-system os))))) | |
126 | ||
c11c19bd LC |
127 | (define %childhurd-os |
128 | (simple-operating-system | |
129 | (service dhcp-client-service-type) | |
18e76f89 JN |
130 | (service hurd-vm-service-type |
131 | (hurd-vm-configuration | |
132 | (image (hurd-vm-disk-image-raw this-record)))))) | |
c11c19bd LC |
133 | |
134 | (define (run-childhurd-test) | |
135 | (define os | |
136 | (marionette-operating-system | |
137 | %childhurd-os | |
138 | #:imported-modules '((gnu services herd) | |
139 | (guix combinators)))) | |
140 | ||
141 | (define vm | |
142 | (virtual-machine | |
143 | (operating-system os) | |
144 | (memory-size (* 1024 3)))) | |
145 | ||
146 | (define run-uname-over-ssh | |
147 | ;; Program that runs 'uname' over SSH and prints the result on standard | |
148 | ;; output. | |
149 | (let () | |
150 | (define run | |
151 | (with-extensions (list guile-ssh) | |
152 | #~(begin | |
153 | (use-modules (ssh session) | |
154 | (ssh auth) | |
155 | (ssh popen) | |
156 | (ice-9 match) | |
157 | (ice-9 textual-ports)) | |
158 | ||
159 | (let ((session (make-session #:user "root" | |
160 | #:port 10022 | |
161 | #:host "localhost" | |
162 | #:log-verbosity 'rare))) | |
163 | (match (connect! session) | |
164 | ('ok | |
165 | (userauth-password! session "") | |
166 | (display | |
167 | (get-string-all | |
168 | (open-remote-input-pipe* session "uname" "-on")))) | |
169 | (status | |
170 | (error "could not connect to childhurd over SSH" | |
171 | session status))))))) | |
172 | ||
173 | (program-file "run-uname-over-ssh" run))) | |
174 | ||
175 | (define test | |
176 | (with-imported-modules '((gnu build marionette)) | |
177 | #~(begin | |
178 | (use-modules (gnu build marionette) | |
179 | (srfi srfi-64) | |
180 | (ice-9 match)) | |
181 | ||
182 | (define marionette | |
183 | (make-marionette (list #$vm))) | |
184 | ||
185 | (mkdir #$output) | |
186 | (chdir #$output) | |
187 | ||
188 | (test-begin "childhurd") | |
189 | ||
190 | (test-assert "service running" | |
191 | (marionette-eval | |
192 | '(begin | |
193 | (use-modules (gnu services herd)) | |
194 | (match (start-service 'childhurd) | |
195 | (#f #f) | |
196 | (('service response-parts ...) | |
197 | (match (assq-ref response-parts 'running) | |
198 | ((pid) (number? pid)))))) | |
199 | marionette)) | |
200 | ||
201 | (test-equal "childhurd SSH server replies" | |
202 | "SSH" | |
203 | ;; Check from within the guest whether its childhurd's SSH | |
204 | ;; server is reachable. Do that from the guest: port forwarding | |
205 | ;; to the host won't work because QEMU listens on 127.0.0.1. | |
206 | (marionette-eval | |
207 | '(begin | |
208 | (use-modules (ice-9 match)) | |
209 | ||
210 | (let loop ((n 60)) | |
211 | (if (zero? n) | |
212 | 'all-attempts-failed | |
213 | (let ((s (socket PF_INET SOCK_STREAM 0)) | |
214 | (a (make-socket-address AF_INET | |
215 | INADDR_LOOPBACK | |
216 | 10022))) | |
217 | (format #t "connecting to childhurd SSH server...~%") | |
218 | (connect s a) | |
219 | (match (get-string-n s 3) | |
220 | ((? eof-object?) | |
221 | (close-port s) | |
222 | (sleep 1) | |
223 | (loop (- n 1))) | |
224 | (str | |
225 | (close-port s) | |
226 | str)))))) | |
227 | marionette)) | |
228 | ||
229 | (test-equal "SSH up and running" | |
230 | "childhurd GNU\n" | |
231 | ||
232 | ;; Connect from the guest to the chidhurd over SSH and run the | |
233 | ;; 'uname' command. | |
234 | (marionette-eval | |
235 | '(begin | |
236 | (use-modules (ice-9 popen)) | |
237 | ||
238 | (get-string-all | |
239 | (open-input-pipe #$run-uname-over-ssh))) | |
240 | marionette)) | |
241 | ||
242 | (test-end) | |
243 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
244 | ||
245 | (gexp->derivation "childhurd-test" test)) | |
246 | ||
247 | (define %test-childhurd | |
248 | (system-test | |
249 | (name "childhurd") | |
250 | (description | |
251 | "Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making | |
252 | sure that the childhurd boots and runs its SSH server.") | |
253 | (value (run-childhurd-test)))) |