Change how agents handle store connections

Keep a connection open for longer, to allow for doing things like registering
gc roots.

1 files changed, 58 insertions, 57 deletions

diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index a2c55ef..c8a640a 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -54,48 +54,50 @@
           (derivation-name (assoc-ref build "derivation-name")))
       (simple-format #t "~A: setting up to build: ~A\n"
                      build-id derivation-name)
-      (let ((pre-build-status (pre-build-process
-                               derivation-substitute-urls
-                               non-derivation-substitute-urls
-                               derivation-name)))
-        (if (eq? (assq-ref pre-build-status 'result) 'success)
-            (begin
-              (simple-format #t "~A: setup successful, building: ~A\n"
-                             build-id derivation-name)
-              (report-build-start coordinator-uri uuid password
-                                  build-id)
-              (let* ((result   (perform-build derivation-name))
-                     ;; TODO Check this handles timezones right
-                     (end-time (localtime (current-time) "UTC")))
-                (retry-on-error
-                 (lambda ()
-                   (let ((log-file (derivation-log-file derivation-name)))
-                     (unless log-file
-                       (raise-exception
-                        (make-exception-with-message
-                         (simple-format #f "log file missing for ~A (~A)"
-                                        derivation-name build-id))))
+      (with-store store
+        (let ((pre-build-status (pre-build-process
+                                 store
+                                 derivation-substitute-urls
+                                 non-derivation-substitute-urls
+                                 derivation-name)))
+          (if (eq? (assq-ref pre-build-status 'result) 'success)
+              (begin
+                (simple-format #t "~A: setup successful, building: ~A\n"
+                               build-id derivation-name)
+                (report-build-start coordinator-uri uuid password
+                                    build-id)
+                (let* ((result (perform-build store derivation-name))
+                       ;; TODO Check this handles timezones right
+                       (end-time (localtime (current-time) "UTC")))
+                  (retry-on-error
+                   (lambda ()
+                     (let ((log-file (derivation-log-file derivation-name)))
+                       (unless log-file
+                         (raise-exception
+                          (make-exception-with-message
+                           (simple-format #f "log file missing for ~A (~A)"
+                                          derivation-name build-id))))
 
-                     (simple-format #t "~A: uploading log file ~A\n"
-                                    build-id log-file)
-                     (submit-log-file
-                      coordinator-uri uuid password
-                      build-id
-                      log-file)))
-                 #:times 6
-                 #:delay 30)
-                ((if result
-                     post-build-success
-                     post-build-failure)
-                 uuid coordinator-uri password
-                 build-id
-                 derivation-name
-                 end-time)))
-            (begin
-              (simple-format #t "~A: failure: ~A\n" build-id pre-build-status)
-              (report-setup-failure coordinator-uri uuid password
-                                    build-id
-                                    pre-build-status))))))
+                       (simple-format #t "~A: uploading log file ~A\n"
+                                      build-id log-file)
+                       (submit-log-file
+                        coordinator-uri uuid password
+                        build-id
+                        log-file)))
+                   #:times 6
+                   #:delay 30)
+                  ((if result
+                       post-build-success
+                       post-build-failure)
+                   uuid coordinator-uri password
+                   build-id
+                   derivation-name
+                   end-time)))
+              (begin
+                (simple-format #t "~A: failure: ~A\n" build-id pre-build-status)
+                (report-setup-failure coordinator-uri uuid password
+                                      build-id
+                                      pre-build-status)))))))
 
   (let-values (((process-job-with-queue count-jobs)
                 (create-work-queue max-parallel-builds
@@ -121,7 +123,8 @@
               jobs)))))
       (sleep 5))))
 
-(define (pre-build-process derivation-substitute-urls
+(define (pre-build-process store
+                           derivation-substitute-urls
                            non-derivation-substitute-urls
                            derivation-name)
   (define (find-missing-inputs inputs)
@@ -132,7 +135,7 @@
                       (valid-path? store path))
                     output-paths))
            (path-substitutes
-            (with-store store
+            (begin
               (set-build-options store #:substitute-urls
                                  non-derivation-substitute-urls)
 
@@ -167,12 +170,11 @@
                       (make-exception-with-message "timeout fetching inputs"))
                      (begin
                        ;; Download the substitutes
-                       (with-store store
-                         (set-build-options store
-                                            #:substitute-urls
-                                            non-derivation-substitute-urls)
+                       (set-build-options store
+                                          #:substitute-urls
+                                          non-derivation-substitute-urls)
 
-                         (build-things store missing-paths)))))
+                       (build-things store missing-paths))))
                  #:times 6
                  #:delay 60)
 
@@ -233,22 +235,21 @@
        '((result         . failure)
          (failure_reason . could_not_delete_outputs))))))
 
-(define (perform-build derivation-name)
-  (with-store store
-    (set-build-options store
-                       #:use-substitutes? #f)
+(define (perform-build store derivation-name)
+  (set-build-options store
+                     #:use-substitutes? #f)
 
-    (parameterize ((current-build-output-port (%make-void-port "w")))
-      (catch #t
-        (lambda ()
-          (build-things store (list derivation-name))
+  (parameterize ((current-build-output-port (%make-void-port "w")))
+    (catch #t
+      (lambda ()
+        (build-things store (list derivation-name))
         #t)
       (lambda (key . args)
         (simple-format (current-error-port)
                        "error: build: ~A ~A\n"
                        key args)
 
-        #f)))))
+        #f))))
 
 (define (post-build-failure uuid coordinator-uri password
                             build-id derivation end-time)