aboutsummaryrefslogtreecommitdiff
path: root/gnu/tests
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/tests')
-rw-r--r--gnu/tests/admin.scm127
-rw-r--r--gnu/tests/base.scm43
-rw-r--r--gnu/tests/databases.scm4
-rw-r--r--gnu/tests/dict.scm2
-rw-r--r--gnu/tests/mail.scm6
-rw-r--r--gnu/tests/messaging.scm4
-rw-r--r--gnu/tests/monitoring.scm2
-rw-r--r--gnu/tests/networking.scm226
-rw-r--r--gnu/tests/nfs.scm2
-rw-r--r--gnu/tests/rsync.scm2
-rw-r--r--gnu/tests/ssh.scm2
-rw-r--r--gnu/tests/version-control.scm118
-rw-r--r--gnu/tests/virtualization.scm2
-rw-r--r--gnu/tests/web.scm149
14 files changed, 533 insertions, 156 deletions
diff --git a/gnu/tests/admin.scm b/gnu/tests/admin.scm
deleted file mode 100644
index a5abbe9ad4..0000000000
--- a/gnu/tests/admin.scm
+++ /dev/null
@@ -1,127 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
-;;; Copyright © 2018 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 admin)
- #: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 admin)
- #:use-module (gnu services networking)
- #:use-module (guix gexp)
- #:use-module (guix store)
- #:use-module (guix monads)
- #:export (%test-tailon))
-
-(define %tailon-os
- ;; Operating system under test.
- (simple-operating-system
- (dhcp-client-service)
- (service tailon-service-type
- (tailon-configuration
- (config-file
- (tailon-configuration-file
- (bind "0.0.0.0:8080")))))))
-
-(define* (run-tailon-test #:optional (http-port 8081))
- "Run tests in %TAILON-OS, which has tailon running and listening on
-HTTP-PORT."
- (define os
- (marionette-operating-system
- %tailon-os
- #:imported-modules '((gnu services herd)
- (guix combinators))))
-
- (define vm
- (virtual-machine
- (operating-system os)
- (port-forwardings `((,http-port . 8080)))))
-
- (define test
- (with-imported-modules '((gnu build marionette))
- #~(begin
- (use-modules (srfi srfi-11) (srfi srfi-64)
- (ice-9 match)
- (gnu build marionette)
- (web uri)
- (web client)
- (web response))
-
- (define marionette
- ;; Forward the guest's HTTP-PORT, where tailon is listening, to
- ;; port 8080 in the host.
- (make-marionette (list #$vm)))
-
- (mkdir #$output)
- (chdir #$output)
-
- (test-begin "tailon")
-
- (test-assert "service running"
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'tailon))
- marionette))
-
- (define* (retry-on-error f #:key times delay)
- (let loop ((attempt 1))
- (match (catch
- #t
- (lambda ()
- (cons #t
- (f)))
- (lambda args
- (cons #f
- args)))
- ((#t . return-value)
- return-value)
- ((#f . error-args)
- (if (>= attempt times)
- error-args
- (begin
- (sleep delay)
- (loop (+ 1 attempt))))))))
-
- (test-equal "http-get"
- 200
- (retry-on-error
- (lambda ()
- (let-values (((response text)
- (http-get #$(format
- #f
- "http://localhost:~A/"
- http-port)
- #:decode-body? #t)))
- (response-code response)))
- #:times 10
- #:delay 5))
-
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
-
- (gexp->derivation "tailon-test" test))
-
-(define %test-tailon
- (system-test
- (name "tailon")
- (description "Connect to a running Tailon server.")
- (value (run-tailon-test))))
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index f27064af85..03392cef38 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -42,6 +42,7 @@
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
#:export (run-basic-test
%test-basic-os
%test-halt
@@ -68,6 +69,11 @@ initialization step, such as entering a LUKS passphrase."
(fold-services (operating-system-services os)
#:target-type special-files-service-type)))
+ (define guix&co
+ (match (package-transitive-propagated-inputs guix)
+ (((labels packages) ...)
+ (cons guix packages))))
+
(define test
(with-imported-modules '((gnu build marionette)
(guix build syscalls))
@@ -148,10 +154,15 @@ info --version")
(#f (reverse result))
(x (loop (cons x result))))))
marionette)))
- (lset= string=?
- (map passwd:name users)
+ (lset= equal?
+ (map (lambda (user)
+ (list (passwd:name user)
+ (passwd:dir user)))
+ users)
(list
- #$@(map user-account-name
+ #$@(map (lambda (account)
+ `(list ,(user-account-name account)
+ ,(user-account-home-directory account)))
(operating-system-user-accounts os))))))
(test-assert "shepherd services"
@@ -329,6 +340,20 @@ info --version")
(x
(pk 'failure x #f))))
+ (test-equal "nscd invalidate action"
+ '(#t) ;one value, #t
+ (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts")
+ result
+ result)
+ marionette))
+
+ (test-equal "nscd invalidate action, wrong table"
+ '(#f) ;one value, #f
+ (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
+ result
+ result)
+ marionette))
+
(test-equal "host not found"
#f
(marionette-eval
@@ -345,8 +370,14 @@ info --version")
'success!
(marionette-eval '(begin
;; Make sure the (guix …) modules are found.
- (add-to-load-path
- #+(file-append guix "/share/guile/site/2.2"))
+ (eval-when (expand load eval)
+ (set! %load-path
+ (append (map (lambda (package)
+ (string-append package
+ "/share/guile/site/"
+ (effective-version)))
+ '#$guix&co)
+ %load-path)))
(use-modules (srfi srfi-34) (guix store))
@@ -661,7 +692,7 @@ non-ASCII names from /tmp.")
(name-service-switch %mdns-host-lookup-nss)
(services (cons* (avahi-service #:debug? #t)
(dbus-service)
- (dhcp-client-service) ;needed for multicast
+ (service dhcp-client-service-type) ;needed for multicast
;; Enable heavyweight debugging output.
(modify-services (operating-system-user-services
diff --git a/gnu/tests/databases.scm b/gnu/tests/databases.scm
index 5c8ca85c13..e0544bbcd2 100644
--- a/gnu/tests/databases.scm
+++ b/gnu/tests/databases.scm
@@ -35,7 +35,7 @@
(define %memcached-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service memcached-service-type)))
(define* (run-memcached-test #:optional (port 11211))
@@ -130,7 +130,7 @@
(operating-system
(inherit
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service mongodb-service-type)))
(packages (cons* mongodb
%base-packages))))
diff --git a/gnu/tests/dict.scm b/gnu/tests/dict.scm
index dd60ffd464..c50e3cd6da 100644
--- a/gnu/tests/dict.scm
+++ b/gnu/tests/dict.scm
@@ -34,7 +34,7 @@
(define %dicod-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service dicod-service-type
(dicod-configuration
(interfaces '("0.0.0.0"))
diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm
index 5677969fac..33aa4d3437 100644
--- a/gnu/tests/mail.scm
+++ b/gnu/tests/mail.scm
@@ -36,7 +36,7 @@
(define %opensmtpd-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service opensmtpd-service-type
(opensmtpd-configuration
(config-file
@@ -155,7 +155,7 @@ accept from any for local deliver to mbox
(define %exim-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service mail-aliases-service-type '())
(service exim-service-type
(exim-configuration
@@ -283,7 +283,7 @@ acl_check_data:
(define %dovecot-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(dovecot-service #:config
(dovecot-configuration
(disable-plaintext-auth? #f)
diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm
index f5f99b9f56..36afb987af 100644
--- a/gnu/tests/messaging.scm
+++ b/gnu/tests/messaging.scm
@@ -35,7 +35,7 @@
"Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
(define os
(marionette-operating-system
- (simple-operating-system (dhcp-client-service)
+ (simple-operating-system (service dhcp-client-service-type)
xmpp-service)
#:imported-modules '((gnu services herd))))
@@ -167,7 +167,7 @@
(define (run-bitlbee-test)
(define os
(marionette-operating-system
- (simple-operating-system (dhcp-client-service)
+ (simple-operating-system (service dhcp-client-service-type)
(service bitlbee-service-type
(bitlbee-configuration
(interface "0.0.0.0"))))
diff --git a/gnu/tests/monitoring.scm b/gnu/tests/monitoring.scm
index 67899987ce..3320a19a77 100644
--- a/gnu/tests/monitoring.scm
+++ b/gnu/tests/monitoring.scm
@@ -85,7 +85,7 @@
(define %prometheus-node-exporter-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service prometheus-node-exporter-service-type
(prometheus-node-exporter-configuration))))
diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm
index 323679e7fc..9f12a4ae8d 100644
--- a/gnu/tests/networking.scm
+++ b/gnu/tests/networking.scm
@@ -1,6 +1,8 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,14 +30,16 @@
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (gnu packages bash)
+ #:use-module (gnu packages linux)
#:use-module (gnu packages networking)
#:use-module (gnu services shepherd)
- #:export (%test-inetd %test-openvswitch %test-dhcpd))
+ #:use-module (ice-9 match)
+ #:export (%test-inetd %test-openvswitch %test-dhcpd %test-tor %test-iptables))
(define %inetd-os
;; Operating system with 2 inetd services.
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service inetd-service-type
(inetd-configuration
(entries (list
@@ -339,3 +343,221 @@ subnet 192.168.1.0 netmask 255.255.255.0 {
(name "dhcpd")
(description "Test a running DHCP daemon configuration.")
(value (run-dhcpd-test))))
+
+
+;;;
+;;; Services related to Tor
+;;;
+
+(define %tor-os
+ (simple-operating-system
+ (tor-service)))
+
+(define %tor-os/unix-socks-socket
+ (simple-operating-system
+ (service tor-service-type
+ (tor-configuration
+ (socks-socket-type 'unix)))))
+
+(define (run-tor-test)
+ (define os
+ (marionette-operating-system %tor-os
+ #:imported-modules '((gnu services herd))
+ #:requirements '(tor)))
+
+ (define os/unix-socks-socket
+ (marionette-operating-system %tor-os/unix-socks-socket
+ #:imported-modules '((gnu services herd))
+ #:requirements '(tor)))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (gnu build marionette)
+ (ice-9 popen)
+ (ice-9 rdelim)
+ (srfi srfi-64))
+
+ (define marionette
+ (make-marionette (list #$(virtual-machine os))))
+
+ (define (tor-is-alive? marionette)
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd)
+ (srfi srfi-1))
+ (live-service-running
+ (find (lambda (live)
+ (memq 'tor
+ (live-service-provision live)))
+ (current-services))))
+ marionette))
+
+ (mkdir #$output)
+ (chdir #$output)
+
+ (test-begin "tor")
+
+ ;; Test the usual Tor service.
+
+ (test-assert "tor is alive"
+ (tor-is-alive? marionette))
+
+ (test-assert "tor is listening"
+ (let ((default-port 9050))
+ (wait-for-tcp-port default-port marionette)))
+
+ ;; Don't run two VMs at once.
+ (marionette-control "quit" marionette)
+
+ ;; Test the Tor service using a SOCKS socket.
+
+ (let* ((socket-directory "/tmp/more-sockets")
+ (_ (mkdir socket-directory))
+ (marionette/unix-socks-socket
+ (make-marionette
+ (list #$(virtual-machine os/unix-socks-socket))
+ ;; We can't use the same socket directory as the first
+ ;; marionette.
+ #:socket-directory socket-directory)))
+ (test-assert "tor is alive, even when using a SOCKS socket"
+ (tor-is-alive? marionette/unix-socks-socket))
+
+ (test-assert "tor is listening, even when using a SOCKS socket"
+ (wait-for-unix-socket "/var/run/tor/socks-sock"
+ marionette/unix-socks-socket)))
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation "tor-test" test))
+
+(define %test-tor
+ (system-test
+ (name "tor")
+ (description "Test a running Tor daemon configuration.")
+ (value (run-tor-test))))
+
+(define* (run-iptables-test)
+ "Run tests of 'iptables-service-type'."
+ (define iptables-rules
+ "*filter
+:INPUT ACCEPT
+:FORWARD ACCEPT
+:OUTPUT ACCEPT
+-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp-port-unreachable
+COMMIT
+")
+
+ (define ip6tables-rules
+ "*filter
+:INPUT ACCEPT
+:FORWARD ACCEPT
+:OUTPUT ACCEPT
+-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp6-port-unreachable
+COMMIT
+")
+
+ (define inetd-echo-port 7)
+
+ (define os
+ (marionette-operating-system
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service inetd-service-type
+ (inetd-configuration
+ (entries (list
+ (inetd-entry
+ (name "echo")
+ (socket-type 'stream)
+ (protocol "tcp")
+ (wait? #f)
+ (user "root"))))))
+ (service iptables-service-type
+ (iptables-configuration
+ (ipv4-rules (plain-file "iptables.rules" iptables-rules))
+ (ipv6-rules (plain-file "ip6tables.rules" ip6tables-rules)))))
+ #:imported-modules '((gnu services herd))
+ #:requirements '(inetd iptables)))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (srfi srfi-64)
+ (gnu build marionette))
+ (define marionette
+ (make-marionette (list #$(virtual-machine os))))
+
+ (define (dump-iptables iptables-save marionette)
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim)
+ (ice-9 regex))
+ (call-with-output-string
+ (lambda (out)
+ (call-with-port
+ (open-pipe* OPEN_READ ,iptables-save)
+ (lambda (in)
+ (let loop ((line (read-line in)))
+ ;; iptables-save does not output rules in the exact
+ ;; same format we loaded using iptables-restore. It
+ ;; adds comments, packet counters, etc. We remove
+ ;; these additions.
+ (unless (eof-object? line)
+ (cond
+ ;; Remove comments
+ ((string-match "^#" line) #t)
+ ;; Remove packet counters
+ ((string-match "^:([A-Z]*) ([A-Z]*) .*" line)
+ => (lambda (match-record)
+ (format out ":~a ~a~%"
+ (match:substring match-record 1)
+ (match:substring match-record 2))))
+ ;; Pass other lines without modification
+ (else (display line out)
+ (newline out)))
+ (loop (read-line in)))))))))
+ marionette))
+
+ (mkdir #$output)
+ (chdir #$output)
+
+ (test-begin "iptables")
+
+ (test-equal "iptables-save dumps the same rules that were loaded"
+ (dump-iptables #$(file-append iptables "/sbin/iptables-save")
+ marionette)
+ #$iptables-rules)
+
+ (test-equal "ip6tables-save dumps the same rules that were loaded"
+ (dump-iptables #$(file-append iptables "/sbin/ip6tables-save")
+ marionette)
+ #$ip6tables-rules)
+
+ (test-error "iptables firewall blocks access to inetd echo service"
+ 'misc-error
+ (wait-for-tcp-port inetd-echo-port marionette #:timeout 5))
+
+ ;; TODO: This test freezes up at the login prompt without any
+ ;; relevant messages on the console. Perhaps it is waiting for some
+ ;; timeout. Find and fix this issue.
+ ;; (test-assert "inetd echo service is accessible after iptables firewall is stopped"
+ ;; (begin
+ ;; (marionette-eval
+ ;; '(begin
+ ;; (use-modules (gnu services herd))
+ ;; (stop-service 'iptables))
+ ;; marionette)
+ ;; (wait-for-tcp-port inetd-echo-port marionette #:timeout 5)))
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation "iptables" test))
+
+(define %test-iptables
+ (system-test
+ (name "iptables")
+ (description "Test a running iptables daemon.")
+ (value (run-iptables-test))))
diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm
index 140f03779b..7ef9f1f7bf 100644
--- a/gnu/tests/nfs.scm
+++ b/gnu/tests/nfs.scm
@@ -55,7 +55,7 @@
(services (cons*
(service rpcbind-service-type
(rpcbind-configuration))
- (dhcp-client-service)
+ (service dhcp-client-service-type)
%base-services))))
(define (run-nfs-test name socket)
diff --git a/gnu/tests/rsync.scm b/gnu/tests/rsync.scm
index a6f8fa2bd1..096580022f 100644
--- a/gnu/tests/rsync.scm
+++ b/gnu/tests/rsync.scm
@@ -111,7 +111,7 @@ PORT."
;; Return operating system under test.
(let ((base-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service rsync-service-type))))
(operating-system
(inherit base-os)
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index 2e40122add..e5cd439cdf 100644
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -39,7 +39,7 @@ empty-password logins.
When SFTP? is true, run an SFTP server test."
(define os
(marionette-operating-system
- (simple-operating-system (dhcp-client-service) ssh-service)
+ (simple-operating-system (service dhcp-client-service-type) ssh-service)
#:imported-modules '((gnu services herd)
(guix combinators))))
(define vm
diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm
index 3b935a1b48..230aa9edf9 100644
--- a/gnu/tests/version-control.scm
+++ b/gnu/tests/version-control.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2017, 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,14 +28,17 @@
#:use-module (gnu services)
#:use-module (gnu services version-control)
#:use-module (gnu services cgit)
+ #:use-module (gnu services ssh)
#:use-module (gnu services web)
#:use-module (gnu services networking)
#:use-module (gnu packages version-control)
+ #:use-module (gnu packages ssh)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix modules)
#:export (%test-cgit
- %test-git-http))
+ %test-git-http
+ %test-gitolite))
(define README-contents
"Hello! This is what goes inside the 'README' file.")
@@ -88,7 +92,7 @@
;; Operating system under test.
(let ((base-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service cgit-service-type
(cgit-configuration
(nginx %cgit-configuration-nginx)))
@@ -233,7 +237,7 @@ HTTP-PORT."
(define %git-http-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service fcgiwrap-service-type)
(service nginx-service-type %git-nginx-configuration)
%test-repository-service))
@@ -300,3 +304,111 @@ HTTP-PORT."
(name "git-http")
(description "Connect to a running Git HTTP server.")
(value (run-git-http-test))))
+
+
+;;;
+;;; Gitolite.
+;;;
+
+(define %gitolite-test-admin-keypair
+ (computed-file
+ "gitolite-test-admin-keypair"
+ (with-imported-modules (source-module-closure
+ '((guix build utils)))
+ #~(begin
+ (use-modules (ice-9 match) (srfi srfi-26)
+ (guix build utils))
+
+ (mkdir #$output)
+ (invoke #$(file-append openssh "/bin/ssh-keygen")
+ "-f" (string-append #$output "/test-admin")
+ "-t" "rsa"
+ "-q"
+ "-N" "")))))
+
+(define %gitolite-os
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service openssh-service-type)
+ (service gitolite-service-type
+ (gitolite-configuration
+ (admin-pubkey
+ (file-append %gitolite-test-admin-keypair "/test-admin.pub"))))))
+
+(define (run-gitolite-test)
+ (define os
+ (marionette-operating-system
+ %gitolite-os
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (port-forwardings `((2222 . 22)))))
+
+ (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 "gitolite")
+
+ ;; Wait for sshd to be up and running.
+ (test-assert "service running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (start-service 'ssh-daemon))
+ marionette))
+
+ (display #$%gitolite-test-admin-keypair)
+
+ (setenv "GIT_SSH_VARIANT" "ssh")
+ (setenv "GIT_SSH_COMMAND"
+ (string-join
+ '(#$(file-append openssh "/bin/ssh")
+ "-i" #$(file-append %gitolite-test-admin-keypair
+ "/test-admin")
+ "-o" "UserKnownHostsFile=/dev/null"
+ "-o" "StrictHostKeyChecking=no")))
+
+ (test-assert "cloning the admin repository"
+ (invoke #$(file-append git "/bin/git")
+ "clone" "-v"
+ "ssh://git@localhost:2222/gitolite-admin"
+ "/tmp/clone"))
+
+ (test-assert "admin key exists"
+ (file-exists? "/tmp/clone/keydir/test-admin.pub"))
+
+ (with-directory-excursion "/tmp/clone"
+ (invoke #$(file-append git "/bin/git")
+ "-c" "user.name=Guix" "-c" "user.email=guix"
+ "commit"
+ "-m" "Test commit"
+ "--allow-empty")
+
+ (test-assert "pushing, and the associated hooks"
+ (invoke #$(file-append git "/bin/git") "push")))
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation "gitolite" test))
+
+(define %test-gitolite
+ (system-test
+ (name "gitolite")
+ (description "Clone the Gitolite admin repository.")
+ (value (run-gitolite-test))))
diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm
index c2939355b2..fbdec20805 100644
--- a/gnu/tests/virtualization.scm
+++ b/gnu/tests/virtualization.scm
@@ -32,7 +32,7 @@
(define %libvirt-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(dbus-service)
(polkit-service)
(service libvirt-service-type)))
diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index 73d502dd0e..319655396a 100644
--- a/gnu/tests/web.scm
+++ b/gnu/tests/web.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
+;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,8 +33,10 @@
#:use-module (guix store)
#:export (%test-httpd
%test-nginx
+ %test-varnish
%test-php-fpm
- %test-hpcguix-web))
+ %test-hpcguix-web
+ %test-tailon))
(define %index.html-contents
;; Contents of the /index.html file.
@@ -122,7 +125,7 @@ HTTP-PORT."
(define %httpd-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service httpd-service-type
(httpd-configuration
(config
@@ -151,7 +154,7 @@ HTTP-PORT."
(define %nginx-os
;; Operating system under test.
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service nginx-service-type
(nginx-configuration
(log-directory "/var/log/nginx")
@@ -168,6 +171,46 @@ HTTP-PORT."
;;;
+;;; Varnish
+;;;
+
+(define %varnish-vcl
+ (mixed-text-file
+ "varnish-test.vcl"
+ "vcl 4.0;
+backend dummy { .host = \"127.1.1.1\"; }
+sub vcl_recv { return(synth(200, \"OK\")); }
+sub vcl_synth {
+ synthetic(\"" %index.html-contents "\");
+ set resp.http.Content-Type = \"text/plain\";
+ return(deliver);
+}"))
+
+(define %varnish-os
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ ;; Pretend to be a web server that serves %index.html-contents.
+ (service varnish-service-type
+ (varnish-configuration
+ (name "/tmp/server")
+ ;; Use a small VSL buffer to fit in the test VM.
+ (parameters '(("vsl_space" . "4M")))
+ (vcl %varnish-vcl)))
+ ;; Proxy the "server" using the builtin configuration.
+ (service varnish-service-type
+ (varnish-configuration
+ (parameters '(("vsl_space" . "4M")))
+ (backend "localhost:80")
+ (listen '(":8080"))))))
+
+(define %test-varnish
+ (system-test
+ (name "varnish")
+ (description "Test the Varnish Cache server.")
+ (value (run-webserver-test "varnish-default" %varnish-os))))
+
+
+;;;
;;; PHP-FPM
;;;
@@ -194,7 +237,7 @@ echo(\"Computed by php:\".((string)(2+3)));
(define %php-fpm-os
;; Operating system under test.
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service php-fpm-service-type)
(service nginx-service-type
(nginx-configuration
@@ -349,7 +392,7 @@ HTTP-PORT, along with php-fpm."
(define %hpcguix-web-os
(simple-operating-system
- (dhcp-client-service)
+ (service dhcp-client-service-type)
(service hpcguix-web-service-type
(hpcguix-web-configuration
(specs %hpcguix-web-specs)))))
@@ -359,3 +402,99 @@ HTTP-PORT, along with php-fpm."
(name "hpcguix-web")
(description "Connect to a running hpcguix-web server.")
(value (run-hpcguix-web-server-test name %hpcguix-web-os))))
+
+
+(define %tailon-os
+ ;; Operating system under test.
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service tailon-service-type
+ (tailon-configuration
+ (config-file
+ (tailon-configuration-file
+ (bind "0.0.0.0:8080")))))))
+
+(define* (run-tailon-test #:optional (http-port 8081))
+ "Run tests in %TAILON-OS, which has tailon running and listening on
+HTTP-PORT."
+ (define os
+ (marionette-operating-system
+ %tailon-os
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (port-forwardings `((,http-port . 8080)))))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (srfi srfi-11) (srfi srfi-64)
+ (ice-9 match)
+ (gnu build marionette)
+ (web uri)
+ (web client)
+ (web response))
+
+ (define marionette
+ ;; Forward the guest's HTTP-PORT, where tailon is listening, to
+ ;; port 8080 in the host.
+ (make-marionette (list #$vm)))
+
+ (mkdir #$output)
+ (chdir #$output)
+
+ (test-begin "tailon")
+
+ (test-assert "service running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (start-service 'tailon))
+ marionette))
+
+ (define* (retry-on-error f #:key times delay)
+ (let loop ((attempt 1))
+ (match (catch
+ #t
+ (lambda ()
+ (cons #t
+ (f)))
+ (lambda args
+ (cons #f
+ args)))
+ ((#t . return-value)
+ return-value)
+ ((#f . error-args)
+ (if (>= attempt times)
+ error-args
+ (begin
+ (sleep delay)
+ (loop (+ 1 attempt))))))))
+
+ (test-equal "http-get"
+ 200
+ (retry-on-error
+ (lambda ()
+ (let-values (((response text)
+ (http-get #$(format
+ #f
+ "http://localhost:~A/"
+ http-port)
+ #:decode-body? #t)))
+ (response-code response)))
+ #:times 10
+ #:delay 5))
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation "tailon-test" test))
+
+(define %test-tailon
+ (system-test
+ (name "tailon")
+ (description "Connect to a running Tailon server.")
+ (value (run-tailon-test))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-29 01:36:28 +0000