Add delay logging to fetching builds

As this appears to be a bit too slow.

2 files changed, 45 insertions, 38 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index bb4e645..5bb922a 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -727,43 +727,50 @@
    (build-coordinator-metrics-registry build-coordinator)
    "coordinator_fetch_builds_duration_seconds"
    (lambda ()
-     (let ((update-made (datastore-update-agent-requested-systems
-                         (build-coordinator-datastore build-coordinator)
-                         agent
-                         systems)))
-       (when update-made
-         (trigger-build-allocation build-coordinator)))
-
-     (map (lambda (build)
-            (define submit-outputs?
-              (with-exception-handler
-                  (lambda (exn)
-                    (log-msg (build-coordinator-logger build-coordinator)
-                             'CRITICAL
-                             "build-submit-outputs hook raised exception: "
-                             exn))
-                (lambda ()
-                  (with-throw-handler #t
-                    (lambda ()
-                      (let ((hook-result (build-submit-outputs-hook build-coordinator
-                                                                    (assq-ref build 'uuid))))
-                        (if (boolean? hook-result)
-                            hook-result
-                            (begin
-                              (log-msg (build-coordinator-logger build-coordinator)
-                                       'CRITICAL
-                                       "build-submit-outputs hook returned non boolean: "
-                                       hook-result)
-                              #t))))
-                    (lambda (key . args)
-                      (backtrace))))
-                #:unwind? #t))
-
-            `(,@build
-              ;; TODO This needs reconsidering when things having been built in
-              ;; the past doesn't necessarily mean they're still available.
-              (submit_outputs . ,submit-outputs?)))
-          (get-builds)))))
+     (call-with-delay-logging
+      (lambda ()
+        (let ((update-made (datastore-update-agent-requested-systems
+                            (build-coordinator-datastore build-coordinator)
+                            agent
+                            systems)))
+          (when update-made
+            (trigger-build-allocation build-coordinator)))
+
+        (map (lambda (build)
+               (define submit-outputs?
+                 (with-exception-handler
+                     (lambda (exn)
+                       (log-msg (build-coordinator-logger build-coordinator)
+                                'CRITICAL
+                                "build-submit-outputs hook raised exception: "
+                                exn))
+                   (lambda ()
+                     (with-throw-handler #t
+                       (lambda ()
+                         (let ((hook-result
+                                (call-with-delay-logging
+                                 (lambda ()
+                                   (build-submit-outputs-hook
+                                    build-coordinator
+                                    (assq-ref build 'uuid))))))
+                           (if (boolean? hook-result)
+                               hook-result
+                               (begin
+                                 (log-msg
+                                  (build-coordinator-logger build-coordinator)
+                                  'CRITICAL
+                                  "build-submit-outputs hook returned non boolean: "
+                                  hook-result)
+                                 #t))))
+                       (lambda (key . args)
+                         (backtrace))))
+                   #:unwind? #t))
+
+               `(,@build
+                 ;; TODO This needs reconsidering when things having been built in
+                 ;; the past doesn't necessarily mean they're still available.
+                 (submit_outputs . ,submit-outputs?)))
+             (get-builds)))))))
 
 (define (agent-details datastore agent-id)
   (let ((agent (datastore-find-agent datastore agent-id))
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 061f05a..ff7b1d1 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -395,7 +395,7 @@ PRAGMA optimize;")))))
                   (sqlite-exec db "COMMIT TRANSACTION;")
                   (apply values vals))))))))
 
-  (call-with-worker-thread
+  (call-with-worker-thread/delay-logging
    (slot-ref datastore (if readonly?
                            'worker-reader-thread-channel
                            'worker-writer-thread-channel))