[jackhill/guix/guix.git] / gnu / tests / version-control.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu tests version-control)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services version-control)
  #:use-module (gnu services cgit)
  #:use-module (gnu services web)
  #:use-module (gnu services networking)
  #:use-module (gnu packages version-control)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix modules)
  #:export (%test-cgit
            %test-git-http))

(define README-contents
  "Hello!  This is what goes inside the 'README' file.")

(define %make-git-repository
  ;; Create Git repository in /srv/git/test.
  (with-imported-modules (source-module-closure
                          '((guix build utils)))
    #~(begin
        (use-modules (guix build utils))

        (let ((git (string-append #$git "/bin/git")))
          (mkdir-p "/tmp/test-repo")
          (with-directory-excursion "/tmp/test-repo"
            (call-with-output-file "/tmp/test-repo/README"
              (lambda (port)
                (display #$README-contents port)))
            (invoke git "config" "--global" "user.email" "charlie@example.org")
            (invoke git "config" "--global" "user.name" "A U Thor")
            (invoke git "init")
            (invoke git "add" ".")
            (invoke git "commit" "-m" "That's a commit."))

          (mkdir-p "/srv/git")
          (rename-file "/tmp/test-repo/.git" "/srv/git/test")))))

(define %test-repository-service
  ;; Service that creates /srv/git/test.
  (simple-service 'make-git-repository activation-service-type
                  %make-git-repository))

(define %cgit-configuration-nginx
  (list
   (nginx-server-configuration
    (root cgit)
    (locations
     (list
      (nginx-location-configuration
       (uri "@cgit")
       (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
               "fastcgi_param PATH_INFO $uri;"
               "fastcgi_param QUERY_STRING $args;"
               "fastcgi_param HTTP_HOST $server_name;"
               "fastcgi_pass 127.0.0.1:9000;")))))
    (try-files (list "$uri" "@cgit"))
    (listen '("19418"))
    (ssl-certificate #f)
    (ssl-certificate-key #f))))

(define %cgit-os
  ;; Operating system under test.
  (let ((base-os
         (simple-operating-system
          (dhcp-client-service)
          (service cgit-service-type
                   (cgit-configuration
                    (nginx %cgit-configuration-nginx)))
          %test-repository-service)))
    (operating-system
      (inherit base-os)
      (packages (cons* git
                       (operating-system-packages base-os))))))

(define* (run-cgit-test #:optional (http-port 19418))
  "Run tests in %CGIT-OS, which has nginx running and listening on
HTTP-PORT."
  (define os
    (marionette-operating-system
     %cgit-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((8080 . ,http-port)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette)
                       (web uri)
                       (web client)
                       (web response))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "cgit")

          ;; XXX: Shepherd reads the config file *before* binding its control
          ;; socket, so /var/run/shepherd/socket might not exist yet when the
          ;; 'marionette' service is started.
          (test-assert "shepherd socket ready"
            (marionette-eval
             `(begin
                (use-modules (gnu services herd))
                (let loop ((i 10))
                  (cond ((file-exists? (%shepherd-socket-file))
                         #t)
                        ((> i 0)
                         (sleep 1)
                         (loop (- i 1)))
                        (else
                         'failure))))
             marionette))

          ;; Wait for nginx to be up and running.
          (test-eq "nginx running"
            'running!
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'nginx)
                'running!)
             marionette))

          ;; Wait for fcgiwrap to be up and running.
          (test-eq "fcgiwrap running"
            'running!
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'fcgiwrap)
                'running!)
             marionette))

          ;; Make sure the PID file is created.
          (test-assert "PID file"
            (marionette-eval
             '(file-exists? "/var/run/nginx/pid")
             marionette))

          ;; Make sure the configuration file is created.
          (test-assert "configuration file"
            (marionette-eval
             '(file-exists? "/etc/cgitrc")
             marionette))

          ;; Make sure Git test repository is created.
          (test-assert "Git test repository"
            (marionette-eval
             '(file-exists? "/srv/git/test")
             marionette))

          ;; Make sure we can access pages that correspond to our repository.
          (letrec-syntax ((test-url
                           (syntax-rules ()
                             ((_ path code)
                              (test-equal (string-append "GET " path)
                                code
                                (let-values (((response body)
                                              (http-get (string-append
                                                         "http://localhost:8080"
                                                         path))))
                                  (response-code response))))
                             ((_ path)
                              (test-url path 200)))))
            (test-url "/")
            (test-url "/test")
            (test-url "/test/log")
            (test-url "/test/tree")
            (test-url "/test/tree/README")
            (test-url "/test/does-not-exist" 404)
            (test-url "/test/tree/does-not-exist" 404)
            (test-url "/does-not-exist" 404))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "cgit-test" test))

(define %test-cgit
  (system-test
   (name "cgit")
   (description "Connect to a running Cgit server.")
   (value (run-cgit-test))))

\f
;;;
;;; Git server.
;;;

(define %git-nginx-configuration
  (nginx-configuration
   (server-blocks
    (list
     (nginx-server-configuration
      (listen '("19418"))
      (ssl-certificate #f)
      (ssl-certificate-key #f)
      (locations
       (list (git-http-nginx-location-configuration
              (git-http-configuration (export-all? #t)
                                      (uri-path "/git"))))))))))

(define %git-http-os
  (simple-operating-system
   (dhcp-client-service)
   (service fcgiwrap-service-type)
   (service nginx-service-type %git-nginx-configuration)
   %test-repository-service))

(define* (run-git-http-test #:optional (http-port 19418))
  (define os
    (marionette-operating-system
     %git-http-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((8080 . ,http-port)))))

  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build utils))
      #~(begin
          (use-modules (srfi srfi-64)
                       (rnrs io ports)
                       (gnu build marionette)
                       (guix build utils))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "git-http")

          ;; Wait for nginx to be up and running.
          (test-eq "nginx running"
            'running!
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'nginx)
                'running!)
             marionette))

          ;; Make sure Git test repository is created.
          (test-assert "Git test repository"
            (marionette-eval
             '(file-exists? "/srv/git/test")
             marionette))

          ;; Make sure we can clone the repo from the host.
          (test-equal "clone"
            '#$README-contents
            (begin
              (invoke #$(file-append git "/bin/git") "clone" "-v"
                      "http://localhost:8080/git/test" "/tmp/clone")
              (call-with-input-file "/tmp/clone/README"
                get-string-all)))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "git-http" test))

(define %test-git-http
  (system-test
   (name "git-http")
   (description "Connect to a running Git HTTP server.")
   (value (run-git-http-test))))
Commit	Line	Data
032a2760	1	;;; GNU Guix --- Functional package management for GNU
e1cf4fd2	2	;;; Copyright © 2017, 2018 Oleg Pykhalov <go.wigust@gmail.com>
bc58201e	3	;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
8b223cea	4	;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
032a2760 OP	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)
e1cf4fd2	29	#:use-module (gnu services cgit)
032a2760 OP	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)
e755692b	35	#:use-module (guix modules)
87dad874 LC	36	#:export (%test-cgit
87dad874 LC	37	%test-git-http))
032a2760	38
e755692b LC	39	(define README-contents
	40	"Hello! This is what goes inside the 'README' file.")
	41
032a2760 OP	42	(define %make-git-repository
032a2760 OP	43	;; Create Git repository in /srv/git/test.
e755692b LC	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))
032a2760 OP	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"))
8b223cea	83	(listen '("19418"))
032a2760 OP	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)
032a2760 OP	92	(service cgit-service-type
	93	(cgit-configuration
	94	(nginx %cgit-configuration-nginx)))
e755692b	95	%test-repository-service)))
032a2760 OP	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
bc58201e LC	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
032a2760	149	;; Wait for nginx to be up and running.
bc58201e	150	(test-eq "nginx running"
032a2760 OP	151	'running!
	152	(marionette-eval
	153	'(begin
	154	(use-modules (gnu services herd))
	155	(start-service 'nginx)
	156	'running!)
	157	marionette))
	158
	159	;; Wait for fcgiwrap to be up and running.
bc58201e	160	(test-eq "fcgiwrap running"
032a2760 OP	161	'running!
	162	(marionette-eval
	163	'(begin
	164	(use-modules (gnu services herd))
	165	(start-service 'fcgiwrap)
	166	'running!)
	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")
e755692b	204	(test-url "/test/tree/README")
032a2760	205	(test-url "/test/does-not-exist" 404)
e755692b	206	(test-url "/test/tree/does-not-exist" 404)
032a2760 OP	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))))
87dad874 LC	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
8b223cea	230	(listen '("19418"))
87dad874 LC	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	(dhcp-client-service)
	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-eq "nginx running"
	276	'running!
	277	(marionette-eval
	278	'(begin
	279	(use-modules (gnu services herd))
	280	(start-service 'nginx)
	281	'running!)
	282	marionette))
	283
	284	;; Make sure Git test repository is created.
	285	(test-assert "Git test repository"
	286	(marionette-eval
	287	'(file-exists? "/srv/git/test")
	288	marionette))
	289
	290	;; Make sure we can clone the repo from the host.
	291	(test-equal "clone"
	292	'#$README-contents
	293	(begin
	294	(invoke #$(file-append git "/bin/git") "clone" "-v"
295	"http://localhost:8080/git/test" "/tmp/clone")
296	(call-with-input-file "/tmp/clone/README"
297	get-string-all)))
298
299	(test-end)
300	(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
301
302	(gexp->derivation "git-http" test))
303
304	(define %test-git-http
305	(system-test
306	(name "git-http")
307	(description "Connect to a running Git HTTP server.")
308	(value (run-git-http-test))))