Stop using a pool of threads for database operations

Now that squee cooperates with suspendable ports, this is unnecessary. Use a
connection pool to still support running queries in parallel using multiple
connections.

1 files changed, 100 insertions, 115 deletions

diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm
index cf6d07f..6724d6f 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -34,6 +34,7 @@
   #:use-module (guix-data-service model git-repository)
   #:use-module (guix-data-service web view html)
   #:use-module (guix-data-service web revision controller)
+  #:use-module (guix-data-service web controller)
   #:use-module (guix-data-service web repository html)
   #:export (repository-controller))
 
@@ -47,7 +48,7 @@
   (match method-and-path-components
     (('GET "repositories")
      (letpar& ((git-repositories
-                (with-thread-postgresql-connection
+                (with-resource-from-pool (connection-pool) conn
                  all-git-repositories)))
        (case (most-appropriate-mime-type
               '(application/json text/html)
@@ -67,17 +68,14 @@
            #:sxml
            (view-git-repositories git-repositories))))))
     (('GET "repository" id)
-     (match (parallel-via-thread-pool-channel
-             (with-thread-postgresql-connection
-              (lambda (conn)
-                (select-git-repository conn id))))
+     (match (with-resource-from-pool (connection-pool) conn
+              (select-git-repository conn id))
        ((label url cgit-url-base fetch-with-authentication?)
         (letpar& ((branches
-                   (with-thread-postgresql-connection
-                    (lambda (conn)
-                      (all-branches-with-most-recent-commit
-                       conn
-                       (string->number id))))))
+                   (with-resource-from-pool (connection-pool) conn
+                     (all-branches-with-most-recent-commit
+                      conn
+                      (string->number id)))))
           (case (most-appropriate-mime-type
                  '(application/json text/html)
                  mime-types)
@@ -122,17 +120,16 @@
                (before_date    ,parse-datetime)
                (limit_results  ,parse-result-limit #:default 100)))))
        (letpar& ((revisions
-                  (with-thread-postgresql-connection
-                   (lambda (conn)
-                     (most-recent-commits-for-branch
-                      conn
-                      (string->number repository-id)
-                      branch-name
-                      #:limit (assq-ref parsed-query-parameters 'limit_results)
-                      #:after-date (assq-ref parsed-query-parameters
-                                             'after_date)
-                      #:before-date (assq-ref parsed-query-parameters
-                                              'before_date))))))
+                  (with-resource-from-pool (connection-pool) conn
+                    (most-recent-commits-for-branch
+                     conn
+                     (string->number repository-id)
+                     branch-name
+                     #:limit (assq-ref parsed-query-parameters 'limit_results)
+                     #:after-date (assq-ref parsed-query-parameters
+                                            'after_date)
+                     #:before-date (assq-ref parsed-query-parameters
+                                             'before_date)))))
          (case (most-appropriate-mime-type
                 '(application/json text/html)
                 mime-types)
@@ -164,12 +161,11 @@
                              revisions)))))))))
     (('GET "repository" repository-id "branch" branch-name "package" package-name)
      (letpar& ((package-versions
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (package-versions-for-branch conn
-                                                (string->number repository-id)
-                                                branch-name
-                                                package-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (package-versions-for-branch conn
+                                               (string->number repository-id)
+                                               branch-name
+                                               package-name))))
        (case (most-appropriate-mime-type
               '(application/json text/html)
               mime-types)
@@ -216,17 +212,17 @@
              request
              `((system ,parse-system #:default "x86_64-linux")))))
        (letpar& ((system-test-history
-                  (with-thread-postgresql-connection
-                   (lambda (conn)
-                     (system-test-derivations-for-branch
-                      conn
-                      (string->number repository-id)
-                      branch-name
-                      (assq-ref parsed-query-parameters
-                                'system)
-                      system-test-name))))
+                  (with-resource-from-pool (connection-pool) conn
+                    (system-test-derivations-for-branch
+                     conn
+                     (string->number repository-id)
+                     branch-name
+                     (assq-ref parsed-query-parameters
+                               'system)
+                     system-test-name)))
                  (valid-systems
-                  (with-thread-postgresql-connection list-systems)))
+                  (call-with-resource-from-pool (connection-pool)
+                                                list-systems)))
          (case (most-appropriate-mime-type
                 '(application/json text/html)
                 mime-types)
@@ -261,11 +257,10 @@
                      system-test-history)))))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (if commit-hash
            (render-view-revision mime-types
                                  commit-hash
@@ -278,11 +273,10 @@
                                       branch-name))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages")
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (if commit-hash
            (let ((parsed-query-parameters
                   (guard-against-mutually-exclusive-query-parameters
@@ -319,11 +313,10 @@
                                       branch-name))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations")
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (if commit-hash
            (let ((parsed-query-parameters
                   (guard-against-mutually-exclusive-query-parameters
@@ -353,12 +346,11 @@
                                       branch-name))))
     (('GET "repository" repository-id "branch" branch-name
            "latest-processed-revision" "fixed-output-package-derivations")
-     (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+     (let ((commit-hash
+            (with-resource-from-pool (connection-pool) conn
+              (latest-processed-commit-for-branch conn
+                                                  repository-id
+                                                  branch-name))))
        (if commit-hash
            (let ((parsed-query-parameters
                   (guard-against-mutually-exclusive-query-parameters
@@ -383,12 +375,11 @@
                                       repository-id
                                       branch-name))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivation-outputs")
-     (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+     (let ((commit-hash
+            (with-resource-from-pool (connection-pool) conn
+              (latest-processed-commit-for-branch conn
+                                                  repository-id
+                                                  branch-name))))
        (if commit-hash
            (let ((parsed-query-parameters
                   (guard-against-mutually-exclusive-query-parameters
@@ -431,11 +422,10 @@
     (('GET "repository" repository-id "branch" branch-name
            "latest-processed-revision" "system-tests")
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (if commit-hash
            (let ((parsed-query-parameters
                   (parse-query-parameters
@@ -450,11 +440,10 @@
                                       branch-name))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility")
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (if commit-hash
            (render-revision-package-reproduciblity
             mime-types
@@ -473,11 +462,10 @@
                                       branch-name))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability")
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (if commit-hash
            (render-revision-package-substitute-availability mime-types
                                                             commit-hash
@@ -488,11 +476,10 @@
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision"
            "lint-warnings")
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (if commit-hash
            (let ((parsed-query-parameters
                   (parse-query-parameters
@@ -523,11 +510,10 @@
                                       branch-name))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version)
      (letpar& ((commit-hash
-                (with-thread-postgresql-connection
-                 (lambda (conn)
-                   (latest-processed-commit-for-branch conn
-                                                       repository-id
-                                                       branch-name)))))
+                (with-resource-from-pool (connection-pool) conn
+                  (latest-processed-commit-for-branch conn
+                                                      repository-id
+                                                      branch-name))))
        (let ((parsed-query-parameters
               (parse-query-parameters
                request
@@ -558,9 +544,9 @@
 
 (define (parse-build-system)
   (let ((systems
-         (parallel-via-thread-pool-channel
-          (with-thread-postgresql-connection
-           list-systems))))
+         (call-with-resource-from-pool
+          (connection-pool)
+          list-systems)))
     (lambda (s)
       (if (member s systems)
           s
@@ -598,16 +584,15 @@
            (assq-ref parsed-query-parameters 'target)))
       (letpar&
           ((package-derivations
-            (with-thread-postgresql-connection
-             (lambda (conn)
-               (package-derivations-for-branch conn
-                                               (string->number repository-id)
-                                               branch-name
-                                               system
-                                               target
-                                               package-name))))
+            (with-resource-from-pool (connection-pool) conn
+              (package-derivations-for-branch conn
+                                              (string->number repository-id)
+                                              branch-name
+                                              system
+                                              target
+                                              package-name)))
            (build-server-urls
-            (with-thread-postgresql-connection
+            (call-with-resource-from-pool (connection-pool)
              select-build-server-urls-by-id)))
         (case (most-appropriate-mime-type
                '(application/json text/html)
@@ -635,10 +620,10 @@
                                     package-derivations))))))
           (else
            (letpar& ((systems
-                      (with-thread-postgresql-connection
+                      (with-resource-from-pool (connection-pool) conn
                        list-systems))
                      (targets
-                      (with-thread-postgresql-connection
+                      (with-resource-from-pool (connection-pool) conn
                        valid-targets)))
              (render-html
               #:sxml (view-branch-package-derivations
@@ -673,17 +658,17 @@
            (assq-ref parsed-query-parameters 'output)))
       (letpar&
           ((package-outputs
-            (with-thread-postgresql-connection
-             (lambda (conn)
-               (package-outputs-for-branch conn
-                                           (string->number repository-id)
-                                           branch-name
-                                           system
-                                           target
-                                           package-name
-                                           output-name))))
+            (with-resource-from-pool (connection-pool) conn
+              (package-outputs-for-branch conn
+                                          (string->number repository-id)
+                                          branch-name
+                                          system
+                                          target
+                                          package-name
+                                          output-name)))
            (build-server-urls
-            (with-thread-postgresql-connection
+            (call-with-resource-from-pool
+             (connection-pool)
              select-build-server-urls-by-id)))
         (case (most-appropriate-mime-type
                '(application/json text/html)
@@ -711,10 +696,10 @@
                                     package-outputs))))))
           (else
            (letpar& ((systems
-                      (with-thread-postgresql-connection
+                      (with-resource-from-pool (connection-pool) conn
                        list-systems))
                      (targets
-                      (with-thread-postgresql-connection
+                      (with-resource-from-pool (connection-pool) conn
                        valid-targets)))
              (render-html
               #:sxml (view-branch-package-outputs