cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add more exception handling to make-resource-pool

Browse source 
As I'm not sure it's working reliably.
This commit is contained in:
Christopher Baines 2023-11-17 12:32:14 +00:00
parent da2a405e8b
commit b2bf948a00
1 changed files with 92 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

174
guix-data-service/utils.scm
View file

@ -99,94 +99,104 @@
(let ((channel (make-channel))) (let ((channel (make-channel)))
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(let loop ((resources '()) (while #t
(available '()) (with-exception-handler
(waiters '())) (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) (match (get-message channel)
(('checkout reply) (('checkout reply)
(if (null? available) (if (null? available)
(if (= (length resources) max-size) (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))
(loop resources (loop resources
available available
(cons reply waiters))))) (cons reply waiters))
(let ((checkout-success? (let ((new-resource (initializer/safe)))
(perform-operation (if new-resource
(choice-operation (let ((checkout-success?
(wrap-operation (perform-operation
(put-operation reply (car available)) (choice-operation
(const #t)) (wrap-operation
(wrap-operation (sleep-operation 0.2) (put-operation reply new-resource)
(const #f)))))) (const #t))
(if checkout-success? (wrap-operation (sleep-operation 0.2)
(loop resources (const #f))))))
(cdr available) (loop (cons new-resource resources)
waiters) (if checkout-success?
(loop resources available
available (cons new-resource available))
waiters))))) waiters))
(('return resource) (loop resources
;; When a resource is returned, prompt all the waiters to request available
;; again. This is to avoid the pool waiting on channels that may (cons reply waiters)))))
;; be dead. (let ((checkout-success?
(for-each (perform-operation
(lambda (waiter) (choice-operation
(spawn-fiber (wrap-operation
(lambda () (put-operation reply (car available))
(perform-operation (const #t))
(choice-operation (wrap-operation (sleep-operation 0.2)
(put-operation waiter 'resource-pool-retry-checkout) (const #f))))))
(sleep-operation 0.2)))))) (if checkout-success?
waiters) (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 (loop resources
(cons resource available) (cons resource available)
;; clear waiters, as they've been notified ;; clear waiters, as they've been notified
'())) '()))
(('stats reply) (('stats reply)
(let ((stats (let ((stats
`((resources . ,(length resources)) `((resources . ,(length resources))
(available . ,(length available)) (available . ,(length available))
(waiters . ,(length waiters))))) (waiters . ,(length waiters)))))
(perform-operation (perform-operation
(choice-operation (choice-operation
(wrap-operation (wrap-operation
(put-operation reply stats) (put-operation reply stats)
(const #t)) (const #t))
(wrap-operation (sleep-operation 0.2) (wrap-operation (sleep-operation 0.2)
(const #f))))) (const #f)))))
(loop resources (loop resources
available available
waiters)) waiters))
(unknown (unknown
(simple-format (simple-format
(current-error-port) (current-error-port)
"unrecognised message to ~A resource pool channel: ~A\n" "unrecognised message to ~A resource pool channel: ~A\n"
name name
unknown) unknown)
(loop resources (loop resources
available available
waiters)))))) waiters)))))
#:unwind? #t))))
channel)) channel))