From bdcbf01fa5031e8ab212b51e59bd300a188bc2e9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 16 Nov 2023 17:40:40 +0100
Subject: [PATCH] utils: Add tests for the resource pool.

* tests/utils.scm: New file.
* Makefile.am (TESTS): Add it.
---
 Makefile.am     |  3 ++-
 tests/utils.scm | 65 +++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 67 insertions(+), 1 deletion(-)
 create mode 100644 tests/utils.scm

diff --git a/Makefile.am b/Makefile.am
index b2ab2d2..671808d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -161,7 +161,8 @@ TESTS = \
   tests/database.scm \
   tests/http.scm \
   tests/metrics.scm \
-  tests/remote.scm
+  tests/remote.scm \
+  tests/utils.scm
 
 # Compiler warning flags.
 GUILE_WARNINGS =					\
diff --git a/tests/utils.scm b/tests/utils.scm
new file mode 100644
index 0000000..e4384f4
--- /dev/null
+++ b/tests/utils.scm
@@ -0,0 +1,65 @@
+;;; utils.scm -- tests for (cuirass utils) module
+;;; Copyright © 2023 Ludovic Courtès <ludo@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 utils)
+             (cuirass logging)
+             (fibers)
+             (fibers channels)
+             (srfi srfi-1)
+             (srfi srfi-64))
+
+;; Enable debugging output.
+(current-logging-level 'debug)
+
+(test-begin "utils")
+
+(define (resource-pool-test resources consumers)
+  (lambda ()
+    (define channel
+      (make-channel))
+
+    (spawn-fiber
+     (lambda ()
+       (define pool (make-resource-pool (iota resources)))
+       (for-each (lambda (rank)
+                   (spawn-fiber
+                    (lambda ()
+                      (with-resource-from-pool pool resource
+                        (put-message channel rank)
+                        #t)))
+                   #t)
+                 (iota consumers))))
+
+    (sort (map (lambda _
+                 (get-message channel))
+               (iota consumers))
+          <)))
+
+(test-equal "resource pool, no contention"
+  (iota 10)
+  (run-fibers (resource-pool-test 10 10)
+              ;; XXX: Disable preemption.  With Fibers 1.3.1, we get random
+              ;; deadlocks on completion (when the 'sort' call above has
+              ;; completed) with the default #:hz value.
+              #:hz 0))
+
+(test-equal "resource pool, contention"
+  (iota 100)
+  (run-fibers (resource-pool-test 10 100)))
+
+(test-end)