projects/guix·blob version-1.2.0 · refs

253 lines · 8.0 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;;;
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)
23 #:use-module (gnu image)
24 #:use-module (gnu system)
25 #:use-module (gnu system file-systems)
26 #:use-module (gnu system image)
27 #:use-module (gnu system images hurd)
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)
34 #:use-module (gnu packages ssh)
35 #:use-module (guix gexp)
36 #:use-module (guix records)
37 #:use-module (guix store)
38 #:export (%test-libvirt
39 %test-childhurd))
40
41
42;;;
43;;; Libvirt.
44;;;
45
46(define %libvirt-os
47 (simple-operating-system
48 (service dhcp-client-service-type)
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))))
109
110
111;;;
112;;; GNU/Hurd virtual machines, aka. childhurds.
113;;;
114
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
127(define %childhurd-os
128 (simple-operating-system
129 (service dhcp-client-service-type)
130 (service hurd-vm-service-type
131 (hurd-vm-configuration
132 (image (hurd-vm-disk-image-raw this-record))))))
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
252sure that the childhurd boots and runs its SSH server.")
253 (value (run-childhurd-test))))