projects/guix·blob version-1.3.0 · refs

264 lines · 8.4 KiB

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