projects/guix·blob bootstrap-team · refs

521 lines · 17.1 KiB

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