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 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
  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" "charlie@example.org")
  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
 107 HTTP-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 \f
 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 \f
 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))))