diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/cuirass.scm | 276 | ||||
| -rw-r--r-- | gnu/tests/databases.scm | 72 | ||||
| -rw-r--r-- | gnu/tests/guix.scm | 5 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 70 | ||||
| -rw-r--r-- | gnu/tests/monitoring.scm | 7 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 7 |
6 files changed, 433 insertions, 4 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 9dbe63f1e4..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 @@ -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) |