From 68cfbe0380085735086b8952e7e700fda0028ad0 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 27 Apr 2025 10:03:06 +0100
Subject: [PATCH] Use a condition for destroying resource pools

This avoids the situation where the resource pool is destroyed, so
there's no fiber to listen to the destroy request.
---
 knots/resource-pool.scm | 70 +++++++++++++++++++----------------------
 1 file changed, 33 insertions(+), 37 deletions(-)

diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm
index c9aab02..5c96eef 100644
--- a/knots/resource-pool.scm
+++ b/knots/resource-pool.scm
@@ -29,6 +29,7 @@
   #:use-module (fibers channels)
   #:use-module (fibers scheduler)
   #:use-module (fibers operations)
+  #:use-module (fibers conditions)
   #:use-module (knots)
   #:use-module (knots parallelism)
   #:export (resource-pool?
@@ -71,11 +72,12 @@
   (record-predicate &resource-pool-abort-add-resource))
 
 (define-record-type <resource-pool>
-  (make-resource-pool-record name channel configuration)
+  (make-resource-pool-record name channel destroy-condition configuration)
   resource-pool?
-  (name          resource-pool-name)
-  (channel       resource-pool-channel)
-  (configuration resource-pool-configuration))
+  (name              resource-pool-name)
+  (channel           resource-pool-channel)
+  (destroy-condition resource-pool-destroy-condition)
+  (configuration     resource-pool-configuration))
 
 (set-record-type-printer!
  <resource-pool>
@@ -98,11 +100,14 @@
                              default-checkout-timeout
                              default-max-waiters)
   (define channel (make-channel))
+  (define destroy-condition
+    (make-condition))
 
   (define pool
     (make-resource-pool-record
      name
      channel
+     destroy-condition
      `((max-size . ,max-size)
        (min-size . ,min-size)
        (idle-seconds . ,idle-seconds)
@@ -208,16 +213,14 @@
             channel
             (list 'return-failed-checkout resource)))))))
 
-  (define (destroy-loop resources destroy-waiters)
-    (let loop ((resources resources)
-               (destroy-waiters destroy-waiters))
+  (define (destroy-loop resources)
+    (let loop ((resources resources))
       (match (get-message channel)
         (('add-resource resource)
          (when destructor
            (spawn-fiber-to-destroy-resource resource))
 
-         (loop resources
-               destroy-waiters))
+         (loop resources))
         (('checkout reply timeout-time max-waiters)
          (spawn-fiber
           (lambda ()
@@ -237,8 +240,7 @@
                          internal-time-units-per-second))
                      (const #f)))
                    op)))))
-         (loop resources
-               destroy-waiters))
+         (loop resources))
         (((and (or 'return
                    'return-failed-checkout
                    'remove)
@@ -270,17 +272,11 @@
                         resources))))
              (if (null? new-resources)
                  (begin
-                   (for-each
-                    (lambda (destroy-waiter)
-                      (spawn-fiber
-                       (lambda ()
-                         (put-message destroy-waiter 'destroy-success))))
-                    destroy-waiters)
+                   (signal-condition! destroy-condition)
 
                    ;; No loop
                    *unspecified*)
-                 (loop new-resources
-                       destroy-waiters)))))
+                 (loop new-resources)))))
 
         (('stats reply)
          (let ((stats
@@ -299,24 +295,20 @@
                 (wrap-operation (sleep-operation 5)
                                 (const #f)))))))
 
-         (loop resources
-               destroy-waiters))
+         (loop resources))
 
         (('check-for-idle-resources)
-         (loop resources
-               destroy-waiters))
+         (loop resources))
 
         (('destroy reply)
-         (loop resources
-               (cons reply destroy-waiters)))
+         (loop resources))
         (unknown
          (simple-format
           (current-error-port)
           "unrecognised message to ~A resource pool channel: ~A\n"
           name
           unknown)
-         (loop resources
-               destroy-waiters)))))
+         (loop resources)))))
 
   (define (main-loop)
     (let loop ((resources '())
@@ -625,10 +617,11 @@
                    waiters
                    resources-last-used))))
 
-        (('destroy reply)
+        (('destroy)
          (if (and (null? resources)
                   (null? waiters))
-             (put-message reply 'destroy-success)
+             (signal-condition!
+              destroy-condition)
 
              (begin
                (for-each
@@ -668,8 +661,7 @@
                                  op))))))))
                   waiters))
 
-               (destroy-loop resources
-                             (list reply)))))
+               (destroy-loop resources))))
 
         (unknown
          (simple-format
@@ -724,12 +716,16 @@
   pool)
 
 (define (destroy-resource-pool pool)
-  (let ((reply (make-channel)))
-    (put-message (resource-pool-channel pool)
-                 (list 'destroy reply))
-    (let ((msg (get-message reply)))
-      (unless (eq? msg 'destroy-success)
-        (error msg)))))
+  (perform-operation
+   (choice-operation
+    (wrap-operation
+     (put-operation (resource-pool-channel pool)
+                    (list 'destroy))
+     (lambda _
+       (wait (resource-pool-destroy-condition pool))))
+    (wait-operation
+     (resource-pool-destroy-condition pool))))
+  #t)
 
 (define &resource-pool-timeout
   (make-exception-type '&recource-pool-timeout