-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.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 web)
- #:use-module (gnu tests)
- #:use-module (gnu system)
- #:use-module (gnu system grub)
- #:use-module (gnu system file-systems)
- #:use-module (gnu system shadow)
- #:use-module (gnu system vm)
- #:use-module (gnu services)
- #:use-module (gnu services base)
- #:use-module (gnu services web)
- #:use-module (gnu services networking)
- #:use-module (guix gexp)
- #:use-module (guix store)
- #:use-module (guix monads)
- #:export (%test-nginx))
-
-(define %index.html-contents
- ;; Contents of the /index.html file served by nginx.
- "Hello, nginx!")
-
-(define %make-http-root
- ;; Create our server root in /srv.
- #~(begin
- (mkdir "/srv")
- (call-with-output-file "/srv/index.html"
- (lambda (port)
- (display #$%index.html-contents port)))))
-
-(define %nginx-servers
- ;; Server blocks.
- (list (nginx-server-configuration
- (root "/srv")
- (http-port 8042)
- (https-port #f)
- (ssl-certificate #f)
- (ssl-certificate-key #f))))
-
-(define %nginx-os
- ;; Operating system under test.
- (operating-system
- (host-name "komputilo")
- (timezone "Europe/Berlin")
- (locale "en_US.utf8")
-
- (bootloader (grub-configuration (device "/dev/sdX")))
- (file-systems %base-file-systems)
- (firmware '())
- (users %base-user-accounts)
- (services (cons* (dhcp-client-service)
- (service nginx-service-type
- (nginx-configuration
- (log-directory "/var/log/nginx")
- (server-blocks %nginx-servers)))
- (simple-service 'make-http-root activation-service-type
- %make-http-root)
- %base-services))))
-
-(define* (run-nginx-test #:optional (http-port 8042))
- "Run tests in %NGINX-OS, which has nginx running and listening on
-HTTP-PORT."
- (mlet* %store-monad ((os -> (marionette-operating-system
- %nginx-os
- #:imported-modules '((gnu services herd)
- (guix combinators))))
- (command (system-qemu-image/shared-store-script
- os #:graphic? #f)))
- (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
- ;; Forward the guest's HTTP-PORT, where nginx is listening, to
- ;; port 8080 in the host.
- (make-marionette (list #$command "-net"
- (string-append
- "user,hostfwd=tcp::8080-:"
- #$(number->string http-port)))))
-
- (mkdir #$output)
- (chdir #$output)
-
- (test-begin "nginx")
-
- ;; Wait for nginx to be up and running.
- (test-eq "service running"
- 'running!
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'nginx)
- 'running!)
- marionette))
-
- ;; Make sure the PID file is created.
- (test-assert "PID file"
- (marionette-eval
- '(file-exists? "/var/run/nginx/pid")
- marionette))
-
- ;; Retrieve the index.html file we put in /srv.
- (test-equal "http-get"
- '(200 #$%index.html-contents)
- (let-values (((response text)
- (http-get "http://localhost:8080/index.html"
- #:decode-body? #t)))
- (list (response-code response) text)))
-
- ;; There should be a log file in here.
- (test-assert "log file"
- (marionette-eval
- '(file-exists? "/var/log/nginx/access.log")
- marionette))
-
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
-
- (gexp->derivation "nginx-test" test)))
-
-(define %test-nginx
- (system-test
- (name "nginx")
- (description "Connect to a running NGINX server.")
- (value (run-nginx-test))))
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019 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.
+;;;
+;;; 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 web)
+ #: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 web)
+ #:use-module (gnu services databases)
+ #:use-module (gnu services getmail)
+ #:use-module (gnu services networking)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services mail)
+ #:use-module (gnu packages databases)
+ #:use-module (gnu packages patchutils)
+ #:use-module (gnu packages python)
+ #:use-module (gnu packages web)
+ #:use-module (guix packages)
+ #:use-module (guix modules)
+ #:use-module (guix records)
+ #:use-module (guix gexp)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (ice-9 match)
+ #:export (%test-httpd
+ %test-nginx
+ %test-varnish
+ %test-php-fpm
+ %test-hpcguix-web
+ %test-tailon
+ %test-patchwork))
+
+(define %index.html-contents
+ ;; Contents of the /index.html file.
+ "Hello, guix!")
+
+(define %make-http-root
+ ;; Create our server root in /srv.
+ #~(begin
+ (mkdir "/srv")
+ (mkdir "/srv/http")
+ (call-with-output-file "/srv/http/index.html"
+ (lambda (port)
+ (display #$%index.html-contents port)))))
+
+(define* (run-webserver-test name test-os #:key (log-file #f) (http-port 8080))
+ "Run tests in %NGINX-OS, which has nginx running and listening on
+HTTP-PORT."
+ (define os
+ (marionette-operating-system
+ test-os
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define forwarded-port 8080)
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (port-forwardings `((,http-port . ,forwarded-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 #$name)
+
+ (test-assert #$(string-append name " service running")
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (match (start-service '#$(string->symbol name))
+ (#f #f)
+ (('service response-parts ...)
+ (match (assq-ref response-parts 'running)
+ ((#t) #t)
+ ((pid) (number? pid))))))
+ marionette))
+
+ (test-assert "HTTP port ready"
+ (wait-for-tcp-port #$forwarded-port marionette))
+
+ ;; Retrieve the index.html file we put in /srv.
+ (test-equal "http-get"
+ '(200 #$%index.html-contents)
+ (let-values
+ (((response text)
+ (http-get #$(simple-format
+ #f "http://localhost:~A/index.html" forwarded-port)
+ #:decode-body? #t)))
+ (list (response-code response) text)))
+
+ #$@(if log-file
+ `((test-assert ,(string-append "log file exists " log-file)
+ (marionette-eval
+ '(file-exists? ,log-file)
+ marionette)))
+ '())
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation (string-append name "-test") test))
+
+\f
+;;;
+;;; HTTPD
+;;;
+
+(define %httpd-os
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service httpd-service-type
+ (httpd-configuration
+ (config
+ (httpd-config-file
+ (listen '("8080"))))))
+ (simple-service 'make-http-root activation-service-type
+ %make-http-root)))
+
+(define %test-httpd
+ (system-test
+ (name "httpd")
+ (description "Connect to a running HTTPD server.")
+ (value (run-webserver-test name %httpd-os
+ #:log-file "/var/log/httpd/error_log"))))
+
+\f
+;;;
+;;; NGINX
+;;;
+
+(define %nginx-servers
+ ;; Server blocks.
+ (list (nginx-server-configuration
+ (listen '("8080")))))
+
+(define %nginx-os
+ ;; Operating system under test.
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service nginx-service-type
+ (nginx-configuration
+ (log-directory "/var/log/nginx")
+ (server-blocks %nginx-servers)))
+ (simple-service 'make-http-root activation-service-type
+ %make-http-root)))
+
+(define %test-nginx
+ (system-test
+ (name "nginx")
+ (description "Connect to a running NGINX server.")
+ (value (run-webserver-test name %nginx-os
+ #:log-file "/var/log/nginx/access.log"))))
+
+\f
+;;;
+;;; 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))))
+
+\f
+;;;
+;;; PHP-FPM
+;;;
+
+(define %make-php-fpm-http-root
+ ;; Create our server root in /srv.
+ #~(begin
+ (mkdir "/srv")
+ (call-with-output-file "/srv/index.php"
+ (lambda (port)
+ (display "<?php
+phpinfo();
+echo(\"Computed by php:\".((string)(2+3)));
+?>\n" port)))))
+
+(define %php-fpm-nginx-server-blocks
+ (list (nginx-server-configuration
+ (root "/srv")
+ (locations
+ (list (nginx-php-location)))
+ (listen '("8042"))
+ (ssl-certificate #f)
+ (ssl-certificate-key #f))))
+
+(define %php-fpm-os
+ ;; Operating system under test.
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service php-fpm-service-type)
+ (service nginx-service-type
+ (nginx-configuration
+ (server-blocks %php-fpm-nginx-server-blocks)))
+ (simple-service 'make-http-root activation-service-type
+ %make-php-fpm-http-root)))
+
+(define* (run-php-fpm-test #:optional (http-port 8042))
+ "Run tests in %PHP-FPM-OS, which has nginx running and listening on
+HTTP-PORT, along with php-fpm."
+ (define os
+ (marionette-operating-system
+ %php-fpm-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-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 "php-fpm")
+
+ (test-assert "php-fpm running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (match (start-service 'php-fpm)
+ (#f #f)
+ (('service response-parts ...)
+ (match (assq-ref response-parts 'running)
+ ((pid) (number? pid))))))
+ marionette))
+
+ (test-assert "nginx running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (start-service 'nginx))
+ marionette))
+
+ (test-equal "http-get"
+ 200
+ (let-values (((response text)
+ (http-get "http://localhost:8080/index.php"
+ #:decode-body? #t)))
+ (response-code response)))
+
+ (test-equal "php computed result is sent"
+ "Computed by php:5"
+ (let-values (((response text)
+ (http-get "http://localhost:8080/index.php"
+ #:decode-body? #t)))
+ (begin
+ (use-modules (ice-9 regex))
+ (let ((matches (string-match "Computed by php:5" text)))
+ (and matches
+ (match:substring matches 0))))))
+
+ (test-end)
+
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation "php-fpm-test" test))
+
+(define %test-php-fpm
+ (system-test
+ (name "php-fpm")
+ (description "Test PHP-FPM through nginx.")
+ (value (run-php-fpm-test))))
+
+\f
+;;;
+;;; hpcguix-web
+;;;
+
+(define* (run-hpcguix-web-server-test name test-os)
+ "Run tests in %HPCGUIX-WEB-OS, which has hpcguix-web running."
+ (define os
+ (marionette-operating-system
+ test-os
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (port-forwardings '((8080 . 5000)))))
+
+ (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 #$name)
+
+ (test-assert "hpcguix-web running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (match (start-service 'hpcguix-web)
+ (#f #f)
+ (('service response-parts ...)
+ (match (assq-ref response-parts 'running)
+ ((pid) (number? pid))))))
+ marionette))
+
+ (test-equal "http-get"
+ 200
+ (begin
+ (wait-for-tcp-port 5000 marionette)
+ (let-values (((response text)
+ (http-get "http://localhost:8080")))
+ (response-code response))))
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation (string-append name "-test") test))
+
+(define %hpcguix-web-specs
+ ;; Server config gexp.
+ #~(define site-config
+ (hpcweb-configuration
+ (title-prefix "[TEST] HPCGUIX-WEB"))))
+
+(define %hpcguix-web-os
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service hpcguix-web-service-type
+ (hpcguix-web-configuration
+ (specs %hpcguix-web-specs)))))
+
+(define %test-hpcguix-web
+ (system-test
+ (name "hpcguix-web")
+ (description "Connect to a running hpcguix-web server.")
+ (value (run-hpcguix-web-server-test name %hpcguix-web-os))))
+
+\f
+(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))))
+
+\f
+;;;
+;;; Patchwork
+;;;
+
+(define (patchwork-initial-database-setup-service configuration)
+ (define start-gexp
+ #~(lambda ()
+ (let ((pid (primitive-fork))
+ (postgres (getpwnam "postgres")))
+ (if (eq? pid 0)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (setgid (passwd:gid postgres))
+ (setuid (passwd:uid postgres))
+ (primitive-exit
+ (if (and
+ (zero?
+ (system* #$(file-append postgresql "/bin/createuser")
+ #$(patchwork-database-configuration-user
+ configuration)))
+ (zero?
+ (system* #$(file-append postgresql "/bin/createdb")
+ "-O"
+ #$(patchwork-database-configuration-user
+ configuration)
+ #$(patchwork-database-configuration-name
+ configuration))))
+ 0
+ 1)))
+ (lambda ()
+ (primitive-exit 1)))
+ (zero? (cdr (waitpid pid)))))))
+
+ (shepherd-service
+ (requirement '(postgres))
+ (provision '(patchwork-postgresql-user-and-database))
+ (start start-gexp)
+ (stop #~(const #f))
+ (respawn? #f)
+ (documentation "Setup patchwork database.")))
+
+(define (patchwork-os patchwork)
+ (simple-operating-system
+ (service dhcp-client-service-type)
+ (service httpd-service-type
+ (httpd-configuration
+ (config
+ (httpd-config-file
+ (listen '("8080"))))))
+ (service postgresql-service-type
+ (postgresql-configuration
+ (postgresql postgresql-10)))
+ (service patchwork-service-type
+ (patchwork-configuration
+ (patchwork patchwork)
+ (domain "localhost")
+ (settings-module
+ (patchwork-settings-module
+ (allowed-hosts (list domain))
+ (default-from-email "")))
+ (getmail-retriever-config
+ (getmail-retriever-configuration
+ (type "SimpleIMAPSSLRetriever")
+ (server "imap.example.com")
+ (port 993)
+ (username "username")
+ (password "password")
+ (extra-parameters
+ '((mailboxes . ("INBOX"))))))))
+ (simple-service 'patchwork-database-setup
+ shepherd-root-service-type
+ (list
+ (patchwork-initial-database-setup-service
+ (patchwork-database-configuration))))))
+
+(define (run-patchwork-test patchwork)
+ "Run tests in %NGINX-OS, which has nginx running and listening on
+HTTP-PORT."
+ (define os
+ (marionette-operating-system
+ (patchwork-os patchwork)
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define forwarded-port 8080)
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (port-forwardings `((8080 . ,forwarded-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 "patchwork")
+
+ (test-assert "patchwork-postgresql-user-and-service started"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (match (start-service 'patchwork-postgresql-user-and-database)
+ (#f #f)
+ (('service response-parts ...)
+ (match (assq-ref response-parts 'running)
+ ((#t) #t)
+ ((pid) (number? pid))))))
+ marionette))
+
+ (test-assert "httpd running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (start-service 'httpd))
+ marionette))
+
+ (test-equal "http-get"
+ 200
+ (let-values
+ (((response text)
+ (http-get #$(simple-format
+ #f "http://localhost:~A/" forwarded-port)
+ #:decode-body? #t)))
+ (response-code response)))
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+ (gexp->derivation "patchwork-test" test))
+
+(define %test-patchwork
+ (system-test
+ (name "patchwork")
+ (description "Connect to a running Patchwork service.")
+ (value (run-patchwork-test patchwork))))
HCoop / jackhill / guix / guix.git / blobdiff