From d06230fcf4fbea966966479795d5d781a156df6f Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 23 Oct 2022 11:28:37 +0100
Subject: Close postgresql connections when the thread pool thread is idle

I think the idle connections associated with idle threads are still taking up
memory, so especially now that you can configure an arbitrary number of
threads (and thus connections), I think it's good to close them regularly.
---
 guix-data-service/database.scm | 10 ++++++++++
 guix-data-service/utils.scm    | 36 +++++++++++++++++++++++++++++++++++-
 2 files changed, 45 insertions(+), 1 deletion(-)

(limited to 'guix-data-service')

diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index 1204bb4..3a39798 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -27,6 +27,7 @@
 
             with-postgresql-connection-per-thread
             with-thread-postgresql-connection
+            close-thread-postgresql-connection
 
             with-postgresql-transaction
 
@@ -146,6 +147,15 @@
 
           (f conn)))))
 
+(define (close-thread-postgresql-connection)
+  (let ((conn (fluid-ref %thread-postgresql-connection)))
+    (when conn
+      (pg-conn-finish conn)
+      (hash-remove! (%postgresql-connections-hash-table)
+                    (current-thread))
+      (fluid-set! %thread-postgresql-connection
+                  conn))))
+
 (define* (with-postgresql-transaction conn f
                                       #:key always-rollback?)
   (exec-query conn "BEGIN;")
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index 20ac3c0..2527cf4 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -23,6 +23,8 @@
   #:use-module (ice-9 threads)
   #:use-module (fibers)
   #:use-module (fibers channels)
+  #:use-module (fibers operations)
+  #:use-module (fibers timers)
   #:use-module (fibers conditions)
   #:use-module (prometheus)
   #:export (call-with-time-logging
@@ -30,6 +32,8 @@
             prevent-inlining-for-tests
 
             %thread-pool-threads
+            %thread-pool-idle-seconds
+            %thread-pool-idle-thunk
             parallel-via-thread-pool-channel
             par-map&
             letpar&
@@ -62,6 +66,12 @@
 (define %thread-pool-threads
   (make-parameter 8))
 
+(define %thread-pool-idle-seconds
+  (make-parameter #f))
+
+(define %thread-pool-idle-thunk
+  (make-parameter #f))
+
 (define* (make-thread-pool-channel threads)
   (define (delay-logger seconds-delayed)
     (when (> seconds-delayed 1)
@@ -70,13 +80,37 @@
        "warning: thread pool delayed by ~1,2f seconds~%"
        seconds-delayed)))
 
+  (define idle-thunk
+    (%thread-pool-idle-thunk))
+
+  (define idle-seconds
+    (%thread-pool-idle-seconds))
+
   (let ((channel (make-channel)))
     (for-each
      (lambda _
        (call-with-new-thread
         (lambda ()
           (let loop ()
-            (match (get-message channel)
+            (match (if idle-seconds
+                       (perform-operation
+                        (choice-operation
+                         (get-operation channel)
+                         (wrap-operation (sleep-operation idle-seconds)
+                                         (const 'timeout))))
+                       (get-message channel))
+              ('timeout
+               (when idle-thunk
+                 (with-exception-handler
+                     (lambda (exn)
+                       (simple-format (current-error-port)
+                                      "worker thread idle thunk exception: ~A\n"
+                                      exn))
+                   idle-thunk
+                   #:unwind? #t))
+
+               (loop))
+
               (((? channel? reply) sent-time (? procedure? proc))
                (let ((time-delay
                       (- (get-internal-real-time)
-- 
cgit v1.2.3