projects/guix·blob version-1.0.0 · refs

414 lines · 13.4 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017, 2018 Oleg Pykhalov <[email protected]>
3;;; Copyright © 2017, 2018 Ludovic Courtès <[email protected]>
4;;; Copyright © 2017, 2018 Clément Lassieur <[email protected]>
5;;; Copyright © 2018 Christopher Baines <[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 version-control)
23 #:use-module (gnu tests)
24 #:use-module (gnu system)
25 #:use-module (gnu system file-systems)
26 #:use-module (gnu system shadow)
27 #:use-module (gnu system vm)
28 #:use-module (gnu services)
29 #:use-module (gnu services version-control)
30 #:use-module (gnu services cgit)
31 #:use-module (gnu services ssh)
32 #:use-module (gnu services web)
33 #:use-module (gnu services networking)
34 #:use-module (gnu packages version-control)
35 #:use-module (gnu packages ssh)
36 #:use-module (guix gexp)
37 #:use-module (guix store)
38 #:use-module (guix modules)
39 #:export (%test-cgit
40 %test-git-http
41 %test-gitolite))
42
43(define README-contents
44 "Hello! This is what goes inside the 'README' file.")
45
46(define %make-git-repository
47 ;; Create Git repository in /srv/git/test.
48 (with-imported-modules (source-module-closure
49 '((guix build utils)))
50 #~(begin
51 (use-modules (guix build utils))
52
53 (let ((git (string-append #$git "/bin/git")))
54 (mkdir-p "/tmp/test-repo")
55 (with-directory-excursion "/tmp/test-repo"
56 (call-with-output-file "/tmp/test-repo/README"
57 (lambda (port)
58 (display #$README-contents port)))
59 (invoke git "config" "--global" "user.email" "[email protected]")
60 (invoke git "config" "--global" "user.name" "A U Thor")
61 (invoke git "init")
62 (invoke git "add" ".")
63 (invoke git "commit" "-m" "That's a commit."))
64
65 (mkdir-p "/srv/git")
66 (rename-file "/tmp/test-repo/.git" "/srv/git/test")))))
67
68(define %test-repository-service
69 ;; Service that creates /srv/git/test.
70 (simple-service 'make-git-repository activation-service-type
71 %make-git-repository))
72
73(define %cgit-configuration-nginx
74 (list
75 (nginx-server-configuration
76 (root cgit)
77 (locations
78 (list
79 (nginx-location-configuration
80 (uri "@cgit")
81 (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
82 "fastcgi_param PATH_INFO $uri;"
83 "fastcgi_param QUERY_STRING $args;"
84 "fastcgi_param HTTP_HOST $server_name;"
85 "fastcgi_pass 127.0.0.1:9000;")))))
86 (try-files (list "$uri" "@cgit"))
87 (listen '("19418"))
88 (ssl-certificate #f)
89 (ssl-certificate-key #f))))
90
91(define %cgit-os
92 ;; Operating system under test.
93 (let ((base-os
94 (simple-operating-system
95 (service dhcp-client-service-type)
96 (service cgit-service-type
97 (cgit-configuration
98 (nginx %cgit-configuration-nginx)))
99 %test-repository-service)))
100 (operating-system
101 (inherit base-os)
102 (packages (cons* git
103 (operating-system-packages base-os))))))
104
105(define* (run-cgit-test #:optional (http-port 19418))
106 "Run tests in %CGIT-OS, which has nginx running and listening on
107HTTP-PORT."
108 (define os
109 (marionette-operating-system
110 %cgit-os
111 #:imported-modules '((gnu services herd)
112 (guix combinators))))
113
114 (define vm
115 (virtual-machine
116 (operating-system os)
117 (port-forwardings `((8080 . ,http-port)))))
118
119 (define test
120 (with-imported-modules '((gnu build marionette))
121 #~(begin
122 (use-modules (srfi srfi-11) (srfi srfi-64)
123 (gnu build marionette)
124 (web uri)
125 (web client)
126 (web response))
127
128 (define marionette
129 (make-marionette (list #$vm)))
130
131 (mkdir #$output)
132 (chdir #$output)
133
134 (test-begin "cgit")
135
136 ;; XXX: Shepherd reads the config file *before* binding its control
137 ;; socket, so /var/run/shepherd/socket might not exist yet when the
138 ;; 'marionette' service is started.
139 (test-assert "shepherd socket ready"
140 (marionette-eval
141 `(begin
142 (use-modules (gnu services herd))
143 (let loop ((i 10))
144 (cond ((file-exists? (%shepherd-socket-file))
145 #t)
146 ((> i 0)
147 (sleep 1)
148 (loop (- i 1)))
149 (else
150 'failure))))
151 marionette))
152
153 ;; Wait for nginx to be up and running.
154 (test-assert "nginx running"
155 (marionette-eval
156 '(begin
157 (use-modules (gnu services herd))
158 (start-service 'nginx))
159 marionette))
160
161 ;; Wait for fcgiwrap to be up and running.
162 (test-assert "fcgiwrap running"
163 (marionette-eval
164 '(begin
165 (use-modules (gnu services herd))
166 (start-service 'fcgiwrap))
167 marionette))
168
169 ;; Make sure the PID file is created.
170 (test-assert "PID file"
171 (marionette-eval
172 '(file-exists? "/var/run/nginx/pid")
173 marionette))
174
175 ;; Make sure the configuration file is created.
176 (test-assert "configuration file"
177 (marionette-eval
178 '(file-exists? "/etc/cgitrc")
179 marionette))
180
181 ;; Make sure Git test repository is created.
182 (test-assert "Git test repository"
183 (marionette-eval
184 '(file-exists? "/srv/git/test")
185 marionette))
186
187 ;; Make sure we can access pages that correspond to our repository.
188 (letrec-syntax ((test-url
189 (syntax-rules ()
190 ((_ path code)
191 (test-equal (string-append "GET " path)
192 code
193 (let-values (((response body)
194 (http-get (string-append
195 "http://localhost:8080"
196 path))))
197 (response-code response))))
198 ((_ path)
199 (test-url path 200)))))
200 (test-url "/")
201 (test-url "/test")
202 (test-url "/test/log")
203 (test-url "/test/tree")
204 (test-url "/test/tree/README")
205 (test-url "/test/does-not-exist" 404)
206 (test-url "/test/tree/does-not-exist" 404)
207 (test-url "/does-not-exist" 404))
208
209 (test-end)
210 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
211
212 (gexp->derivation "cgit-test" test))
213
214(define %test-cgit
215 (system-test
216 (name "cgit")
217 (description "Connect to a running Cgit server.")
218 (value (run-cgit-test))))
219
220
221;;;
222;;; Git server.
223;;;
224
225(define %git-nginx-configuration
226 (nginx-configuration
227 (server-blocks
228 (list
229 (nginx-server-configuration
230 (listen '("19418"))
231 (ssl-certificate #f)
232 (ssl-certificate-key #f)
233 (locations
234 (list (git-http-nginx-location-configuration
235 (git-http-configuration (export-all? #t)
236 (uri-path "/git"))))))))))
237
238(define %git-http-os
239 (simple-operating-system
240 (service dhcp-client-service-type)
241 (service fcgiwrap-service-type)
242 (service nginx-service-type %git-nginx-configuration)
243 %test-repository-service))
244
245(define* (run-git-http-test #:optional (http-port 19418))
246 (define os
247 (marionette-operating-system
248 %git-http-os
249 #:imported-modules '((gnu services herd)
250 (guix combinators))))
251
252 (define vm
253 (virtual-machine
254 (operating-system os)
255 (port-forwardings `((8080 . ,http-port)))))
256
257 (define test
258 (with-imported-modules '((gnu build marionette)
259 (guix build utils))
260 #~(begin
261 (use-modules (srfi srfi-64)
262 (rnrs io ports)
263 (gnu build marionette)
264 (guix build utils))
265
266 (define marionette
267 (make-marionette (list #$vm)))
268
269 (mkdir #$output)
270 (chdir #$output)
271
272 (test-begin "git-http")
273
274 ;; Wait for nginx to be up and running.
275 (test-assert "nginx running"
276 (marionette-eval
277 '(begin
278 (use-modules (gnu services herd))
279 (start-service 'nginx))
280 marionette))
281
282 ;; Make sure Git test repository is created.
283 (test-assert "Git test repository"
284 (marionette-eval
285 '(file-exists? "/srv/git/test")
286 marionette))
287
288 ;; Make sure we can clone the repo from the host.
289 (test-equal "clone"
290 '#$README-contents
291 (begin
292 (invoke #$(file-append git "/bin/git") "clone" "-v"
293 "http://localhost:8080/git/test" "/tmp/clone")
294 (call-with-input-file "/tmp/clone/README"
295 get-string-all)))
296
297 (test-end)
298 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
299
300 (gexp->derivation "git-http" test))
301
302(define %test-git-http
303 (system-test
304 (name "git-http")
305 (description "Connect to a running Git HTTP server.")
306 (value (run-git-http-test))))
307
308
309;;;
310;;; Gitolite.
311;;;
312
313(define %gitolite-test-admin-keypair
314 (computed-file
315 "gitolite-test-admin-keypair"
316 (with-imported-modules (source-module-closure
317 '((guix build utils)))
318 #~(begin
319 (use-modules (ice-9 match) (srfi srfi-26)
320 (guix build utils))
321
322 (mkdir #$output)
323 (invoke #$(file-append openssh "/bin/ssh-keygen")
324 "-f" (string-append #$output "/test-admin")
325 "-t" "rsa"
326 "-q"
327 "-N" "")))))
328
329(define %gitolite-os
330 (simple-operating-system
331 (service dhcp-client-service-type)
332 (service openssh-service-type)
333 (service gitolite-service-type
334 (gitolite-configuration
335 (admin-pubkey
336 (file-append %gitolite-test-admin-keypair "/test-admin.pub"))))))
337
338(define (run-gitolite-test)
339 (define os
340 (marionette-operating-system
341 %gitolite-os
342 #:imported-modules '((gnu services herd)
343 (guix combinators))))
344
345 (define vm
346 (virtual-machine
347 (operating-system os)
348 (port-forwardings `((2222 . 22)))))
349
350 (define test
351 (with-imported-modules '((gnu build marionette)
352 (guix build utils))
353 #~(begin
354 (use-modules (srfi srfi-64)
355 (rnrs io ports)
356 (gnu build marionette)
357 (guix build utils))
358
359 (define marionette
360 (make-marionette (list #$vm)))
361
362 (mkdir #$output)
363 (chdir #$output)
364
365 (test-begin "gitolite")
366
367 ;; Wait for sshd to be up and running.
368 (test-assert "service running"
369 (marionette-eval
370 '(begin
371 (use-modules (gnu services herd))
372 (start-service 'ssh-daemon))
373 marionette))
374
375 (display #$%gitolite-test-admin-keypair)
376
377 (setenv "GIT_SSH_VARIANT" "ssh")
378 (setenv "GIT_SSH_COMMAND"
379 (string-join
380 '(#$(file-append openssh "/bin/ssh")
381 "-i" #$(file-append %gitolite-test-admin-keypair
382 "/test-admin")
383 "-o" "UserKnownHostsFile=/dev/null"
384 "-o" "StrictHostKeyChecking=no")))
385
386 (test-assert "cloning the admin repository"
387 (invoke #$(file-append git "/bin/git")
388 "clone" "-v"
389 "ssh://git@localhost:2222/gitolite-admin"
390 "/tmp/clone"))
391
392 (test-assert "admin key exists"
393 (file-exists? "/tmp/clone/keydir/test-admin.pub"))
394
395 (with-directory-excursion "/tmp/clone"
396 (invoke #$(file-append git "/bin/git")
397 "-c" "user.name=Guix" "-c" "user.email=guix"
398 "commit"
399 "-m" "Test commit"
400 "--allow-empty")
401
402 (test-assert "pushing, and the associated hooks"
403 (invoke #$(file-append git "/bin/git") "push")))
404
405 (test-end)
406 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
407
408 (gexp->derivation "gitolite" test))
409
410(define %test-gitolite
411 (system-test
412 (name "gitolite")
413 (description "Clone the Gitolite admin repository.")
414 (value (run-gitolite-test))))