database: use custom connection pool

This works around some performance issues with the db-lib connection
pool (see racket/db#36).

Author: Bogdanp

koyo-doc/scribblings/database.scrbl

@@ -24,6 +24,7 @@ working with database connections.
 @defproc[(make-database-factory [connector (-> connection?)]
                                 [#:log-statements? log-statements? boolean? #f]
                                 [#:max-connections max-connections exact-positive-integer? 16]
+                                [#:connection-idle-ttl connection-idle-ttl (or/c inf.0 exact-positive-integer?) (* 60 1000)]
                                 [#:max-idle-connections max-idle-connections exact-positive-integer? 2]) (-> database?)]{
 
   Returns a function that will create a database component containing a
@@ -36,13 +37,21 @@ working with database connections.
   executed from, the name of the procedure that executed the query and
   the statement itself.
 
+  The @racket[#:connection-idle-ttl] argument controls the maximum
+  amount of time (in milliseconds) that connections will remain idle
+  in the pool for. The @racket[#:max-idle-connections] argument is
+  deprecated and will be removed in a future release.
+
   @history[
     #:changed "0.8" @elem{The component no longer forcefully shuts
      down its associated custodian when the component is stopped. There
      is now a lower bound on @tt{crypto-lib} for version 1.6 to ensure
      that shared libraries (eg. for libargon2) correctly get included in
      distributions (using @tt{koyo dist} or @tt{raco distribute}).}
     #:changed "0.20" @elem{Addded the @racket[#:log-statements?]
+     argument.}
+    #:changed "0.45" @elem{Added the @racket[#:connection-idle-ttl]
+     argument. Deprecated the @racket[#:max-idle-connections]
      argument.}]
 }
 
@@ -67,13 +76,12 @@ working with database connections.
 
   Retrieves a database connection from the pool, enters a transaction
   with the requested @racket[#:isolation] level and passes the
-  connection to @racket[proc].  If @racket[proc] completes
-  successfully, the transaction is committed, otherwise it is rolled
-  back.
+  connection to @racket[proc]. If @racket[proc] completes successfully,
+  the transaction is committed, otherwise it is rolled back.
 
   Nested calls to @racket[call-with-database-transaction] reuse the
-  same connection and, if the database supports it, create nested
-  transactions.
+  same connection and create nested transactions, if supported by the
+  database.
 }
 
 @deftogether[(
@@ -96,9 +104,8 @@ working with database connections.
                                   'read-uncommitted)])]
 )]{
 
-  These forms are syntactic sugar for calling @racket[call-with-database-connection]
-  and @racket[call-with-database-transaction], respectively, with an
-  anonymous thunk.
+  These forms are syntactic sugar for calling @racket[call-with-database-connection] and
+  @racket[call-with-database-transaction], respectively, with an anonymous thunk.
 
   For example, the following forms are equivalent:
 

koyo-lib/info.rkt

@@ -1,7 +1,7 @@
 #lang info
 
 (define license 'BSD-3-Clause)
-(define version "0.44.4")
+(define version "0.45")
 (define collection 'multi)
 
 (define deps
@@ -21,6 +21,7 @@
     "monocle-lib"
     "net-lib"
     "raco-invoke"
+    "resource-pool-lib"
     "scribble-text-lib"
     "srfi-lite-lib"
     "struct-define"

koyo-lib/koyo/database.rkt

@@ -3,6 +3,7 @@
 (require (for-syntax racket/base
                      syntax/parse/pre)
          component
+         data/pool
          db
          (only-in db/private/generic/interfaces
                   connection<%>
@@ -24,6 +25,7 @@
    (->* [(-> connection?)]
         [#:log-statements? boolean?
          #:max-connections exact-positive-integer?
+         #:connection-idle-ttl (or/c +inf.0 exact-positive-integer?)
          #:max-idle-connections exact-positive-integer?]
         (-> database?))]
   [call-with-database-connection
@@ -46,32 +48,38 @@
   (connection-pool
    connector ;; noqa
    max-connections ;; noqa
-   max-idle-connections ;; noqa
+   connection-idle-ttl ;; noqa
    log-statements?)
   #:methods gen:component
   [(define (component-start db) ;; noqa
-     (match-define (database _ connector max-conns max-idle-conns _log?)
-       db)
+     (match-define (database _ connector max-size idle-ttl _) db)
      (define pool
-       (connection-pool
-        #:max-connections max-conns
-        #:max-idle-connections max-idle-conns
-        connector))
+       (make-pool
+        #:max-size max-size
+        #:idle-ttl idle-ttl
+        (lambda ()
+          ;; This procedure must not raise an exception. So, on connect failure, return
+          ;; a dummy object whose connected? method re-raises the exception. This makes
+          ;; database-borrow-connection raise at the appropriate time.
+          (with-handlers ([exn:fail? (λ (e) (new dummy-connection% [p pool] [e e]))])
+            (connector)))
+        disconnect))
      (struct-copy database db [connection-pool pool]))
 
    (define (component-stop db) ;; noqa
-     (send (database-connection-pool db) clear-idle)
+     (pool-close! (database-connection-pool db))
      (struct-copy database db [connection-pool #f]))])
 
 (define ((make-database-factory connector
                                 #:log-statements? [log-statements? #f]
                                 #:max-connections [max-connections 16]
-                                #:max-idle-connections [max-idle-connections 2]))
+                                #:connection-idle-ttl [connection-idle-ttl (* 60 1000)]
+                                #:max-idle-connections [_max-idle-connections 2]))
   (database
    #;connection-pool #f
    #;connector connector
    #;max-connections max-connections
-   #;max-idle-connections max-idle-connections
+   #;connection-idle-ttl connection-idle-ttl
    #;log-statements log-statements?))
 
 (define current-database-connection
@@ -90,11 +98,9 @@
                   (set! conn the-conn)
                   (set! close void))]
             [else
-             (define the-conn
-               (connection-pool-lease
-                (database-connection-pool db)))
+             (define the-conn (database-borrow-connection db))
              (set! conn the-conn)
-             (set! close (λ () (disconnect the-conn)))])))
+             (set! close (λ () (database-release-connection db the-conn)))])))
       (lambda ()
         (with-timing "proc"
           (parameterize ([current-database-connection conn])
@@ -114,11 +120,19 @@
           (proc conn))))))
 
 (define (database-borrow-connection db)
-  (connection-pool-lease
-   (database-connection-pool db)))
+  (define the-pool
+    (database-connection-pool db))
+  (define the-conn
+    (pool-take! the-pool))
+  (cond
+    [(send the-conn connected?)
+     the-conn]
+    [else
+     (pool-abandon! the-pool the-conn)
+     (database-borrow-connection db)]))
 
-(define (database-release-connection _db conn)
-  (disconnect conn))
+(define (database-release-connection db conn)
+  (pool-release! (database-connection-pool db) conn))
 
 (define-syntax (with-database-connection stx)
   (syntax-parse stx
@@ -140,6 +154,37 @@
          (lambda (name)
            e ...))]))
 
+(define dummy-connection%
+  (class* object% (connection<%>)
+    (init-field p e)
+    (super-new)
+
+    (define-syntax-rule (define-dummies [id arg ...] ...)
+      (begin
+        (define/public (id arg ...)
+          (unless abandoned?
+            (set! abandoned? #t)
+            (pool-abandon! p this))
+          (raise e)) ...))
+
+    (define abandoned? #f)
+
+    (define-dummies
+      [connected?]
+      [get-dbsystem]
+      [query fsym stmt cursor?]
+      [prepare fsym stmt close-on-exec?]
+      [fetch/cursor fsym cursor fetch-size]
+      [get-base]
+      [list-tables fsym schema]
+      [start-transaction fsym isolation option cwt?]
+      [end-transaction fsym mode cwt?]
+      [transaction-status fsym]
+      [free-statement pst need-lock?])
+
+    (define/public (disconnect)
+      (void))))
+
 
 ;; Query Logging ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;