aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service')
-rw-r--r--guix-data-service/utils.scm182
1 files 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))