gnu/tests/version-control.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018 Oleg Pykhalov <go.wigust@gmail.com>
   3 ;;; Copyright © 2017-2018, 2020-2022 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
   5 ;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
   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" "charlie@example.org")
  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 dhcp-client-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
 111 HTTP-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 \f
 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 dhcp-client-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 \f
 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 dhcp-client-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 dhcp-client-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              (nginx %gitile-configuration-nginx)))
 426    %test-repository-service))
 427
 428 (define* (run-gitile-test #:optional (http-port 19418))
 429   "Run tests in %GITOLITE-OS, which has nginx running and listening on
 430 HTTP-PORT."
 431   (define os
 432     (marionette-operating-system
 433      %gitile-os
 434      #:imported-modules '((gnu services herd)
 435                           (guix combinators))))
 436
 437   (define vm
 438     (virtual-machine
 439      (operating-system os)
 440      (port-forwardings `((8081 . ,http-port)))
 441      (memory-size 1024)))
 442
 443   (define test
 444     (with-imported-modules '((gnu build marionette))
 445       #~(begin
 446           (use-modules (srfi srfi-11) (srfi srfi-64)
 447                        (gnu build marionette)
 448                        (web uri)
 449                        (web client)
 450                        (web response))
 451
 452           (define marionette
 453             (make-marionette (list #$vm)))
 454
 455           (test-runner-current (system-test-runner #$output))
 456           (test-begin "gitile")
 457
 458           ;; XXX: Shepherd reads the config file *before* binding its control
 459           ;; socket, so /var/run/shepherd/socket might not exist yet when the
 460           ;; 'marionette' service is started.
 461           (test-assert "shepherd socket ready"
 462             (marionette-eval
 463              `(begin
 464                 (use-modules (gnu services herd))
 465                 (let loop ((i 10))
 466                   (cond ((file-exists? (%shepherd-socket-file))
 467                          #t)
 468                         ((> i 0)
 469                          (sleep 1)
 470                          (loop (- i 1)))
 471                         (else
 472                          'failure))))
 473              marionette))
 474
 475           ;; Wait for nginx to be up and running.
 476           (test-assert "nginx running"
 477             (wait-for-file "/var/run/nginx/pid" marionette))
 478
 479           ;; Make sure Git test repository is created.
 480           (test-assert "Git test repository"
 481             (marionette-eval
 482              '(file-exists? "/srv/git/test")
 483              marionette))
 484
 485           (sleep 2)
 486
 487           ;; Make sure we can access pages that correspond to our repository.
 488           (letrec-syntax ((test-url
 489                            (syntax-rules ()
 490                              ((_ path code)
 491                               (test-equal (string-append "GET " path)
 492                                 code
 493                                 (let-values (((response body)
 494                                               (http-get (string-append
 495                                                          "http://localhost:8081"
 496                                                          path))))
 497                                   (response-code response))))
 498                              ((_ path)
 499                               (test-url path 200)))))
 500             (test-url "/")
 501             (test-url "/css/gitile.css")
 502             (test-url "/test")
 503             (test-url "/test/commits")
 504             (test-url "/test/tree" 404)
 505             (test-url "/test/tree/-")
 506             (test-url "/test/tree/-/README")
 507             (test-url "/test/does-not-exist" 404)
 508             (test-url "/test/tree/-/does-not-exist" 404)
 509             (test-url "/does-not-exist" 404))
 510
 511           (test-end))))
 512
 513   (gexp->derivation "gitile-test" test))
 514
 515 (define %test-gitile
 516   (system-test
 517    (name "gitile")
 518    (description "Connect to a running Gitile server.")
 519    (value (run-gitile-test))))