Split the thread pool used for database connections

In to two thread pools, a default one, and one reserved for essential
functionality.

There are some pages that use slow queries, so this should help stop those
pages block other operations.

2 files changed, 72 insertions, 70 deletions

diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index 2527cf4..c5c6bdf 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -31,9 +31,8 @@
             with-time-logging
             prevent-inlining-for-tests
 
-            %thread-pool-threads
-            %thread-pool-idle-seconds
-            %thread-pool-idle-thunk
+            thread-pool-channel
+            make-thread-pool-channel
             parallel-via-thread-pool-channel
             par-map&
             letpar&
@@ -63,16 +62,10 @@
 (define-syntax-rule (prevent-inlining-for-tests var)
   (set! var var))
 
-(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* (make-thread-pool-channel threads
+                                   #:key
+                                   idle-thunk
+                                   idle-seconds)
   (define (delay-logger seconds-delayed)
     (when (> seconds-delayed 1)
       (format
@@ -80,12 +73,6 @@
        "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 _
@@ -142,27 +129,17 @@
      (iota threads))
     channel))
 
-(define %thread-pool-mutex (make-mutex))
-(define %thread-pool-channel #f)
-
-(define (make-thread-pool-channel!')
-  (with-mutex %thread-pool-mutex
-    (unless %thread-pool-channel
-      (set! %thread-pool-channel (make-thread-pool-channel
-                                  (%thread-pool-threads)))
-      (set! make-thread-pool-channel! (lambda () #t)))))
-
-(define make-thread-pool-channel!
-  (lambda () (make-thread-pool-channel!')))
+(define thread-pool-channel
+  (make-parameter #f))
 
 (define (defer-to-thread-pool-channel thunk)
-  (make-thread-pool-channel!)
   (let ((reply (make-channel)))
     (spawn-fiber
      (lambda ()
-       (put-message %thread-pool-channel (list reply
-                                               (get-internal-real-time)
-                                               thunk))))
+       (put-message (thread-pool-channel)
+                    (list reply
+                          (get-internal-real-time)
+                          thunk))))
     reply))
 
 (define (fetch-result-of-defered-thunk reply-channel)
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 34a7893..efdd92c 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -73,7 +73,12 @@
   #:export (%show-error-details
             handle-static-assets
             make-render-metrics
-            controller))
+            controller
+
+            reserved-thread-pool-channel))
+
+(define reserved-thread-pool-channel
+  (make-parameter #f))
 
 (define cache-control-default-max-age
   (* 60 60 24)) ; One day
@@ -636,23 +641,33 @@
   (define path
     (uri-path (request-uri request)))
 
-  (define (delegate-to f)
-    (or (f request
-           method-and-path-components
-           mime-types
-           body)
+  (define* (delegate-to f #:key use-reserved-thread-pool?)
+    (or (parameterize
+            ((thread-pool-channel
+              (if use-reserved-thread-pool?
+                  (reserved-thread-pool-channel)
+                  (thread-pool-channel))))
+          (f request
+             method-and-path-components
+             mime-types
+             body))
         (render-html
          #:sxml (general-not-found
                  "Page not found"
                  "")
          #:code 404)))
 
-  (define (delegate-to-with-secret-key-base f)
-    (or (f request
-           method-and-path-components
-           mime-types
-           body
-           secret-key-base)
+  (define* (delegate-to-with-secret-key-base f #:key use-reserved-thread-pool?)
+    (or (parameterize
+            ((thread-pool-channel
+              (if use-reserved-thread-pool?
+                  (reserved-thread-pool-channel)
+                  (thread-pool-channel))))
+          (f request
+             method-and-path-components
+             mime-types
+             body
+             secret-key-base))
         (render-html
          #:sxml (general-not-found
                  "Page not found"
@@ -663,18 +678,20 @@
    (base-controller request method-and-path-components #t)
    (match method-and-path-components
      (('GET)
-      (render-html
-       #:sxml (index
-               (parallel-via-thread-pool-channel
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (map
-                    (lambda (git-repository-details)
-                      (cons
-                       git-repository-details
-                       (all-branches-with-most-recent-commit
-                        conn (first git-repository-details))))
-                    (all-git-repositories conn))))))))
+      (parameterize ((thread-pool-channel
+                      (reserved-thread-pool-channel)))
+        (render-html
+         #:sxml (index
+                 (parallel-via-thread-pool-channel
+                  (with-thread-postgresql-connection
+                   (lambda (conn)
+                     (map
+                      (lambda (git-repository-details)
+                        (cons
+                         git-repository-details
+                         (all-branches-with-most-recent-commit
+                          conn (first git-repository-details))))
+                      (all-git-repositories conn)))))))))
      (('GET "builds")
       (delegate-to build-controller))
      (('GET "statistics")
@@ -687,7 +704,9 @@
          #:sxml (view-statistics guix-revisions-count
                                  count-derivations))))
      (('GET "metrics")
-      (render-metrics))
+      (parameterize ((thread-pool-channel
+                      (reserved-thread-pool-channel)))
+        (render-metrics)))
      (('GET "revision" args ...)
       (delegate-to revision-controller))
      (('GET "repositories")
@@ -697,12 +716,14 @@
      (('GET "package" _ ...)
       (delegate-to package-controller))
      (('GET "gnu" "store" filename)
-      ;; These routes are a little special, as the extensions aren't used for
-      ;; content negotiation, so just use the path from the request
-      (let ((path (uri-path (request-uri request))))
-        (if (string-suffix? ".drv" path)
-            (render-derivation (uri-decode path))
-            (render-store-item (uri-decode path)))))
+      (parameterize ((thread-pool-channel
+                      (reserved-thread-pool-channel)))
+        ;; These routes are a little special, as the extensions aren't used for
+        ;; content negotiation, so just use the path from the request
+        (let ((path (uri-path (request-uri request))))
+          (if (string-suffix? ".drv" path)
+              (render-derivation (uri-decode path))
+              (render-store-item (uri-decode path))))))
      (('GET "gnu" "store" filename "formatted")
       (if (string-suffix? ".drv" filename)
           (render-formatted-derivation (string-append "/gnu/store/" filename))
@@ -731,16 +752,20 @@
           (render-json-derivation (string-append "/gnu/store/" filename))
           (render-json-store-item (string-append "/gnu/store/" filename))))
      (('GET "build-servers")
-      (delegate-to-with-secret-key-base build-server-controller))
+      (delegate-to-with-secret-key-base build-server-controller
+                                        #:use-reserved-thread-pool? #t))
      (('GET "dumps" _ ...)
       (delegate-to dumps-controller))
      (((or 'GET 'POST) "build-server" _ ...)
       (delegate-to-with-secret-key-base build-server-controller))
      (('GET "compare" _ ...)             (delegate-to compare-controller))
      (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
-     (('GET "jobs" _ ...)   (delegate-to jobs-controller))
-     (('GET "job" job-id)   (delegate-to jobs-controller))
-     (('GET _ ...) (delegate-to nar-controller))
+     (('GET "jobs" _ ...)   (delegate-to jobs-controller
+                                         #:use-reserved-thread-pool? #t))
+     (('GET "job" job-id)   (delegate-to jobs-controller
+                                         #:use-reserved-thread-pool? #t))
+     (('GET _ ...) (delegate-to nar-controller
+                                #:use-reserved-thread-pool? #t))
      ((method path ...)
       (render-html
        #:sxml (general-not-found