From 838ee6f1e368b28724c41f35d06ccf62a700c424 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 28 Apr 2025 09:20:33 +0100
Subject: [PATCH] Enable destroying individual resources in a resource pool

---
 knots/resource-pool.scm | 38 ++++++++++++++++++++++++++++++++++----
 1 file changed, 34 insertions(+), 4 deletions(-)

diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm
index ea87a79..bd69f95 100644
--- a/knots/resource-pool.scm
+++ b/knots/resource-pool.scm
@@ -53,6 +53,10 @@
             resource-pool-destroyed-error-pool
             resource-pool-destroyed-error?
 
+            &resource-pool-destroy-resource
+            make-resource-pool-destroy-resource-exception
+            resource-pool-destroy-resource-exception?
+
             resource-pool-default-timeout-handler
 
             call-with-resource-from-pool
@@ -555,6 +559,14 @@
                   resources-last-used
                   index))))
 
+        (('destroy resource)
+         (spawn-fiber-to-destroy-resource resource)
+
+         (loop resources
+               available
+               waiters
+               resources-last-used))
+
         (('stats reply)
          (let ((stats
                 `((resources              . ,(length resources))
@@ -780,6 +792,17 @@
 (define resource-pool-destroyed-error?
   (record-predicate &resource-pool-destroyed))
 
+(define &resource-pool-destroy-resource
+  (make-exception-type '&recource-pool-destroy-resource
+                       &exception
+                       '()))
+
+(define make-resource-pool-destroy-resource-exception
+  (record-constructor &resource-pool-destroy-resource))
+
+(define resource-pool-destroy-resource-exception?
+  (record-predicate &resource-pool-destroy-resource))
+
 (define resource-pool-default-timeout-handler
   (make-parameter #f))
 
@@ -787,7 +810,8 @@
           pool proc #:key (timeout 'default)
           (timeout-handler (resource-pool-default-timeout-handler))
           (max-waiters 'default)
-          (channel (resource-pool-channel pool)))
+          (channel (resource-pool-channel pool))
+          (destroy-resource-on-exception? #f))
   "Call PROC with a resource from POOL, blocking until a resource becomes
 available.  Return the resource once PROC has returned."
 
@@ -877,9 +901,15 @@ available.  Return the resource once PROC has returned."
                    ;; Unwind the stack before calling put-message, as
                    ;; this avoids inconsistent behaviour with
                    ;; continuation barriers
-                   (put-message (resource-pool-channel pool)
-                                `(return ,resource))
-                   (raise-exception exn))
+                   (put-message
+                    (resource-pool-channel pool)
+                    (list (if (or destroy-resource-on-exception?
+                                  (resource-pool-destroy-resource-exception? exn))
+                              'destroy
+                              'return)
+                          resource))
+                   (unless (resource-pool-destroy-resource-exception? exn)
+                     (raise-exception exn)))
                (lambda ()
                  (with-exception-handler
                      (lambda (exn)