From 7251c7d653de29f36d50b33badf05a5db983b8e7 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 9 Jul 2023 16:52:35 +0100 Subject: 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. --- guix-data-service/web/build-server/controller.scm | 130 ++++++++++------------ 1 file changed, 61 insertions(+), 69 deletions(-) (limited to 'guix-data-service/web/build-server') diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm index 7c31cf1..ca03284 100644 --- a/guix-data-service/web/build-server/controller.scm +++ b/guix-data-service/web/build-server/controller.scm @@ -26,6 +26,7 @@ #:use-module (guix-data-service substitutes) #:use-module (guix-data-service web render) #:use-module (guix-data-service web query-parameters) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service model utils) #:use-module (guix-data-service model build) @@ -60,18 +61,16 @@ (build-server-build-id (assq-ref query-parameters 'build_server_build_id)) (build - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (if build-server-build-id - (select-build-by-build-server-and-build-server-build-id - conn - build-server-id - build-server-build-id) - (select-build-by-build-server-and-derivation-file-name - conn - build-server-id - derivation-file-name))))))) + (with-resource-from-pool (connection-pool) conn + (if build-server-build-id + (select-build-by-build-server-and-build-server-build-id + conn + build-server-id + build-server-build-id) + (select-build-by-build-server-and-derivation-file-name + conn + build-server-id + derivation-file-name))))) (if build (render-html #:sxml @@ -88,13 +87,11 @@ ; guix-build-coordinator ; doesn't mark builds as ; failed-dependency - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-required-builds-that-failed - conn - build-server-id - derivation-file-name)))) + (with-resource-from-pool (connection-pool) conn + (select-required-builds-that-failed + conn + build-server-id + derivation-file-name)) #f))))) (render-html #:sxml (general-not-found @@ -121,27 +118,26 @@ (define build-server-id (string->number build-server-id-string)) - (define (call-via-thread-pool-channel handler) + (define (spawn-fiber-for-handler handler) (spawn-fiber (lambda () - (parallel-via-thread-pool-channel - (with-postgresql-connection - "build-event-handler-conn" - (lambda (conn) - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception in build event handler: ~A\n" - exn)) - (lambda () - (with-throw-handler #t - (lambda () - (handler conn)) - (lambda _ - (display (backtrace) (current-error-port)) - (display "\n" (current-error-port))))) - #:unwind? #t))))))) + (with-postgresql-connection + "build-event-handler-conn" + (lambda (conn) + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception in build event handler: ~A\n" + exn)) + (lambda () + (with-throw-handler #t + (lambda () + (handler conn)) + (lambda _ + (display (backtrace) (current-error-port)) + (display "\n" (current-error-port))))) + #:unwind? #t)))))) (define (with-build-ids-for-status data build-ids @@ -217,24 +213,24 @@ #f)))) items)) - (letpar& ((build-ids - (with-thread-postgresql-connection - (lambda (conn) - (with-postgresql-transaction - conn - (lambda (conn) - (handle-derivation-events - conn - filtered-items))))))) + (let ((build-ids + (with-resource-from-pool (reserved-connection-pool) conn + (with-postgresql-transaction + conn + (lambda (conn) + (handle-derivation-events + conn + filtered-items)))))) (with-build-ids-for-status items build-ids '("succeeded") (lambda (ids) - (call-via-thread-pool-channel + (spawn-fiber-for-handler (lambda (conn) - (handle-removing-blocking-build-entries-for-successful-builds conn ids))) + (handle-removing-blocking-build-entries-for-successful-builds + conn ids))) (request-query-of-build-server-substitutes build-server-id ids))) @@ -244,7 +240,7 @@ build-ids '("scheduled") (lambda (ids) - (call-via-thread-pool-channel + (spawn-fiber-for-handler (lambda (conn) (handle-blocked-builds-entries-for-scheduled-builds conn ids))))) @@ -253,7 +249,7 @@ build-ids '("failed" "failed-dependency" "canceled") (lambda (ids) - (call-via-thread-pool-channel + (spawn-fiber-for-handler (lambda (conn) (handle-populating-blocked-builds-for-build-failures conn ids))))))) @@ -263,12 +259,10 @@ #:code 400) (let ((provided-token (assq-ref parsed-query-parameters 'token)) (permitted-tokens - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (compute-tokens-for-build-server conn - secret-key-base - build-server-id)))))) + (with-resource-from-pool (reserved-connection-pool) conn + (compute-tokens-for-build-server conn + secret-key-base + build-server-id)))) (if (member provided-token (map cdr permitted-tokens) string=?) @@ -317,10 +311,8 @@ (define (handle-signing-key-request id) (render-html #:sxml (view-signing-key - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-signing-key conn id))))))) + (with-resource-from-pool (connection-pool) conn + (select-signing-key conn id))))) (define (build-server-controller request method-and-path-components @@ -329,17 +321,17 @@ secret-key-base) (match method-and-path-components (('GET "build-servers") - (letpar& ((build-servers - (with-thread-postgresql-connection - select-build-servers))) + (let ((build-servers + (with-resource-from-pool (connection-pool) conn + select-build-servers))) (render-build-servers mime-types build-servers))) (('GET "build-server" build-server-id) - (letpar& ((build-server - (with-thread-postgresql-connection - (lambda (conn) - (select-build-server conn (string->number - build-server-id)))))) + (let ((build-server + (with-resource-from-pool (connection-pool) conn + (lambda (conn) + (select-build-server conn (string->number + build-server-id)))))) (if build-server (render-build-server mime-types build-server) -- cgit v1.2.3