projects/guix·blob master · refs

606 lines · 20.4 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;;; Copyright © 2026 Nguyễn Gia Phong <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23(define-module (gnu tests version-control)
24 #:use-module (gnu tests)
25 #:use-module (gnu system)
26 #:use-module (gnu system file-systems)
27 #:use-module (gnu system shadow)
28 #:use-module (gnu system vm)
29 #:use-module (gnu services)
30 #:use-module (gnu services version-control)
31 #:use-module (gnu services cgit)
32 #:use-module (gnu services ssh)
33 #:use-module (gnu services web)
34 #:use-module (gnu services networking)
35 #:use-module (gnu packages version-control)
36 #:use-module (gnu packages ssh)
37 #:use-module (guix gexp)
38 #:use-module (guix store)
39 #:use-module (guix modules)
40 #:export (%test-cgit
41 %test-git-http
42 %test-git-http-root-path
43 %test-gitolite
44 %test-gitile
45 %test-fossil))
46
47(define README-contents
48 "Hello! This is what goes inside the 'README' file.")
49
50(define %make-git-repository
51 ;; Create Git repository in /srv/git/test.
52 (with-imported-modules (source-module-closure
53 '((guix build utils)))
54 #~(begin
55 (use-modules (guix build utils))
56
57 (let ((git (string-append #$git "/bin/git")))
58 (mkdir-p "/tmp/test-repo")
59 (with-directory-excursion "/tmp/test-repo"
60 (call-with-output-file "/tmp/test-repo/README"
61 (lambda (port)
62 (display #$README-contents port)))
63 (invoke git "config" "--global" "user.email" "[email protected]")
64 (invoke git "config" "--global" "user.name" "A U Thor")
65 (invoke git "init")
66 (invoke git "add" ".")
67 (invoke git "commit" "-m" "That's a commit."))
68
69 (mkdir-p "/srv/git")
70 (rename-file "/tmp/test-repo/.git" "/srv/git/test")
71 (with-output-to-file "/srv/git/test/git-daemon-export-ok"
72 (lambda _
73 (display "")))))))
74
75(define %test-repository-service
76 ;; Service that creates /srv/git/test.
77 (simple-service 'make-git-repository activation-service-type
78 %make-git-repository))
79
80(define %cgit-configuration-nginx
81 (list
82 (nginx-server-configuration
83 (root cgit)
84 (locations
85 (list
86 (nginx-location-configuration
87 (uri "@cgit")
88 (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
89 "fastcgi_param PATH_INFO $uri;"
90 "fastcgi_param QUERY_STRING $args;"
91 "fastcgi_param HTTP_HOST $server_name;"
92 "fastcgi_pass 127.0.0.1:9000;")))))
93 (try-files (list "$uri" "@cgit"))
94 (listen '("19418"))
95 (ssl-certificate #f)
96 (ssl-certificate-key #f))))
97
98(define %cgit-os
99 ;; Operating system under test.
100 (let ((base-os
101 (simple-operating-system
102 (service dhcpcd-service-type)
103 (service cgit-service-type
104 (cgit-configuration
105 (nginx %cgit-configuration-nginx)))
106 %test-repository-service)))
107 (operating-system
108 (inherit base-os)
109 (packages (cons* git
110 (operating-system-packages base-os))))))
111
112(define* (run-cgit-test #:optional (http-port 19418))
113 "Run tests in %CGIT-OS, which has nginx running and listening on
114HTTP-PORT."
115 (define os
116 (marionette-operating-system
117 %cgit-os
118 #:imported-modules '((gnu services herd)
119 (guix combinators))))
120
121 (define vm
122 (virtual-machine
123 (operating-system os)
124 (port-forwardings `((8080 . ,http-port)))))
125
126 (define test
127 (with-imported-modules '((gnu build marionette))
128 #~(begin
129 (use-modules (srfi srfi-11) (srfi srfi-64)
130 (gnu build marionette)
131 (web uri)
132 (web client)
133 (web response))
134
135 (define marionette
136 (make-marionette (list #$vm)))
137
138 (test-runner-current (system-test-runner #$output))
139 (test-begin "cgit")
140
141 ;; XXX: Shepherd reads the config file *before* binding its control
142 ;; socket, so /var/run/shepherd/socket might not exist yet when the
143 ;; 'marionette' service is started.
144 (test-assert "shepherd socket ready"
145 (marionette-eval
146 `(begin
147 (use-modules (gnu services herd))
148 (let loop ((i 10))
149 (cond ((file-exists? (%shepherd-socket-file))
150 #t)
151 ((> i 0)
152 (sleep 1)
153 (loop (- i 1)))
154 (else
155 'failure))))
156 marionette))
157
158 ;; Wait for nginx to be up and running.
159 (test-assert "nginx running"
160 (wait-for-file "/var/run/nginx/pid" marionette))
161
162 ;; Wait for fcgiwrap to be up and running.
163 (test-assert "fcgiwrap running"
164 (wait-for-tcp-port 9000 marionette))
165
166 ;; Make sure the PID file is created.
167 (test-assert "PID file"
168 (marionette-eval
169 '(file-exists? "/var/run/nginx/pid")
170 marionette))
171
172 ;; Make sure the configuration file is created.
173 (test-assert "configuration file"
174 (marionette-eval
175 '(file-exists? "/etc/cgitrc")
176 marionette))
177
178 ;; Make sure Git test repository is created.
179 (test-assert "Git test repository"
180 (marionette-eval
181 '(file-exists? "/srv/git/test")
182 marionette))
183
184 ;; Make sure we can access pages that correspond to our repository.
185 (letrec-syntax ((test-url
186 (syntax-rules ()
187 ((_ path code)
188 (test-equal (string-append "GET " path)
189 code
190 (let-values (((response body)
191 (http-get (string-append
192 "http://localhost:8080"
193 path))))
194 (response-code response))))
195 ((_ path)
196 (test-url path 200)))))
197 (test-url "/")
198 (test-url "/test")
199 (test-url "/test/log")
200 (test-url "/test/tree")
201 (test-url "/test/tree/README")
202 (test-url "/test/does-not-exist" 404)
203 (test-url "/test/tree/does-not-exist" 404)
204 (test-url "/does-not-exist" 404))
205
206 (test-end))))
207
208 (gexp->derivation "cgit-test" test))
209
210(define %test-cgit
211 (system-test
212 (name "cgit")
213 (description "Connect to a running Cgit server.")
214 (value (run-cgit-test))))
215
216
217;;;
218;;; Git server.
219;;;
220
221(define (git-nginx-configuration uri-path)
222 (nginx-configuration
223 (server-blocks
224 (list
225 (nginx-server-configuration
226 (listen '("19418"))
227 (ssl-certificate #f)
228 (ssl-certificate-key #f)
229 (locations
230 (list (git-http-nginx-location-configuration
231 (git-http-configuration (export-all? #t)
232 (uri-path uri-path))))))))))
233
234(define (git-http-os uri-path)
235 (simple-operating-system
236 (service dhcpcd-service-type)
237 (service fcgiwrap-service-type)
238 (service nginx-service-type (git-nginx-configuration uri-path))
239 %test-repository-service))
240
241(define* (git-http-test name description uri-path
242 #:optional (http-port 19418))
243 (define os
244 (marionette-operating-system
245 (git-http-os uri-path)
246 #:imported-modules '((gnu services herd)
247 (guix combinators))))
248
249 (define vm
250 (virtual-machine
251 (operating-system os)
252 (port-forwardings `((8080 . ,http-port)))))
253
254 (define test
255 (with-imported-modules '((gnu build marionette)
256 (guix build utils))
257 #~(begin
258 (use-modules (srfi srfi-64)
259 (rnrs io ports)
260 (gnu build marionette)
261 (guix build utils))
262
263 (define marionette
264 (make-marionette (list #$vm)))
265
266 (test-runner-current (system-test-runner #$output))
267 (test-begin #$name)
268
269 ;; Wait for nginx to be up and running.
270 (test-assert "nginx running"
271 (wait-for-file "/var/run/nginx/pid" marionette))
272
273 ;; Make sure Git test repository is created.
274 (test-assert "Git test repository"
275 (marionette-eval
276 '(file-exists? "/srv/git/test")
277 marionette))
278
279 (test-assert "fcgiwrap listens"
280 ;; Wait for fcgiwrap to be ready before cloning.
281 (wait-for-tcp-port 9000 marionette))
282
283 ;; Make sure we can clone the repo from the host.
284 (test-equal "clone"
285 '#$README-contents
286 (begin
287 (invoke #$(file-append git "/bin/git") "clone" "-v"
288 #$(simple-format #f "http://localhost:8080~a/test"
289 (if (string=? uri-path "/")
290 ""
291 (string-append "/" (string-trim-both
292 uri-path #\/))))
293 "/tmp/clone")
294 (call-with-input-file "/tmp/clone/README"
295 get-string-all)))
296
297 (test-end))))
298
299 (system-test
300 (name name)
301 (description description)
302 (value (gexp->derivation name test))))
303
304(define %test-git-http
305 (git-http-test "git-http" "Connect to a running Git HTTP server." "/git/"))
306
307(define %test-git-http-root-path
308 (git-http-test "git-http-root-path"
309 "Connect to a running Git HTTP server with root URI path."
310 "/"))
311
312
313;;;
314;;; Gitolite.
315;;;
316
317(define %gitolite-test-admin-keypair
318 (computed-file
319 "gitolite-test-admin-keypair"
320 (with-imported-modules (source-module-closure
321 '((guix build utils)))
322 #~(begin
323 (use-modules (ice-9 match) (srfi srfi-26)
324 (guix build utils))
325
326 (mkdir #$output)
327 (invoke #$(file-append openssh "/bin/ssh-keygen")
328 "-f" (string-append #$output "/test-admin")
329 "-t" "rsa"
330 "-q"
331 "-N" "")))))
332
333(define %gitolite-os
334 (simple-operating-system
335 (service dhcpcd-service-type)
336 (service openssh-service-type)
337 (service gitolite-service-type
338 (gitolite-configuration
339 (admin-pubkey
340 (file-append %gitolite-test-admin-keypair "/test-admin.pub"))))))
341
342(define (run-gitolite-test)
343 (define os
344 (marionette-operating-system
345 %gitolite-os
346 #:imported-modules '((gnu services herd)
347 (guix combinators))))
348
349 (define vm
350 (virtual-machine
351 (operating-system os)
352 (port-forwardings `((2222 . 22)))))
353
354 (define test
355 (with-imported-modules '((gnu build marionette)
356 (guix build utils))
357 #~(begin
358 (use-modules (srfi srfi-64)
359 (rnrs io ports)
360 (gnu build marionette)
361 (guix build utils))
362
363 (define marionette
364 (make-marionette (list #$vm)))
365
366 (test-runner-current (system-test-runner #$output))
367 (test-begin "gitolite")
368
369 ;; Wait for sshd to be up and running.
370 (test-assert "service running"
371 (marionette-eval
372 '(begin
373 (use-modules (gnu services herd))
374 (start-service 'ssh-daemon))
375 marionette))
376
377 (display #$%gitolite-test-admin-keypair)
378
379 (setenv "GIT_SSH_VARIANT" "ssh")
380 (setenv "GIT_SSH_COMMAND"
381 (string-join
382 '(#$(file-append openssh "/bin/ssh")
383 "-i" #$(file-append %gitolite-test-admin-keypair
384 "/test-admin")
385 "-o" "UserKnownHostsFile=/dev/null"
386 "-o" "StrictHostKeyChecking=no")))
387
388 (test-assert "cloning the admin repository"
389 (invoke #$(file-append git "/bin/git")
390 "clone" "-v"
391 "ssh://git@localhost:2222/gitolite-admin"
392 "/tmp/clone"))
393
394 (test-assert "admin key exists"
395 (file-exists? "/tmp/clone/keydir/test-admin.pub"))
396
397 (with-directory-excursion "/tmp/clone"
398 (invoke #$(file-append git "/bin/git")
399 "-c" "user.name=Guix" "-c" "user.email=guix"
400 "commit"
401 "-m" "Test commit"
402 "--allow-empty")
403
404 (test-assert "pushing, and the associated hooks"
405 (invoke #$(file-append git "/bin/git") "push")))
406
407 (test-end))))
408
409 (gexp->derivation "gitolite" test))
410
411(define %test-gitolite
412 (system-test
413 (name "gitolite")
414 (description "Clone the Gitolite admin repository.")
415 (value (run-gitolite-test))))
416
417;;;
418;;; Gitile.
419;;;
420
421(define %gitile-configuration-nginx
422 (nginx-server-configuration
423 (root "/does/not/exists")
424 (try-files (list "$uri" "=404"))
425 (listen '("19418"))
426 (ssl-certificate #f)
427 (ssl-certificate-key #f)))
428
429(define %gitile-os
430 ;; Operating system under test.
431 (simple-operating-system
432 (service dhcpcd-service-type)
433 (simple-service 'srv-git activation-service-type
434 #~(mkdir-p "/srv/git"))
435 (service gitile-service-type
436 (gitile-configuration
437 (base-git-url "http://localhost")
438 (repositories "/srv/git")
439 ;; As /srv/git is root-owned, disable strict owner validation.
440 (git-owner-validation? #f)
441 (nginx %gitile-configuration-nginx)))
442 %test-repository-service))
443
444(define* (run-gitile-test #:optional (http-port 19418))
445 "Run tests in %GITOLITE-OS, which has nginx running and listening on
446HTTP-PORT."
447 (define os
448 (marionette-operating-system
449 %gitile-os
450 #:imported-modules '((gnu services herd)
451 (guix combinators))))
452
453 (define vm
454 (virtual-machine
455 (operating-system os)
456 (port-forwardings `((8081 . ,http-port)))
457 (memory-size 1024)))
458
459 (define test
460 (with-imported-modules '((gnu build marionette))
461 #~(begin
462 (use-modules (srfi srfi-11) (srfi srfi-64)
463 (gnu build marionette)
464 (web uri)
465 (web client)
466 (web response))
467
468 (define marionette
469 (make-marionette (list #$vm)))
470
471 (test-runner-current (system-test-runner #$output))
472 (test-begin "gitile")
473
474 ;; XXX: Shepherd reads the config file *before* binding its control
475 ;; socket, so /var/run/shepherd/socket might not exist yet when the
476 ;; 'marionette' service is started.
477 (test-assert "shepherd socket ready"
478 (marionette-eval
479 `(begin
480 (use-modules (gnu services herd))
481 (let loop ((i 10))
482 (cond ((file-exists? (%shepherd-socket-file))
483 #t)
484 ((> i 0)
485 (sleep 1)
486 (loop (- i 1)))
487 (else
488 'failure))))
489 marionette))
490
491 ;; Wait for nginx to be up and running.
492 (test-assert "nginx running"
493 (wait-for-file "/var/run/nginx/pid" marionette))
494
495 ;; Make sure Git test repository is created.
496 (test-assert "Git test repository"
497 (marionette-eval
498 '(file-exists? "/srv/git/test")
499 marionette))
500
501 (sleep 2)
502
503 ;; Make sure we can access pages that correspond to our repository.
504 (letrec-syntax ((test-url
505 (syntax-rules ()
506 ((_ path code)
507 (test-equal (string-append "GET " path)
508 code
509 (let-values (((response body)
510 (http-get (string-append
511 "http://localhost:8081"
512 path))))
513 (response-code response))))
514 ((_ path)
515 (test-url path 200)))))
516 (test-url "/")
517 (test-url "/css/gitile.css")
518 (test-url "/test")
519 (test-url "/test/commits")
520 (test-url "/test/tree" 404)
521 (test-url "/test/tree/-")
522 (test-url "/test/tree/-/README")
523 (test-url "/test/does-not-exist" 404)
524 (test-url "/test/tree/-/does-not-exist" 404)
525 (test-url "/does-not-exist" 404))
526
527 (test-end))))
528
529 (gexp->derivation "gitile-test" test))
530
531(define %test-gitile
532 (system-test
533 (name "gitile")
534 (description "Connect to a running Gitile server.")
535 (value (run-gitile-test))))
536
537
538;;;
539;;; Fossil server.
540;;;
541
542(define %test-fossil
543 (system-test
544 (name "fossil")
545 (description "Connect to a running Fossil server.")
546 (value
547 (gexp->derivation
548 (string-append name "-test")
549 (let* ((port 8080)
550 (base-url (simple-format #f "http://localhost:~a" port))
551 (index-url (string-append base-url "/index"))
552 (os (marionette-operating-system
553 (simple-operating-system
554 (service dhcpcd-service-type)
555 (service fossil-service-type
556 (fossil-configuration
557 (repository "/tmp/test.fossil")
558 (base-url base-url)
559 (create? #t)
560 (port port))))))
561 (vm (virtual-machine (operating-system os)
562 (port-forwardings (list (cons port port))))))
563 (with-imported-modules '((gnu build marionette)
564 (guix build utils))
565 #~(begin
566 (use-modules (gnu build marionette)
567 (guix build utils)
568 (srfi srfi-64)
569 (srfi srfi-71)
570 (web client)
571 (web response))
572 (define marionette (make-marionette (list #$vm)))
573 (test-runner-current (system-test-runner #$output))
574 (test-begin #$name)
575
576 (test-assert "server running"
577 (wait-for-tcp-port #$port marionette))
578
579 (test-assert "server log file"
580 (wait-for-file "/var/log/fossil.log" marionette))
581
582 (test-assert "cloning"
583 (begin
584 (setenv "HOME" #$output) ; fossil writes to $HOME
585 (invoke/quiet #$(file-append fossil "/bin/fossil") "clone"
586 "--admin-user" "alice"
587 "--httptrace"
588 "--verbose"
589 #$base-url
590 (string-append #$output "/test.fossil"))))
591
592 (test-assert "index redirect"
593 (let ((response text
594 (http-get #$base-url #:decode-body? #t)))
595 (and (= 302 (response-code response))
596 (string-contains text #$index-url))))
597
598 (test-equal "index page"
599 200 (response-code (http-get #$index-url)))
600
601 (test-equal "tarball download"
602 200 (response-code
603 (http-get (string-append #$base-url
604 "/tarball/test.tar.gz"))))
605
606 (test-end))))))))