cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Enable destroying individual resources in a resource pool

Browse source
This commit is contained in:
Christopher Baines 2025-04-28 09:20:33 +01:00
parent 1dca6d755e
commit 838ee6f1e3
1 changed files with 34 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

38
knots/resource-pool.scm
View file

@ -53,6 +53,10 @@
resource-pool-destroyed-error-pool resource-pool-destroyed-error-pool
resource-pool-destroyed-error? resource-pool-destroyed-error?
&resource-pool-destroy-resource
make-resource-pool-destroy-resource-exception
resource-pool-destroy-resource-exception?
resource-pool-default-timeout-handler resource-pool-default-timeout-handler
call-with-resource-from-pool call-with-resource-from-pool
@ -555,6 +559,14 @@
resources-last-used resources-last-used
index)))) index))))
(('destroy resource)
(spawn-fiber-to-destroy-resource resource)
(loop resources
available
waiters
resources-last-used))
(('stats reply) (('stats reply)
(let ((stats (let ((stats
`((resources . ,(length resources)) `((resources . ,(length resources))
@ -780,6 +792,17 @@
(define resource-pool-destroyed-error? (define resource-pool-destroyed-error?
(record-predicate &resource-pool-destroyed)) (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 (define resource-pool-default-timeout-handler
(make-parameter #f)) (make-parameter #f))
@ -787,7 +810,8 @@
pool proc #:key (timeout 'default) pool proc #:key (timeout 'default)
(timeout-handler (resource-pool-default-timeout-handler)) (timeout-handler (resource-pool-default-timeout-handler))
(max-waiters 'default) (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 "Call PROC with a resource from POOL, blocking until a resource becomes
available. Return the resource once PROC has returned." 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 ;; Unwind the stack before calling put-message, as
;; this avoids inconsistent behaviour with ;; this avoids inconsistent behaviour with
;; continuation barriers ;; continuation barriers
(put-message (resource-pool-channel pool) (put-message
`(return ,resource)) (resource-pool-channel pool)
(raise-exception exn)) (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 () (lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)