[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
branch master updated: Add more exception handling to make-resource-pool
From: |
Christopher Baines |
Subject: |
branch master updated: Add more exception handling to make-resource-pool |
Date: |
Fri, 17 Nov 2023 07:32:50 -0500 |
This is an automated email from the git hooks/post-receive script.
cbaines pushed a commit to branch master
in repository data-service.
The following commit(s) were added to refs/heads/master by this push:
new b2bf948 Add more exception handling to make-resource-pool
b2bf948 is described below
commit b2bf948a00b582573fa5a3819fa04fac6977a608
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Fri Nov 17 12:32:14 2023 +0000
Add more exception handling to make-resource-pool
As I'm not sure it's working reliably.
---
guix-data-service/utils.scm | 182 +++++++++++++++++++++++---------------------
1 file changed, 96 insertions(+), 86 deletions(-)
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index 9dd94df..7357a40 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -99,94 +99,104 @@
(let ((channel (make-channel)))
(spawn-fiber
(lambda ()
- (let loop ((resources '())
- (available '())
- (waiters '()))
-
- (match (get-message channel)
- (('checkout reply)
- (if (null? available)
- (if (= (length resources) max-size)
- (loop resources
- available
- (cons reply waiters))
- (let ((new-resource (initializer/safe)))
- (if new-resource
- (let ((checkout-success?
- (perform-operation
- (choice-operation
- (wrap-operation
- (put-operation reply new-resource)
- (const #t))
- (wrap-operation (sleep-operation 0.2)
- (const #f))))))
- (loop (cons new-resource resources)
- (if checkout-success?
- available
- (cons new-resource available))
- waiters))
+ (while #t
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format
+ (current-error-port)
+ "exception in the ~A pool fiber: ~A\n"
+ name
+ exn))
+ (lambda ()
+ (let loop ((resources '())
+ (available '())
+ (waiters '()))
+
+ (match (get-message channel)
+ (('checkout reply)
+ (if (null? available)
+ (if (= (length resources) max-size)
(loop resources
available
- (cons reply waiters)))))
- (let ((checkout-success?
- (perform-operation
- (choice-operation
- (wrap-operation
- (put-operation reply (car available))
- (const #t))
- (wrap-operation (sleep-operation 0.2)
- (const #f))))))
- (if checkout-success?
- (loop resources
- (cdr available)
- waiters)
- (loop resources
- available
- waiters)))))
- (('return resource)
- ;; When a resource is returned, prompt all the waiters to request
- ;; again. This is to avoid the pool waiting on channels that may
- ;; be dead.
- (for-each
- (lambda (waiter)
- (spawn-fiber
- (lambda ()
- (perform-operation
- (choice-operation
- (put-operation waiter 'resource-pool-retry-checkout)
- (sleep-operation 0.2))))))
- waiters)
-
- (loop resources
- (cons resource available)
- ;; clear waiters, as they've been notified
- '()))
- (('stats reply)
- (let ((stats
- `((resources . ,(length resources))
- (available . ,(length available))
- (waiters . ,(length waiters)))))
-
- (perform-operation
- (choice-operation
- (wrap-operation
- (put-operation reply stats)
- (const #t))
- (wrap-operation (sleep-operation 0.2)
- (const #f)))))
-
- (loop resources
- available
- waiters))
- (unknown
- (simple-format
- (current-error-port)
- "unrecognised message to ~A resource pool channel: ~A\n"
- name
- unknown)
- (loop resources
- available
- waiters))))))
+ (cons reply waiters))
+ (let ((new-resource (initializer/safe)))
+ (if new-resource
+ (let ((checkout-success?
+ (perform-operation
+ (choice-operation
+ (wrap-operation
+ (put-operation reply new-resource)
+ (const #t))
+ (wrap-operation (sleep-operation 0.2)
+ (const #f))))))
+ (loop (cons new-resource resources)
+ (if checkout-success?
+ available
+ (cons new-resource available))
+ waiters))
+ (loop resources
+ available
+ (cons reply waiters)))))
+ (let ((checkout-success?
+ (perform-operation
+ (choice-operation
+ (wrap-operation
+ (put-operation reply (car available))
+ (const #t))
+ (wrap-operation (sleep-operation 0.2)
+ (const #f))))))
+ (if checkout-success?
+ (loop resources
+ (cdr available)
+ waiters)
+ (loop resources
+ available
+ waiters)))))
+ (('return resource)
+ ;; When a resource is returned, prompt all the waiters to
request
+ ;; again. This is to avoid the pool waiting on channels
that may
+ ;; be dead.
+ (for-each
+ (lambda (waiter)
+ (spawn-fiber
+ (lambda ()
+ (perform-operation
+ (choice-operation
+ (put-operation waiter 'resource-pool-retry-checkout)
+ (sleep-operation 0.2))))))
+ waiters)
+
+ (loop resources
+ (cons resource available)
+ ;; clear waiters, as they've been notified
+ '()))
+ (('stats reply)
+ (let ((stats
+ `((resources . ,(length resources))
+ (available . ,(length available))
+ (waiters . ,(length waiters)))))
+
+ (perform-operation
+ (choice-operation
+ (wrap-operation
+ (put-operation reply stats)
+ (const #t))
+ (wrap-operation (sleep-operation 0.2)
+ (const #f)))))
+
+ (loop resources
+ available
+ waiters))
+ (unknown
+ (simple-format
+ (current-error-port)
+ "unrecognised message to ~A resource pool channel: ~A\n"
+ name
+ unknown)
+ (loop resources
+ available
+ waiters)))))
+ #:unwind? #t))))
channel))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- branch master updated: Add more exception handling to make-resource-pool,
Christopher Baines <=