Sort out resource pool delay and duration logging

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!
  <resource-pool>
  (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,6 +1527,12 @@ available.  Return the resource once PROC has returned."
        (raise-exception
         (make-resource-pool-destroyed-error pool)))
       (('success resource-id resource-value)
+       (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
@@ -1469,6 +1540,10 @@ available.  Return the resource once PROC has returned."
                      ;; 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?
@@ -1496,9 +1571,13 @@ available.  Return the resource once PROC has returned."
                        (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)))))))
+             (apply values vals))))))))
 
 (define-syntax-rule (with-resource-from-pool pool resource exp ...)
   "Evaluate EXP ... with RESOURCE bound to a resource checked out from

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