branch: main
commit d7e546f0340f14cc92b987f2ca622ff195f1c0f4
Author: Ludovic Courtès <l...@gnu.org>
AuthorDate: Fri Jul 12 18:35:59 2024 +0200
tests: Add basic tests for ‘cuirass register’.
* tests/common.scm (%daemon-socket): New variable.
(start-guix-daemon, wait-for-bridge): New procedures.
(with-guix-daemon): New macro.
* tests/register.scm: New file.
* Makefile.am (TESTS): Add it.
---
Makefile.am | 3 +-
tests/common.scm | 61 ++++++++++++++++++++++++++++++++++-
tests/register.scm | 93 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 155 insertions(+), 2 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index cd8668f..1123eb1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -2,7 +2,7 @@
# Copyright © 1995-2016, 2023 Free Software Foundation, Inc.
# Copyright © 2016, 2017 Mathieu Lirzin <m...@gnu.org>
-# Copyright © 2018, 2023 Ludovic Courtès <l...@gnu.org>
+# Copyright © 2018, 2023-2024 Ludovic Courtès <l...@gnu.org>
# Copyright © 2018 Clément Lassieur <clem...@lassieur.org>
# Copyright © 2018 Tatiana Sholokhova <tanja201...@gmail.com>
# Copyright © 2020 Mathieu Othacehe <othac...@gnu.org>
@@ -170,6 +170,7 @@ TESTS = \
tests/gitlab.scm \
tests/http.scm \
tests/metrics.scm \
+ tests/register.scm \
tests/remote.scm \
tests/utils.scm
diff --git a/tests/common.scm b/tests/common.scm
index 0599320..4b6c549 100644
--- a/tests/common.scm
+++ b/tests/common.scm
@@ -17,6 +17,7 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests common)
+ #:use-module ((cuirass base) #:select (%bridge-socket-file-name))
#:use-module (cuirass database)
#:use-module (cuirass parameters)
#:use-module (cuirass utils)
@@ -25,7 +26,9 @@
#:use-module (ice-9 rdelim)
#:export (%db
retry
- test-init-db!))
+ test-init-db!
+ with-guix-daemon
+ wait-for-bridge))
(define %db
(make-parameter #f))
@@ -57,3 +60,59 @@
(%create-database? #t)
(%package-database (pg-tmp))
(%db (db-open)))
+
+(define %daemon-socket
+ (in-vicinity (or (getenv "TMPDIR") "/tmp")
+ "cuirass-test-daemon-socket"))
+
+(define (start-guix-daemon)
+ "Start a custom @command{guix-daemon} and define all the relevant
+environment variables so that Guix clients will take to it."
+ (setenv "GUIX_DAEMON_SOCKET" %daemon-socket)
+ (setenv "GUIX_STATE_DIRECTORY"
+ (in-vicinity (or (getenv "TMPDIR") "/tmp")
+ "cuirass-test-var"))
+ (setenv "NIX_STORE"
+ (in-vicinity (or (getenv "TMPDIR") "/tmp")
+ "cuirass-test-store"))
+ (spawn "guix-daemon"
+ (list "guix-daemon" "--disable-chroot"
+ (string-append "--listen=" %daemon-socket))))
+
+(define-syntax-rule (with-guix-daemon exp ...)
+ "Evaluate @var{exp}... in a context where a test instance of
+@command{guix-daemon} is running and @env{GUIX_DAEMON_SOCKET}, etc. are set
+appropriately."
+ (let ((pid #f))
+ (dynamic-wind
+ (lambda ()
+ (set! pid (start-guix-daemon)))
+ (lambda ()
+ exp ...)
+ (lambda ()
+ (format (current-error-port)
+ "terminating guix-daemon (PID ~a)" pid)
+ (false-if-exception (kill (- pid) SIGTERM))))))
+
+(define (wait-for-bridge)
+ "Wait for the \"bridge\" socket of @command{cuirass register} to be ready.
+Return the socket on success and #f on failure."
+ (let ((address (make-socket-address AF_UNIX
+ (%bridge-socket-file-name)))
+ (socket (socket AF_UNIX SOCK_STREAM 0)))
+ (let loop ((i 0))
+ (catch 'system-error
+ (lambda ()
+ (connect socket address)
+ socket)
+ (lambda args
+ (if (< i 50)
+ (begin
+ (usleep 200000)
+ (loop (+ i 1)))
+ (begin
+ (format (current-error-port)
+ "failed to connect to '~a': ~a~%"
+ (sockaddr:path address)
+ (strerror (system-error-errno args)))
+ #f)))))))
diff --git a/tests/register.scm b/tests/register.scm
new file mode 100644
index 0000000..7e97ee9
--- /dev/null
+++ b/tests/register.scm
@@ -0,0 +1,93 @@
+;;; register.scm -- test the 'cuirass register' process
+;;; Copyright © 2024 Ludovic Courtès <l...@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass. If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass base)
+ (cuirass database)
+ (cuirass specification)
+ (guix channels)
+ (tests common)
+ (ice-9 match)
+ (srfi srfi-64))
+
+(define (start-process)
+ (setenv "CUIRASS_LOGGING_LEVEL" "debug")
+ (spawn "cuirass"
+ (list "cuirass" "register"
+ "-S" (string-append (getenv "testsrcdir")
+ "/../examples/random.scm")
+ (string-append "--database=" (%package-database)))))
+
+(define (specification-sans-location spec)
+ "Reset the location of SPEC's channel to ease comparison."
+ (specification
+ (inherit spec)
+ (channels (map (lambda (ch)
+ (channel (inherit ch)))
+ (specification-channels spec)))))
+
+(define %pid #f)
+(define %client-socket #f)
+
+(test-assert "initialize database"
+ (begin
+ (test-init-db!)
+ (%package-database)))
+
+;; The 'restart-builds' fiber attempts to connect to 'guix-daemon' early on so
+;; it needs to be up and running upfront.
+(with-guix-daemon
+
+ (test-assert "started"
+ (begin
+ (set! %pid (start-process))
+ %pid))
+
+ (test-equal "jobset is in database"
+ (map specification-sans-location
+ (read-specifications (string-append (getenv "testsrcdir")
+ "/../examples/random.scm")))
+ (retry (lambda ()
+ (match (db-get-specifications)
+ (() #f)
+ (lst (map specification-sans-location lst))))
+ #:times 5
+ #:delay 1))
+
+ (test-assert "bridge ready"
+ (begin
+ (set! %client-socket (wait-for-bridge))
+ %client-socket))
+
+ (unless (file-port? %client-socket)
+ (test-skip 1))
+
+ (test-assert "active-jobset?"
+ (retry
+ (lambda ()
+ (write '(active-jobset? random) %client-socket)
+ (match (read %client-socket)
+ (('reply #t) #t)
+ (_ #f)))
+ #:times 5
+ #:delay 1))
+
+ (test-equal "process terminated"
+ (cons %pid SIGKILL)
+ (begin
+ (kill %pid SIGKILL)
+ (waitpid %pid))))
