diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 8092a3a..88c102c 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -103,6 +103,14 @@ 'documentation "Return the configuration alist of the resource pool.") +(define (resource-pool-delay-logger resource-pool) + (assq-ref (resource-pool-configuration resource-pool) + 'delay-logger)) + +(define (resource-pool-duration-logger resource-pool) + (assq-ref (resource-pool-configuration resource-pool) + 'duration-logger)) + (set-record-type-printer! (lambda (resource-pool port) @@ -164,8 +172,8 @@ (define* (make-fixed-size-resource-pool resources-list-or-vector #:key - (delay-logger (const #f)) - (duration-logger (const #f)) + (delay-logger #f) + (duration-logger #f) scheduler (name "unnamed") default-checkout-timeout @@ -193,6 +201,19 @@ Maximum number of fibers that may queue waiting for a resource. When this limit is exceeded, @code{&resource-pool-too-many-waiters} is raised when a resource is requested. Defaults to @code{#f} (no limit). +@item #:delay-logger +Called as @code{(delay-logger seconds)} with the time spent waiting +for a resource to become available. Defaults to @code{#f} (no +logging). + +@item #:duration-logger +Called as @code{(duration-logger seconds)} after the proc passed to +@code{call-with-resource-from-pool} completes, whether it returned +normally or raised an exception. Can be overridden per-call via the +@code{#:duration-logger} keyword argument to +@code{call-with-resource-from-pool}. Defaults to @code{#f} (no +logging). + @item #:scheduler The Fibers scheduler to use for the pool's internal fiber. Defaults to the current scheduler. @@ -547,8 +568,8 @@ to the current scheduler. (define* (make-resource-pool return-new-resource max-size #:key (min-size 0) (idle-seconds #f) - (delay-logger (const #f)) - (duration-logger (const #f)) + (delay-logger #f) + (duration-logger #f) destructor lifetime scheduler @@ -605,6 +626,19 @@ Maximum number of fibers that may queue waiting for a resource. When this limit is exceeded, @code{&resource-pool-too-many-waiters} is raised when a resource is requested. Defaults to @code{#f} (no limit). +@item #:delay-logger +Called as @code{(delay-logger seconds)} with the time spent waiting +for a resource to become available. Defaults to @code{#f} (no +logging). + +@item #:duration-logger +Called as @code{(duration-logger seconds)} after the proc passed to +@code{call-with-resource-from-pool} completes, whether it returned +normally or raised an exception. Can be overridden per-call via the +@code{#:duration-logger} keyword argument to +@code{call-with-resource-from-pool}. Defaults to @code{#f} (no +logging). + @item #:scheduler The Fibers scheduler to use for the pool's internal fiber. Defaults to the current scheduler. @@ -1374,9 +1408,20 @@ receive @code{&resource-pool-destroyed}." (timeout-handler (resource-pool-default-timeout-handler)) (max-waiters 'default) (channel (resource-pool-channel pool)) - (destroy-resource-on-exception? #f)) + (destroy-resource-on-exception? #f) + (delay-logger (resource-pool-delay-logger pool)) + (duration-logger (resource-pool-duration-logger pool))) "Call PROC with a resource from POOL, blocking until a resource becomes -available. Return the resource once PROC has returned." +available. Return the resource once PROC has returned. + +@code{#:delay-logger} is called as @code{(delay-logger seconds)} with +the time spent waiting for a resource to become available. Defaults +to the pool's @code{#:delay-logger} if not specified. + +@code{#:duration-logger} is called as @code{(duration-logger seconds)} +after PROC completes, whether it returned normally or raised an +exception. Defaults to the pool's @code{#:duration-logger} if not +specified." (define timeout-or-default (if (eq? timeout 'default) @@ -1390,6 +1435,26 @@ available. Return the resource once PROC has returned." 'default-max-waiters) max-waiters)) + (define (delay-logger/safe seconds) + (with-exception-handler + ;; Ignore exceptions, since this would break returning the + ;; resource + (lambda (exn) #f) + (lambda () + (delay-logger seconds)) + #:unwind? #t)) + + (define (duration-logger/safe seconds) + (with-exception-handler + ;; Ignore exceptions, since this would break returning the + ;; resource + (lambda (exn) #f) + (lambda () + (duration-logger seconds)) + #:unwind? #t)) + + (define checkout-start-time (get-internal-real-time)) + (unless channel (raise-exception (make-resource-pool-destroyed-error pool))) @@ -1462,43 +1527,57 @@ available. Return the resource once PROC has returned." (raise-exception (make-resource-pool-destroyed-error pool))) (('success resource-id resource-value) - (call-with-values - (lambda () - (with-exception-handler - (lambda (exn) - ;; Unwind the stack before calling put-message, as - ;; this avoids inconsistent behaviour with - ;; continuation barriers - (put-message - channel - (list (if (or destroy-resource-on-exception? - (resource-pool-destroy-resource-exception? exn)) - 'destroy - 'return) - resource-id)) - (raise-exception exn)) - (lambda () - (with-exception-handler - (lambda (exn) - (let ((stack - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1))) - (_ - (make-stack #t))))) - (raise-exception - (make-exception - exn - (make-knots-exception stack))))) - (lambda () - (proc resource-value)))) - #:unwind? #t)) - (lambda vals - (put-message channel - `(return ,resource-id)) - (apply values vals))))))) + (when delay-logger + (delay-logger/safe + (/ (- (get-internal-real-time) checkout-start-time) + internal-time-units-per-second))) + + (let ((proc-start-time (get-internal-real-time))) + (call-with-values + (lambda () + (with-exception-handler + (lambda (exn) + ;; Unwind the stack before calling put-message, as + ;; this avoids inconsistent behaviour with + ;; continuation barriers + (when duration-logger + (duration-logger/safe + (/ (- (get-internal-real-time) proc-start-time) + internal-time-units-per-second))) + (put-message + channel + (list (if (or destroy-resource-on-exception? + (resource-pool-destroy-resource-exception? exn)) + 'destroy + 'return) + resource-id)) + (raise-exception exn)) + (lambda () + (with-exception-handler + (lambda (exn) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) + (lambda () + (proc resource-value)))) + #:unwind? #t)) + (lambda vals + (when duration-logger + (duration-logger/safe + (/ (- (get-internal-real-time) proc-start-time) + internal-time-units-per-second))) + (put-message channel + `(return ,resource-id)) + (apply values vals)))))))) (define-syntax-rule (with-resource-from-pool pool resource exp ...) "Evaluate EXP ... with RESOURCE bound to a resource checked out from diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm index b3a84d7..5726ad3 100644 --- a/tests/resource-pool.scm +++ b/tests/resource-pool.scm @@ -282,4 +282,50 @@ (destroy-resource-pool resource-pool)))) +;; Test delay-logger and duration-logger +(run-fibers-for-tests + (lambda () + (let* ((logged-delay #f) + (logged-duration #f) + (resource-pool (make-fixed-size-resource-pool + (list 1) + #:delay-logger + (lambda (seconds) + (set! logged-delay seconds)) + #:duration-logger + (lambda (seconds) + (set! logged-duration seconds))))) + + (call-with-resource-from-pool resource-pool + (lambda (res) + (sleep 0.2))) + + (assert-true (number? logged-delay)) + (assert-true (number? logged-duration)) + (assert-true (>= logged-duration 0.1)) + + (destroy-resource-pool resource-pool)))) + +;; Test per-call duration-logger overrides pool default +(run-fibers-for-tests + (lambda () + (let* ((pool-logged #f) + (call-logged #f) + (resource-pool (make-fixed-size-resource-pool + (list 1) + #:duration-logger + (lambda (seconds) + (set! pool-logged seconds))))) + + (call-with-resource-from-pool resource-pool + (lambda (res) #t) + #:duration-logger + (lambda (seconds) + (set! call-logged seconds))) + + (assert-true (not pool-logged)) + (assert-true (number? call-logged)) + + (destroy-resource-pool resource-pool)))) + (display "resource-pool test finished successfully\n")