guile-knots/tests/resource-pool.scm

(use-modules (tests)
             (fibers)
             (fibers channels)
             (unit-test)
             (knots parallelism)
             (knots resource-pool))

(run-fibers-for-tests
 (lambda ()
   (let ((parallelism-limiter (make-parallelism-limiter
                               1)))
     (with-parallelism-limiter parallelism-limiter
                               #f)

     (destroy-parallelism-limiter parallelism-limiter))))

(run-fibers-for-tests
 (lambda ()
   (let ((parallelism-limiter (make-parallelism-limiter
                               1))
         (channel
           (make-channel)))
     (spawn-fiber
      (lambda ()
        (with-parallelism-limiter parallelism-limiter
           (put-message channel #t)
           (sleep 1))))
     (get-message channel)
     (destroy-parallelism-limiter parallelism-limiter))))

(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))))

(run-fibers-for-tests
 (lambda ()
   (let ((resource-pool (make-resource-pool
                         (const 'foo)
                         1
                         #:lifetime 1
                         #:destructor
                         (const #t))))
     (for-each
      (lambda _
        (with-resource-from-pool resource-pool
            res
          res))
      (iota 20))

     (destroy-resource-pool resource-pool))))

(display "resource-pool test finished successfully\n")