Avoid long running store connections

As I think this can cause the guix-daemon WAL to grow excessively.

1 files changed, 32 insertions, 89 deletions

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 672577f..9f46c47 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -120,8 +120,7 @@
       inf)))
    string<?))
 
-(define (all-inferior-system-tests inf store guix-source guix-commit
-                                   add-temp-root/long-running-store)
+(define (all-inferior-system-tests inf store guix-source guix-commit)
   (define inf-systems
     (inferior-guix-systems inf))
 
@@ -190,14 +189,6 @@
       (let ((system-test-data
              (with-time-logging "getting system tests"
                (inferior-eval-with-store/non-blocking inf store extract))))
-
-        (for-each (lambda (derivation-file-names-by-system)
-                    (for-each (lambda (derivation-file-name)
-                                (add-temp-root/long-running-store
-                                 derivation-file-name))
-                              (map cdr derivation-file-names-by-system)))
-                  (map third system-test-data))
-
         system-test-data))
     (lambda (key . args)
       (display (backtrace) (current-error-port))
@@ -1039,7 +1030,7 @@
      (inferior-eval-with-store inferior store proc))))
 
 (define* (channel->source-and-derivation-file-names-by-system
-          conn store channel
+          conn channel
           fetch-with-authentication?
           #:key parallelism)
 
@@ -1117,16 +1108,16 @@
     (let ((inferior
            (if use-container?
                (open-inferior/container
-                store
-                (guix-store-path store)
+                inferior-store
+                (guix-store-path inferior-store)
                 #:extra-shared-directories
                 '("/gnu/store")
                 #:extra-environment-variables
                 (list (string-append
-                       "SSL_CERT_DIR=" (nss-certs-store-path store))))
+                       "SSL_CERT_DIR=" (nss-certs-store-path inferior-store))))
                (begin
                  (simple-format #t "debug: using open-inferior\n")
-                 (open-inferior (guix-store-path store)
+                 (open-inferior (guix-store-path inferior-store)
                                 #:error-port (current-error-port))))))
 
       ;; /etc is only missing if open-inferior/container has been used
@@ -1166,14 +1157,16 @@
            conn
            'latest-channel-instances
            (lambda ()
-             ;; TODO (guix serialization) uses dynamic-wind
-             (call-with-temporary-thread
-              (lambda ()
-                (first
-                 (latest-channel-instances store
-                                           (list channel)
-                                           #:authenticate?
-                                           fetch-with-authentication?)))))))
+             (with-store-connection
+              (lambda (store)
+                ;; TODO (guix serialization) uses dynamic-wind
+                (call-with-temporary-thread
+                 (lambda ()
+                   (first
+                    (latest-channel-instances store
+                                              (list channel)
+                                              #:authenticate?
+                                              fetch-with-authentication?)))))))))
          (pool-store-connections '())
          (inferior-and-store-pool
           (make-resource-pool
@@ -1193,10 +1186,8 @@
            #:idle-seconds 10
            #:destructor (match-lambda
                           ((inferior . store)
-                           ;; Just close the inferior here, close the store
-                           ;; connection later to keep the temporary roots
-                           ;; alive
-                           (close-inferior inferior)))))
+                           (close-inferior inferior)
+                           (close-connection store)))))
          (systems
           (with-resource-from-pool inferior-and-store-pool res
             (match res
@@ -1235,33 +1226,16 @@
                     #:unwind? #t)))))
            systems)))
 
-    (for-each
-     (match-lambda
-       ((_ . manifest-and-profile)
-        (when manifest-and-profile
-          (and=> (assq-ref manifest-and-profile 'manifest-entry-item)
-                 (lambda (drv)
-                   (add-temp-root store drv)))
-          (and=> (assq-ref manifest-and-profile 'profile)
-                 (lambda (drv)
-                   (add-temp-root store drv))))))
-     result)
-
-    ;; Now the roots have been added to the main store connection, close the
-    ;; pool ones
-    (for-each close-connection pool-store-connections)
-
     (cons
      (channel-instance-checkout channel-instance)
      result)))
 
-(define* (channel->source-and-derivations-by-system conn store channel
+(define* (channel->source-and-derivations-by-system conn channel
                                                     fetch-with-authentication?
                                                     #:key parallelism)
   (match (with-time-logging "computing the channel derivation"
            (channel->source-and-derivation-file-names-by-system
             conn
-            store
             channel
             fetch-with-authentication?
             #:parallelism parallelism))
@@ -1280,7 +1254,6 @@
 (prevent-inlining-for-tests channel->source-and-derivations-by-system)
 
 (define (channel-derivations-by-system->guix-store-item
-         store
          channel-derivations-by-system)
 
   (define (store-item->guix-store-item filename)
@@ -1297,7 +1270,9 @@
         (let ((derivation-for-current-system
                (read-derivation-from-file derivation-file-name-for-current-system)))
           (with-time-logging "building the channel derivation"
-            (build-derivations store (list derivation-for-current-system)))
+            (with-store-connection
+             (lambda (store)
+               (build-derivations store (list derivation-for-current-system)))))
 
           (store-item->guix-store-item
            (derivation->output-path derivation-for-current-system)))
@@ -1443,8 +1418,7 @@
 
        inf))))
 
-(define* (extract-information-from conn long-running-store-connection
-                                   guix-revision-id commit
+(define* (extract-information-from conn guix-revision-id commit
                                    guix-source store-path
                                    #:key skip-system-tests?
                                    extra-inferior-environment-variables
@@ -1488,18 +1462,6 @@
         (close-connection store)
         (close-inferior inferior)))))
 
-  (define add-temp-root/long-running-store
-    (let ((channel (make-channel)))
-
-      (spawn-fiber
-       (lambda ()
-         (let loop ((filename (get-message channel)))
-           (add-temp-root long-running-store-connection filename)
-           (loop (get-message channel)))))
-
-      (lambda (filename)
-        (put-message channel filename))))
-
   (simple-format #t "debug: extract-information-from: ~A\n" store-path)
 
   (letpar& ((inferior-lint-checkers-and-warnings-data
@@ -1551,11 +1513,6 @@
                                 system
                                 target)))
 
-                          (vector-for-each
-                           (lambda (_ drv)
-                             (and=> drv add-temp-root/long-running-store))
-                           drvs)
-
                           (cons (cons system target)
                                 drvs))))))))
               (with-resource-from-pool inf-and-store-pool res
@@ -1572,8 +1529,7 @@
                      ((inferior . inferior-store)
                       (with-time-logging "getting inferior system tests"
                         (all-inferior-system-tests inferior inferior-store
-                                                   guix-source commit
-                                                   add-temp-root/long-running-store)))))))
+                                                   guix-source commit)))))))
             (packages-data
              (with-resource-from-pool inf-and-store-pool res
                (match res
@@ -1723,12 +1679,9 @@
           (channel (name 'guix)
                    (url git-repository-url)
                    (commit commit)))
-         (initial-store-connection
-          (open-store-connection))
          (source-and-channel-derivations-by-system
           (channel->source-and-derivations-by-system
            conn
-           initial-store-connection
            channel-for-commit
            fetch-with-authentication?
            #:parallelism parallelism))
@@ -1741,26 +1694,17 @@
                                   channel-derivations-by-system)))
     (let ((store-item
            (channel-derivations-by-system->guix-store-item
-            initial-store-connection
             channel-derivations-by-system)))
       (if store-item
           (and
-           (with-store-connection
-            (lambda (store)
-              (add-temp-root store store-item)
-
-              ;; Close the initial connection now that the store-item has a
-              ;; root
-              (close-connection initial-store-connection)
-
-              (extract-information-from conn store
-                                        guix-revision-id
-                                        commit guix-source store-item
-                                        #:skip-system-tests?
-                                        skip-system-tests?
-                                        #:extra-inferior-environment-variables
-                                        extra-inferior-environment-variables
-                                        #:parallelism parallelism)))
+           (extract-information-from conn
+                                     guix-revision-id
+                                     commit guix-source store-item
+                                     #:skip-system-tests?
+                                     skip-system-tests?
+                                     #:extra-inferior-environment-variables
+                                     extra-inferior-environment-variables
+                                     #:parallelism parallelism)
 
            (if (defined? 'channel-news-for-commit
                  (resolve-module '(guix channels)))
@@ -1785,7 +1729,6 @@
           (begin
             (simple-format #t "Failed to generate store item for ~A\n"
                            commit)
-            (close-connection initial-store-connection)
             #f)))))
 
 (define (enqueue-load-new-guix-revision-job conn git-repository-id commit source)