Merge branch 'master' into core-updates-frozen

6 files changed, 155 insertions, 21 deletions

diff --git a/gnu/tests/ganeti.scm b/gnu/tests/ganeti.scm
index 19c26b86dd..b64a332dde 100644
--- a/gnu/tests/ganeti.scm
+++ b/gnu/tests/ganeti.scm
@@ -38,7 +38,7 @@
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vda")))
+                 (targets '("/dev/vda"))))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
                           (mount-point "/")
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 80604361e0..130a4f76b0 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -4,7 +4,7 @@
 ;;; Copyright © 2020 Mathieu Othacehe <[email protected]>
 ;;; Copyright © 2020 Danny Milosavljevic <[email protected]>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email protected]>
-;;; Copyright © 2020 Maxim Cournoyer <[email protected]>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -97,7 +97,7 @@
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
@@ -135,7 +135,7 @@
 
     (bootloader (bootloader-configuration
                  (bootloader extlinux-bootloader-gpt)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
@@ -418,7 +418,7 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vda")))
+                 (targets (list "/dev/vda"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
@@ -494,7 +494,7 @@ reboot\n")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets '("/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons* (file-system
                            (device (file-system-label "my-root"))
@@ -549,7 +549,7 @@ partition.  In particular, home directories must be correctly created (see
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons* (file-system
                            (device (file-system-label "root-fs"))
@@ -626,7 +626,7 @@ where /gnu lives on a separate partition.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
 
     ;; Add a kernel module for RAID-1 (aka. "mirror").
@@ -709,7 +709,7 @@ by 'mdadm'.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets '("/dev/vdb"))))
 
     ;; Note: Do not pass "console=ttyS0" so we can use our passphrase prompt
     ;; detection logic in 'enter-luks-passphrase'.
@@ -842,7 +842,7 @@ build (current-guix) and then store a couple of full system images.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
 
     (mapped-devices (list (mapped-device
@@ -929,7 +929,7 @@ reboot\n")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
 
     (mapped-devices (list (mapped-device
                            (source
@@ -1029,7 +1029,7 @@ store a couple of full system images.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
@@ -1103,7 +1103,7 @@ build (current-guix) and then store a couple of full system images.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
 
     (file-systems (cons (file-system
@@ -1171,7 +1171,7 @@ RAID-0 (stripe) root partition.")
     (locale "en_US.UTF-8")
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons* (file-system
                            (device (file-system-label "btrfs-pool"))
@@ -1264,7 +1264,7 @@ build (current-guix) and then store a couple of full system images.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
@@ -1337,7 +1337,7 @@ build (current-guix) and then store a couple of full system images.")
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/vdb")))
+                 (targets (list "/dev/vdb"))))
     (kernel-arguments '("console=ttyS0"))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm
index 9b2b785176..a0c091eadb 100644
--- a/gnu/tests/nfs.scm
+++ b/gnu/tests/nfs.scm
@@ -50,7 +50,7 @@
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/sdX")))
+                 (targets '("/dev/sdX"))))
     (file-systems %base-file-systems)
     (users %base-user-accounts)
     (packages (cons*
diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm
index 52beeef447..001b5d185a 100644
--- a/gnu/tests/reconfigure.scm
+++ b/gnu/tests/reconfigure.scm
@@ -261,7 +261,7 @@ bootloader's configuration file."
      ;; would attempt to write directly to the virtual disk if the
      ;; installation script were run.
      (test
-      (install-bootloader-program #f #f #f bootcfg bootcfg-file #f "/")))))
+      (install-bootloader-program #f #f #f bootcfg bootcfg-file '(#f) "/")))))
 
 
 (define %test-switch-to-system
diff --git a/gnu/tests/telephony.scm b/gnu/tests/telephony.scm
index 1155a9dbc2..aeb6500c47 100644
--- a/gnu/tests/telephony.scm
+++ b/gnu/tests/telephony.scm
@@ -74,7 +74,7 @@
 
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
-                 (target "/dev/sdX")))
+                 (targets '("/dev/sdX"))))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
                           (mount-point "/")
diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm
index d3cf19c913..a7cde1f163 100644
--- a/gnu/tests/version-control.scm
+++ b/gnu/tests/version-control.scm
@@ -38,7 +38,8 @@
   #:use-module (guix modules)
   #:export (%test-cgit
             %test-git-http
-            %test-gitolite))
+            %test-gitolite
+            %test-gitile))
 
 (define README-contents
   "Hello!  This is what goes inside the 'README' file.")
@@ -63,7 +64,10 @@
             (invoke git "commit" "-m" "That's a commit."))
 
           (mkdir-p "/srv/git")
-          (rename-file "/tmp/test-repo/.git" "/srv/git/test")))))
+          (rename-file "/tmp/test-repo/.git" "/srv/git/test")
+          (with-output-to-file "/srv/git/test/git-daemon-export-ok"
+            (lambda _
+              (display "")))))))
 
 (define %test-repository-service
   ;; Service that creates /srv/git/test.
@@ -416,3 +420,133 @@ HTTP-PORT."
    (name "gitolite")
    (description "Clone the Gitolite admin repository.")
    (value (run-gitolite-test))))
+
+;;;
+;;; Gitile.
+;;;
+
+(define %gitile-configuration-nginx
+  (nginx-server-configuration
+   (root "/does/not/exists")
+   (try-files (list "$uri" "=404"))
+   (listen '("19418"))
+   (ssl-certificate #f)
+   (ssl-certificate-key #f)))
+
+(define %gitile-os
+  ;; Operating system under test.
+  (simple-operating-system
+   (service dhcp-client-service-type)
+   (simple-service 'srv-git activation-service-type
+                   #~(mkdir-p "/srv/git"))
+   (service gitile-service-type
+            (gitile-configuration
+             (base-git-url "http://localhost")
+             (repositories "/srv/git")
+             (nginx %gitile-configuration-nginx)))
+   %test-repository-service))
+
+(define* (run-gitile-test #:optional (http-port 19418))
+  "Run tests in %GITOLITE-OS, which has nginx running and listening on
+HTTP-PORT."
+  (define os
+    (marionette-operating-system
+     %gitile-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings `((8081 . ,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 "gitile")
+
+          ;; 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-assert "nginx running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'nginx))
+             marionette))
+
+          ;; Make sure the PID file is created.
+          (test-assert "PID file"
+            (marionette-eval
+             '(file-exists? "/var/run/nginx/pid")
+             marionette))
+
+          ;; Make sure Git test repository is created.
+          (test-assert "Git test repository"
+            (marionette-eval
+             '(file-exists? "/srv/git/test")
+             marionette))
+
+          (sleep 2)
+
+          ;; 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:8081"
+                                                         path))))
+                                  (response-code response))))
+                             ((_ path)
+                              (test-url path 200)))))
+            (test-url "/")
+            (test-url "/css/gitile.css")
+            (test-url "/test")
+            (test-url "/test/commits")
+            (test-url "/test/tree" 404)
+            (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 "gitile-test" test))
+
+(define %test-gitile
+  (system-test
+   (name "gitile")
+   (description "Connect to a running Gitile server.")
+   (value (run-gitile-test))))