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 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu tests version-control)
  22   #:use-module (gnu tests)
  23   #:use-module (gnu system)
  24   #:use-module (gnu system file-systems)
  25   #:use-module (gnu system shadow)
  26   #:use-module (gnu system vm)
  27   #:use-module (gnu services)
  28   #:use-module (gnu services version-control)
  29   #:use-module (gnu services cgit)
  30   #:use-module (gnu services web)
  31   #:use-module (gnu services networking)
  32   #:use-module (gnu packages version-control)
  33   #:use-module (guix gexp)
  34   #:use-module (guix store)
  35   #:use-module (guix modules)
  36   #:export (%test-cgit
  37             %test-git-http))
  38
  39 (define README-contents
  40   "Hello!  This is what goes inside the 'README' file.")
  41
  42 (define %make-git-repository
  43   ;; Create Git repository in /srv/git/test.
  44   (with-imported-modules (source-module-closure
  45                           '((guix build utils)))
  46     #~(begin
  47         (use-modules (guix build utils))
  48
  49         (let ((git (string-append #$git "/bin/git")))
  50           (mkdir-p "/tmp/test-repo")
  51           (with-directory-excursion "/tmp/test-repo"
  52             (call-with-output-file "/tmp/test-repo/README"
  53               (lambda (port)
  54                 (display #$README-contents port)))
  55             (invoke git "config" "--global" "user.email" "charlie@example.org")
  56             (invoke git "config" "--global" "user.name" "A U Thor")
  57             (invoke git "init")
  58             (invoke git "add" ".")
  59             (invoke git "commit" "-m" "That's a commit."))
  60
  61           (mkdir-p "/srv/git")
  62           (rename-file "/tmp/test-repo/.git" "/srv/git/test")))))
  63
  64 (define %test-repository-service
  65   ;; Service that creates /srv/git/test.
  66   (simple-service 'make-git-repository activation-service-type
  67                   %make-git-repository))
  68
  69 (define %cgit-configuration-nginx
  70   (list
  71    (nginx-server-configuration
  72     (root cgit)
  73     (locations
  74      (list
  75       (nginx-location-configuration
  76        (uri "@cgit")
  77        (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
  78                "fastcgi_param PATH_INFO $uri;"
  79                "fastcgi_param QUERY_STRING $args;"
  80                "fastcgi_param HTTP_HOST $server_name;"
  81                "fastcgi_pass 127.0.0.1:9000;")))))
  82     (try-files (list "$uri" "@cgit"))
  83     (listen '("19418"))
  84     (ssl-certificate #f)
  85     (ssl-certificate-key #f))))
  86
  87 (define %cgit-os
  88   ;; Operating system under test.
  89   (let ((base-os
  90          (simple-operating-system
  91           (dhcp-client-service)
  92           (service cgit-service-type
  93                    (cgit-configuration
  94                     (nginx %cgit-configuration-nginx)))
  95           %test-repository-service)))
  96     (operating-system
  97       (inherit base-os)
  98       (packages (cons* git
  99                        (operating-system-packages base-os))))))
 100
 101 (define* (run-cgit-test #:optional (http-port 19418))
 102   "Run tests in %CGIT-OS, which has nginx running and listening on
 103 HTTP-PORT."
 104   (define os
 105     (marionette-operating-system
 106      %cgit-os
 107      #:imported-modules '((gnu services herd)
 108                           (guix combinators))))
 109
 110   (define vm
 111     (virtual-machine
 112      (operating-system os)
 113      (port-forwardings `((8080 . ,http-port)))))
 114
 115   (define test
 116     (with-imported-modules '((gnu build marionette))
 117       #~(begin
 118           (use-modules (srfi srfi-11) (srfi srfi-64)
 119                        (gnu build marionette)
 120                        (web uri)
 121                        (web client)
 122                        (web response))
 123
 124           (define marionette
 125             (make-marionette (list #$vm)))
 126
 127           (mkdir #$output)
 128           (chdir #$output)
 129
 130           (test-begin "cgit")
 131
 132           ;; XXX: Shepherd reads the config file *before* binding its control
 133           ;; socket, so /var/run/shepherd/socket might not exist yet when the
 134           ;; 'marionette' service is started.
 135           (test-assert "shepherd socket ready"
 136             (marionette-eval
 137              `(begin
 138                 (use-modules (gnu services herd))
 139                 (let loop ((i 10))
 140                   (cond ((file-exists? (%shepherd-socket-file))
 141                          #t)
 142                         ((> i 0)
 143                          (sleep 1)
 144                          (loop (- i 1)))
 145                         (else
 146                          'failure))))
 147              marionette))
 148
 149           ;; Wait for nginx to be up and running.
 150           (test-assert "nginx running"
 151             (marionette-eval
 152              '(begin
 153                 (use-modules (gnu services herd))
 154                 (start-service 'nginx))
 155              marionette))
 156
 157           ;; Wait for fcgiwrap to be up and running.
 158           (test-assert "fcgiwrap running"
 159             (marionette-eval
 160              '(begin
 161                 (use-modules (gnu services herd))
 162                 (start-service 'fcgiwrap))
 163              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           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 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 \f
 217 ;;;
 218 ;;; Git server.
 219 ;;;
 220
 221 (define %git-nginx-configuration
 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 "/git"))))))))))
 233
 234 (define %git-http-os
 235   (simple-operating-system
 236    (dhcp-client-service)
 237    (service fcgiwrap-service-type)
 238    (service nginx-service-type %git-nginx-configuration)
 239    %test-repository-service))
 240
 241 (define* (run-git-http-test #:optional (http-port 19418))
 242   (define os
 243     (marionette-operating-system
 244      %git-http-os
 245      #:imported-modules '((gnu services herd)
 246                           (guix combinators))))
 247
 248   (define vm
 249     (virtual-machine
 250      (operating-system os)
 251      (port-forwardings `((8080 . ,http-port)))))
 252
 253   (define test
 254     (with-imported-modules '((gnu build marionette)
 255                              (guix build utils))
 256       #~(begin
 257           (use-modules (srfi srfi-64)
 258                        (rnrs io ports)
 259                        (gnu build marionette)
 260                        (guix build utils))
 261
 262           (define marionette
 263             (make-marionette (list #$vm)))
 264
 265           (mkdir #$output)
 266           (chdir #$output)
 267
 268           (test-begin "git-http")
 269
 270           ;; Wait for nginx to be up and running.
 271           (test-assert "nginx running"
 272             (marionette-eval
 273              '(begin
 274                 (use-modules (gnu services herd))
 275                 (start-service 'nginx))
 276              marionette))
 277
 278           ;; Make sure Git test repository is created.
 279           (test-assert "Git test repository"
 280             (marionette-eval
 281              '(file-exists? "/srv/git/test")
 282              marionette))
 283
 284           ;; Make sure we can clone the repo from the host.
 285           (test-equal "clone"
 286             '#$README-contents
 287             (begin
 288               (invoke #$(file-append git "/bin/git") "clone" "-v"
 289                       "http://localhost:8080/git/test" "/tmp/clone")
 290               (call-with-input-file "/tmp/clone/README"
 291                 get-string-all)))
 292
 293           (test-end)
 294           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 295
 296   (gexp->derivation "git-http" test))
 297
 298 (define %test-git-http
 299   (system-test
 300    (name "git-http")
 301    (description "Connect to a running Git HTTP server.")
 302    (value (run-git-http-test))))