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))
+                                        (delay-logger #f)
-                                        (duration-logger (const #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))
+                             (delay-logger #f)
-                             (duration-logger (const #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
+       (when delay-logger
-           (lambda ()
+         (delay-logger/safe
-             (with-exception-handler
+          (/ (- (get-internal-real-time) checkout-start-time)
-                 (lambda (exn)
+             internal-time-units-per-second)))
-                   ;; Unwind the stack before calling put-message, as
+
-                   ;; this avoids inconsistent behaviour with
+       (let ((proc-start-time (get-internal-real-time)))
-                   ;; continuation barriers
+         (call-with-values
-                   (put-message
+             (lambda ()
-                    channel
+               (with-exception-handler
-                    (list (if (or destroy-resource-on-exception?
+                   (lambda (exn)
-                                  (resource-pool-destroy-resource-exception? exn))
+                     ;; Unwind the stack before calling put-message, as
-                              'destroy
+                     ;; this avoids inconsistent behaviour with
-                              'return)
+                     ;; continuation barriers
-                          resource-id))
+                     (when duration-logger
-                   (raise-exception exn))
+                       (duration-logger/safe
-               (lambda ()
+                        (/ (- (get-internal-real-time) proc-start-time)
-                 (with-exception-handler
+                           internal-time-units-per-second)))
-                     (lambda (exn)
+                     (put-message
-                          (let ((stack
+                      channel
-                                 (match (fluid-ref %stacks)
+                      (list (if (or destroy-resource-on-exception?
-                                   ((stack-tag . prompt-tag)
+                                    (resource-pool-destroy-resource-exception? exn))
-                                    (make-stack #t
+                                'destroy
-                                                0 prompt-tag
+                                'return)
-                                                0 (and prompt-tag 1)))
+                            resource-id))
-                                   (_
+                     (raise-exception exn))
-                                    (make-stack #t)))))
+                 (lambda ()
-                            (raise-exception
+                   (with-exception-handler
-                             (make-exception
+                       (lambda (exn)
-                              exn
+                            (let ((stack
-                              (make-knots-exception stack)))))
+                                   (match (fluid-ref %stacks)
-                   (lambda ()
+                                     ((stack-tag . prompt-tag)
-                     (proc resource-value))))
+                                      (make-stack #t
-               #:unwind? #t))
+                                                  0 prompt-tag
-         (lambda vals
+                                                  0 (and prompt-tag 1)))
-           (put-message channel
+                                     (_
-                        `(return ,resource-id))
+                                      (make-stack #t)))))
-           (apply values vals)))))))
+                              (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

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