Christopher Baines
4f0eafef0a
Add the ability to specify the max number of waiters for a resource pool, this provides a more efficient way of avoiding waiters for a resource pool continually rising. This commit also improves the destroy behaviour.
189 lines
5.3 KiB
Scheme
189 lines
5.3 KiB
Scheme
(use-modules (tests)
|
|
(fibers)
|
|
(unit-test)
|
|
(knots parallelism)
|
|
(knots resource-pool))
|
|
|
|
(define new-number
|
|
(let ((val 0))
|
|
(lambda ()
|
|
(set! val (1+ val))
|
|
val)))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let ((resource-pool (make-resource-pool
|
|
new-number
|
|
1)))
|
|
(assert-true
|
|
(number?
|
|
(with-resource-from-pool resource-pool
|
|
res
|
|
res))))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let ((resource-pool (make-resource-pool
|
|
new-number
|
|
1
|
|
#:add-resources-parallelism 1)))
|
|
(assert-true
|
|
(number?
|
|
(with-resource-from-pool resource-pool
|
|
res
|
|
res))))))
|
|
|
|
(let* ((error-constructor
|
|
(record-constructor &resource-pool-timeout))
|
|
(err
|
|
(error-constructor 'foo)))
|
|
(assert-equal
|
|
(resource-pool-timeout-error-pool err)
|
|
'foo))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let ((resource-pool (make-resource-pool
|
|
new-number
|
|
2)))
|
|
(fibers-for-each
|
|
(lambda _
|
|
(with-resource-from-pool resource-pool
|
|
res
|
|
res))
|
|
(iota 20))
|
|
|
|
(destroy-resource-pool resource-pool))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let ((resource-pool (make-resource-pool
|
|
new-number
|
|
2
|
|
#:destructor
|
|
(lambda (res)
|
|
#t))))
|
|
(fibers-for-each
|
|
(lambda _
|
|
(with-resource-from-pool resource-pool
|
|
res
|
|
res))
|
|
(iota 20))
|
|
|
|
(destroy-resource-pool resource-pool))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let ((resource-pool (make-resource-pool
|
|
new-number
|
|
2
|
|
#:idle-seconds 0.5
|
|
#:destructor
|
|
(lambda (res)
|
|
#t))))
|
|
(fibers-for-each
|
|
(lambda _
|
|
(with-resource-from-pool resource-pool
|
|
res
|
|
res))
|
|
(iota 20))
|
|
|
|
(let loop ((stats (resource-pool-stats resource-pool)))
|
|
(unless (= 0 (assq-ref stats 'resources))
|
|
(sleep 0.1)
|
|
(loop (resource-pool-stats resource-pool)))))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((counter 0)
|
|
(resource-pool (make-resource-pool
|
|
(lambda ()
|
|
(let ((start-val counter))
|
|
(sleep 0.05)
|
|
(if (= start-val counter)
|
|
(set! counter (+ 1 counter))
|
|
(error "collision detected")))
|
|
(new-number))
|
|
1)))
|
|
(fibers-batch-for-each
|
|
(lambda _
|
|
(with-resource-from-pool
|
|
resource-pool res
|
|
(let ((start-val counter))
|
|
(sleep 0.05)
|
|
(if (= start-val counter)
|
|
(set! counter (+ 1 counter))
|
|
(error "collision detected")))))
|
|
20
|
|
(iota 50)))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let* ((counter 0)
|
|
(resource-pool (make-resource-pool
|
|
(lambda ()
|
|
(let ((start-val counter))
|
|
(sleep 0.05)
|
|
(if (= start-val counter)
|
|
(set! counter (+ 1 counter))
|
|
(error "collision detected")))
|
|
(new-number))
|
|
1
|
|
#:default-checkout-timeout 120)))
|
|
(fibers-batch-for-each
|
|
(lambda _
|
|
(with-resource-from-pool
|
|
resource-pool res
|
|
(let ((start-val counter))
|
|
(sleep 0.05)
|
|
(if (= start-val counter)
|
|
(set! counter (+ 1 counter))
|
|
(error "collision detected")))))
|
|
20
|
|
(iota 50)))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let ((resource-pool (make-resource-pool
|
|
(lambda () #f)
|
|
1
|
|
#:default-max-waiters 1)))
|
|
(call-with-resource-from-pool
|
|
resource-pool
|
|
(lambda (res)
|
|
|
|
;; 1st waiter
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(if (resource-pool-destroyed-error? exn)
|
|
#t
|
|
(raise-exception exn)))
|
|
(lambda ()
|
|
(call-with-resource-from-pool
|
|
resource-pool
|
|
(lambda (res)
|
|
(error 'should-not-be-reached))))
|
|
#:unwind? #t)))
|
|
|
|
(while (= 0
|
|
(assq-ref
|
|
(resource-pool-stats resource-pool)
|
|
'waiters))
|
|
(sleep 0))
|
|
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(if (resource-pool-too-many-waiters-error? exn)
|
|
#t
|
|
(raise-exception exn)))
|
|
(lambda ()
|
|
;; 2nd waiter
|
|
(call-with-resource-from-pool
|
|
resource-pool
|
|
(lambda (res)
|
|
(error 'should-not-be-reached))))
|
|
#:unwind? #t))))))
|
|
|
|
(display "resource-pool test finished successfully\n")
|