summaryrefslogtreecommitdiff
path: root/gnu/tests
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/tests')
-rw-r--r--gnu/tests/cuirass.scm276
-rw-r--r--gnu/tests/databases.scm72
-rw-r--r--gnu/tests/guix.scm5
-rw-r--r--gnu/tests/install.scm74
-rw-r--r--gnu/tests/monitoring.scm7
-rw-r--r--gnu/tests/web.scm7
6 files changed, 435 insertions, 6 deletions
diff --git a/gnu/tests/cuirass.scm b/gnu/tests/cuirass.scm
new file mode 100644
index 0000000000..86a06d3069
--- /dev/null
+++ b/gnu/tests/cuirass.scm
@@ -0,0 +1,276 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@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 cuirass)
+ #:use-module (gnu tests)
+ #:use-module (gnu system)
+ #:use-module (gnu system vm)
+ #:use-module (gnu system install)
+ #:use-module (gnu packages databases)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages version-control)
+ #:use-module (gnu services)
+ #:use-module (gnu services avahi)
+ #:use-module (gnu services base)
+ #:use-module (gnu services cuirass)
+ #:use-module (gnu services databases)
+ #:use-module (gnu services networking)
+ #:use-module (gnu system nss)
+ #:use-module (guix gexp)
+ #:use-module (guix store)
+ #:export (%cuirass-test
+ %cuirass-remote-test))
+
+(define* (run-cuirass-test name #:key remote-build?)
+ (define %cuirass-specs
+ #~(list
+ '((#:name . "test")
+ (#:load-path-inputs . ())
+ (#:package-path-inputs . ())
+ (#:proc-input . "main")
+ (#:proc-file . "derivation.scm")
+ (#:proc . main)
+ (#:proc-args . ())
+ (#:inputs . (((#:name . "main")
+ (#:url . "file:///tmp/cuirass-main/")
+ (#:load-path . ".")
+ (#:branch . "master")
+ (#:no-compile? . #t))))
+ (#:build-outputs . ())
+ (#:priority . 1))))
+
+ (define %derivation-file
+ (scheme-file
+ "derivation.scm"
+ '(begin
+ (use-modules (guix)
+ (srfi srfi-1)
+ (ice-9 match))
+
+ (define (derivation->alist store drv)
+ `((#:derivation . ,(derivation-file-name drv))
+ (#:log . ,(log-file store (derivation-file-name drv)))
+ (#:outputs . ,(filter-map (lambda (res)
+ (match res
+ ((name . path)
+ `(,name . ,path))))
+ (derivation->output-paths drv)))
+ (#:nix-name . ,(derivation-name drv))
+ (#:system . ,(derivation-system drv))
+ (#:max-silent-time . 3600)
+ (#:timeout . 3600)))
+
+ (define (main store arguments)
+ (let* ((file (plain-file "test" "this is a test derivation"))
+ (job-name "test-job")
+ (drv (run-with-store store
+ (gexp->derivation
+ job-name
+ #~(begin
+ (mkdir #$output)
+ (symlink #$file
+ (string-append #$output "/file")))))))
+ (list (lambda ()
+ `((#:job-name . ,job-name)
+ ,@(derivation->alist store drv)))))))))
+
+ (define os
+ (marionette-operating-system
+ (simple-operating-system
+ (service cuirass-service-type
+ (cuirass-configuration
+ (specifications %cuirass-specs)
+ (remote-server (and remote-build?
+ (cuirass-remote-server-configuration)))
+ (host "0.0.0.0")
+ (use-substitutes? #t)))
+ (service dhcp-client-service-type)
+ ;; Create a Git repository to host Cuirass' specification.
+ (simple-service
+ 'create-git-directory activation-service-type
+ #~(begin
+ (let* ((git (string-append #$git "/bin/git"))
+ (main "/tmp/cuirass-main")
+ (file (string-append main "/derivation.scm")))
+ (mkdir-p main)
+ (with-directory-excursion main
+ (copy-file #$%derivation-file file)
+ (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.")))))
+ ;; The Guix-daemon & Cuirass will complain if the store is
+ ;; read-only. Create a store overlay to solve this issue.
+ (simple-service
+ 'mount-cow-store activation-service-type
+ #~(begin
+ (use-modules (guix build syscalls)
+ (guix build utils))
+ (mkdir-p "/rw-store")
+ (mount "none" "/rw-store" "tmpfs")
+
+ (mkdir-p "/rw-store/upper")
+ (mkdir-p "/rw-store/work")
+ (mount "none" "/gnu/store" "overlay" 0
+ "lowerdir=/gnu/store,upperdir=/rw-store/upper,workdir=/rw-store/work")))
+ (service postgresql-service-type
+ (postgresql-configuration
+ (postgresql postgresql-10)))
+ (service postgresql-role-service-type))
+ #:imported-modules '((gnu services herd)
+ (guix combinators)
+ (guix build syscalls)
+ (guix build utils))))
+
+ (define os*
+ (operating-system
+ (inherit os)
+ (name-service-switch %mdns-host-lookup-nss)
+ (services
+ (append (if remote-build?
+ (list
+ (service avahi-service-type)
+ (service cuirass-remote-worker-service-type
+ (cuirass-remote-worker-configuration)))
+ '())
+ (operating-system-user-services os)))))
+
+ (define cuirass-web-port 8081)
+ (define forward-port 5000)
+
+ (define vm
+ (virtual-machine
+ (operating-system os*)
+ (memory-size 1024)
+ (port-forwardings `((,forward-port . ,cuirass-web-port)))))
+
+ (define test
+ (with-extensions (list guile-json-4)
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (srfi srfi-11) (srfi srfi-64)
+ (gnu build marionette)
+ (ice-9 match)
+ (ice-9 rdelim)
+ (json)
+ (rnrs bytevectors)
+ (web client) (web response))
+
+ (define marionette
+ (make-marionette (list #$vm)))
+
+ (define (query path)
+ (http-get
+ (format #f "http://localhost:~a~a"
+ #$(number->string forward-port)
+ path)))
+
+ (define* (retry f #:key times delay)
+ (let loop ((attempt 1))
+ (let ((result (f)))
+ (cond
+ (result result)
+ (else
+ (if (>= attempt times)
+ #f
+ (begin
+ (sleep delay)
+ (loop (+ 1 attempt)))))))))
+
+ (mkdir #$output)
+ (chdir #$output)
+
+ (test-begin "cuirass")
+
+ ;; Wait for cuirass to be up and running.
+ (test-assert "cuirass running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (start-service 'cuirass)
+ #t)
+ marionette))
+
+ (test-assert "cuirass-web running"
+ (begin
+ (wait-for-tcp-port #$cuirass-web-port marionette)
+ (retry
+ (lambda ()
+ (let-values (((response text)
+ (query "/")))
+ (eq? (response-code response) 200)))
+ #:times 5
+ #:delay 5)))
+
+ (test-equal "cuirass-web evaluation"
+ "test"
+ (begin
+ (retry
+ (lambda ()
+ (let-values (((response text)
+ (query "/api/evaluation?id=1")))
+ (let ((result
+ (false-if-exception
+ (json-string->scm
+ (utf8->string text)))))
+ (and result
+ (assoc-ref result "specification")))))
+ #:times 5
+ #:delay 5)))
+
+ ;; Even though there's a store overlay, the Guix database is not
+ ;; initialized, meaning that we won't be able to perform the
+ ;; build. Check at least that it is queued.
+ (test-assert "cuirass-web build queued"
+ (begin
+ (retry
+ (lambda ()
+ (let-values (((response text)
+ (query "/api/queue?nr=1")))
+ (let ((result
+ (json-string->scm
+ (utf8->string text))))
+ (match (vector->list result)
+ ((build)
+ (and (string=? (assoc-ref build "job")
+ "test-job")
+ (or (not #$remote-build?)
+ ;; Check if the build is started.
+ (= (assoc-ref build "buildstatus") -1))))
+ (else #f)))))
+ #:times 5
+ #:delay 10)))
+
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
+
+ (gexp->derivation name test))
+
+(define %cuirass-test
+ (system-test
+ (name "cuirass")
+ (description "Connect to a Cuirass server.")
+ (value (run-cuirass-test name))))
+
+(define %cuirass-remote-test
+ (system-test
+ (name "cuirass-remote")
+ (description "Connect to a Cuirass server with remote build.")
+ (value (run-cuirass-test name #:remote-build? #t))))
diff --git a/gnu/tests/databases.scm b/gnu/tests/databases.scm
index 31d5ae4c6a..e831d69f5a 100644
--- a/gnu/tests/databases.scm
+++ b/gnu/tests/databases.scm
@@ -214,11 +214,31 @@
;;; The PostgreSQL service.
;;;
+(define %postgresql-log-directory
+ "/var/log/postgresql")
+
+(define %role-log-file
+ "/var/log/postgresql_roles.log")
+
(define %postgresql-os
(simple-operating-system
(service postgresql-service-type
(postgresql-configuration
- (postgresql postgresql-10)))))
+ (postgresql postgresql-10)
+ (config-file
+ (postgresql-config-file
+ (extra-config
+ '(("session_preload_libraries" "auto_explain")
+ ("random_page_cost" 2)
+ ("auto_explain.log_min_duration" "100 ms")
+ ("work_mem" "500 MB")
+ ("debug_print_plan" #t)))))))
+ (service postgresql-role-service-type
+ (postgresql-role-configuration
+ (roles
+ (list (postgresql-role
+ (name "root")
+ (create-database? #t))))))))
(define (run-postgresql-test)
"Run tests in %POSTGRESQL-OS."
@@ -254,6 +274,56 @@
(start-service 'postgres))
marionette))
+ (test-assert "log-file"
+ (marionette-eval
+ '(begin
+ (use-modules (ice-9 ftw)
+ (ice-9 match))
+ (current-output-port
+ (open-file "/dev/console" "w0"))
+ (let ((server-log-file
+ (string-append #$%postgresql-log-directory
+ "/pg_ctl.log")))
+ (and (file-exists? server-log-file)
+ (display
+ (call-with-input-file server-log-file
+ get-string-all)))
+ #t))
+ marionette))
+
+ (test-assert "database ready"
+ (begin
+ (marionette-eval
+ '(begin
+ (let loop ((i 10))
+ (unless (or (zero? i)
+ (and (file-exists? #$%role-log-file)
+ (string-contains
+ (call-with-input-file #$%role-log-file
+ get-string-all)
+ ";\nCREATE DATABASE")))
+ (sleep 1)
+ (loop (- i 1)))))
+ marionette)))
+
+ (test-assert "database creation"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd)
+ (ice-9 popen))
+ (current-output-port
+ (open-file "/dev/console" "w0"))
+ (let* ((port (open-pipe*
+ OPEN_READ
+ #$(file-append postgresql "/bin/psql")
+ "-tAh" "/var/run/postgresql"
+ "-c" "SELECT 1 FROM pg_database WHERE
+ datname='root'"))
+ (output (get-string-all port)))
+ (close-pipe port)
+ (string-contains output "1")))
+ marionette))
+
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
diff --git a/gnu/tests/guix.scm b/gnu/tests/guix.scm
index af7d8f0b21..219b8b482f 100644
--- a/gnu/tests/guix.scm
+++ b/gnu/tests/guix.scm
@@ -164,7 +164,10 @@
"
local all all trust
host all all 127.0.0.1/32 trust
-host all all ::1/128 trust"))))))
+host all all ::1/128 trust"))
+ ;; XXX: Remove when postgresql default socket directory is
+ ;; changed to /var/run/postgresql.
+ (socket-directory #f)))))
(service guix-data-service-type
(guix-data-service-configuration
(host "0.0.0.0")))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index bf94e97c2a..4b8963eadd 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -66,6 +67,7 @@
%test-encrypted-root-not-boot-os
%test-btrfs-root-os
%test-btrfs-root-on-subvolume-os
+ %test-btrfs-raid-root-os
%test-jfs-root-os
%test-f2fs-root-os
%test-lvm-separate-home-os
@@ -222,7 +224,7 @@ reboot\n")
#:imported-modules '((gnu services herd)
(gnu installer tests)
(guix combinators))))
- (installation-image-type 'raw)
+ (installation-image-type 'efi-raw)
(install-size 'guess)
(target-size (* 2200 MiB)))
"Run SCRIPT (a shell script following the system installation procedure) in
@@ -272,7 +274,7 @@ packages defined in installation-os."
"-no-reboot"
"-m" "1200"
#$@(cond
- ((eq? 'raw installation-image-type)
+ ((eq? 'efi-raw installation-image-type)
#~("-drive"
,(string-append "file=" #$image
",if=virtio,readonly")))
@@ -1059,6 +1061,74 @@ build (current-guix) and then store a couple of full system images.")
(command (qemu-command/writable-image image)))
(run-basic-test %btrfs-root-os command "btrfs-root-os")))))
+
+
+;;;
+;;; Btrfs RAID-0 root file system.
+;;;
+(define-os-with-source (%btrfs-raid-root-os %btrfs-raid-root-os-source)
+ ;; An OS whose root partition is a RAID partition.
+ (use-modules (gnu) (gnu tests))
+
+ (operating-system
+ (host-name "liberigilo")
+ (timezone "Europe/Paris")
+ (locale "en_US.utf8")
+
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vdb")))
+ (kernel-arguments '("console=ttyS0"))
+
+ (file-systems (cons (file-system
+ (device (file-system-label "root-fs"))
+ (mount-point "/")
+ (type "btrfs"))
+ %base-file-systems))
+ (users %base-user-accounts)
+ (services (cons (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix combinators)))))
+ %base-services))))
+
+(define %btrfs-raid-root-installation-script
+ "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+parted --script /dev/vdb mklabel gpt \\
+ mkpart primary ext2 1M 3M \\
+ mkpart primary ext2 3M 1.4G \\
+ mkpart primary ext2 1.4G 2.8G \\
+ set 1 boot on \\
+ set 1 bios_grub on
+mkfs.btrfs -L root-fs -d raid0 -m raid0 /dev/vdb2 /dev/vdb3
+mount /dev/vdb2 /mnt
+df -h /mnt
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-btrfs-raid-root-os
+ (system-test
+ (name "btrfs-raid-root-os")
+ (description "Test functionality of an OS installed with a Btrfs
+RAID-0 (stripe) root partition.")
+ (value
+ (mlet* %store-monad
+ ((image (run-install %btrfs-raid-root-os
+ %btrfs-raid-root-os-source
+ #:script %btrfs-raid-root-installation-script
+ #:target-size (* 2800 MiB)))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test %btrfs-raid-root-os `(,@command) "btrfs-raid-root-os")))))
+
;;;
;;; Btrfs root file system on a subvolume.
diff --git a/gnu/tests/monitoring.scm b/gnu/tests/monitoring.scm
index 8630f5818c..be69e1c259 100644
--- a/gnu/tests/monitoring.scm
+++ b/gnu/tests/monitoring.scm
@@ -309,7 +309,12 @@ zabbix||{}
(service dhcp-client-service-type)
(service postgresql-service-type
(postgresql-configuration
- (postgresql postgresql)))
+ (postgresql postgresql)
+ ;; XXX: Remove when postgresql default socket directory is
+ ;; changed to /var/run/postgresql.
+ (config-file
+ (postgresql-config-file
+ (socket-directory #f)))))
(service zabbix-front-end-service-type
(zabbix-front-end-configuration
(db-password "zabbix")))
diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index 7f4518acd2..cc0e79c8b2 100644
--- a/gnu/tests/web.scm
+++ b/gnu/tests/web.scm
@@ -569,7 +569,12 @@ HTTP-PORT."
(listen '("8080"))))))
(service postgresql-service-type
(postgresql-configuration
- (postgresql postgresql-10)))
+ (postgresql postgresql-10)
+ ;; XXX: Remove when postgresql default socket directory is
+ ;; changed to /var/run/postgresql.
+ (config-file
+ (postgresql-config-file
+ (socket-directory #f)))))
(service patchwork-service-type
(patchwork-configuration
(patchwork patchwork)
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-11 16:27:23 +0000