projects/guix·blob perlssl · refs

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