Christopher Baines
ab5411da42
All checks were successful
/ test (push) Successful in 9s
This was motivated by trying to allow for completely cleaning up resource pools, which involved removing their use of fiberize which currently has no destroy mechanism. As part of this, there's a new parallelism limiter mechanism using resource pools rather than fibers, and also a fixed size resource pool. The tests now drain? and destroy the resource pools to check cleaning up.
214 lines
5.9 KiB
Scheme
214 lines
5.9 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)))
|
|
|
|
(destroy-resource-pool resource-pool))))
|
|
|
|
(run-fibers-for-tests
|
|
(lambda ()
|
|
(let ((resource-pool (make-fixed-size-resource-pool
|
|
(list 1))))
|
|
(assert-true
|
|
(number?
|
|
(with-resource-from-pool resource-pool
|
|
res
|
|
res)))
|
|
|
|
(destroy-resource-pool resource-pool))))
|
|
|
|
(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)))
|
|
|
|
(destroy-resource-pool resource-pool))))
|
|
|
|
(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
|
|
#:timeout #f)))
|
|
(unless (= 0 (assq-ref stats 'resources))
|
|
(sleep 0.1)
|
|
(loop (resource-pool-stats resource-pool #:timeout #f))))
|
|
|
|
(destroy-resource-pool 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))
|
|
|
|
(destroy-resource-pool 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
|
|
#:default-checkout-timeout 5)))
|
|
(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))
|
|
|
|
(destroy-resource-pool resource-pool))))
|
|
|
|
(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)
|
|
#f)))
|
|
#:unwind? #t)))
|
|
|
|
(while (= 0
|
|
(assq-ref
|
|
(resource-pool-stats resource-pool #:timeout #f)
|
|
'waiters))
|
|
(sleep 0.1))
|
|
|
|
(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)))
|
|
|
|
(destroy-resource-pool resource-pool))))
|
|
|
|
(display "resource-pool test finished successfully\n")
|