01/05: Further change job store connection handling

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit 993887fe0c5fcdb17c0583df50b868201761b85c
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Thu Apr 25 22:01:22 2024 +0100

    Further change job store connection handling
    
    The guix-dameon WAL is still growing excessively, so avoid doing anything 
with
    the long running store connection except registering temporary roots.
---
 guix-data-service/jobs/load-new-guix-revision.scm | 60 +++++++++++------
 tests/jobs-load-new-guix-revision.scm             | 82 ++++++++++++++---------
 2 files changed, 89 insertions(+), 53 deletions(-)

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm 
b/guix-data-service/jobs/load-new-guix-revision.scm
index 9579977..38ff754 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -1400,7 +1400,8 @@
 
     inf))
 
-(define* (extract-information-from conn store guix-revision-id commit
+(define* (extract-information-from conn long-running-store-connection
+                                   guix-revision-id commit
                                    guix-source store-path
                                    #:key skip-system-tests?
                                    parallelism)
@@ -1411,7 +1412,9 @@
     ;; inferior Guix works, even if it's build using a different
     ;; glibc version
     (string-append
-     (glibc-locales-for-guix-store-path store store-path)
+     (with-store-connection
+      (lambda (store)
+        (glibc-locales-for-guix-store-path store store-path)))
      "/lib/locale"
      ":" (getenv "GUIX_LOCPATH")))
 
@@ -1439,7 +1442,7 @@
       (spawn-fiber
        (lambda ()
          (let loop ((filename (get-message channel)))
-           (add-temp-root store filename)
+           (add-temp-root long-running-store-connection filename)
            (loop (get-message channel)))))
 
       (lambda (filename)
@@ -1647,7 +1650,7 @@
 
 (prevent-inlining-for-tests load-channel-instances)
 
-(define* (load-new-guix-revision conn store git-repository-id commit
+(define* (load-new-guix-revision conn git-repository-id commit
                                  #:key skip-system-tests? parallelism)
   (let* ((git-repository-fields
           (select-git-repository conn git-repository-id))
@@ -1659,10 +1662,12 @@
           (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
-           store
+           initial-store-connection
            channel-for-commit
            fetch-with-authentication?
            #:parallelism parallelism))
@@ -1675,16 +1680,24 @@
                                   channel-derivations-by-system)))
     (let ((store-item
            (channel-derivations-by-system->guix-store-item
-            store
+            initial-store-connection
             channel-derivations-by-system)))
       (if store-item
           (and
-           (extract-information-from conn store
-                                     guix-revision-id
-                                     commit guix-source store-item
-                                     #:skip-system-tests?
-                                     skip-system-tests?
-                                     #:parallelism parallelism)
+           (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?
+                                        #:parallelism parallelism)))
 
            (if (defined? 'channel-news-for-commit
                  (resolve-module '(guix channels)))
@@ -1709,6 +1722,7 @@
           (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)
@@ -2067,6 +2081,15 @@ SKIP LOCKED")
             (string=? priority "t"))))
    (exec-query conn query)))
 
+(define (open-store-connection)
+  (let ((store (open-connection)))
+    (ensure-non-blocking-store-connection store)
+    (set-build-options store #:fallback? #t)
+
+    store))
+
+(prevent-inlining-for-tests open-store-connection)
+
 (define (with-store-connection f)
   (with-store store
     (ensure-non-blocking-store-connection store)
@@ -2108,14 +2131,11 @@ SKIP LOCKED")
                  (lambda ()
                    (with-throw-handler #t
                      (lambda ()
-                       (with-store-connection
-                        (lambda (store)
-                          (load-new-guix-revision conn
-                                                  store
-                                                  git-repository-id
-                                                  commit
-                                                  #:skip-system-tests? #t
-                                                  #:parallelism parallelism))))
+                       (load-new-guix-revision conn
+                                               git-repository-id
+                                               commit
+                                               #:skip-system-tests? #t
+                                               #:parallelism parallelism))
                      (lambda (key . args)
                        (simple-format (current-error-port)
                                       "error: load-new-guix-revision: ~A ~A\n"
diff --git a/tests/jobs-load-new-guix-revision.scm 
b/tests/jobs-load-new-guix-revision.scm
index a2beb64..1a64ce3 100644
--- a/tests/jobs-load-new-guix-revision.scm
+++ b/tests/jobs-load-new-guix-revision.scm
@@ -37,50 +37,66 @@
 
       (mock
        ((guix-data-service jobs load-new-guix-revision)
-        channel->source-and-derivations-by-system
-        (lambda* (conn store channel fetch-with-authentication?
-                       #:key parallelism)
-          (cons
-           "/gnu/store/guix"
-           '(("x86_64-linux"
-              .
-              ((manifest-entry-item . "/gnu/store/foo.drv")
-               (profile . "/gnu/store/bar.drv")))))))
+        open-store-connection
+        (lambda ()
+          'fake-store-connection))
 
        (mock
         ((guix-data-service jobs load-new-guix-revision)
-         channel-derivations-by-system->guix-store-item
-         (lambda (store channel-derivations-by-system)
-           "/gnu/store/test"))
+         channel->source-and-derivations-by-system
+         (lambda* (conn store channel fetch-with-authentication?
+                        #:key parallelism)
+           (cons
+            "/gnu/store/guix"
+            '(("x86_64-linux"
+               .
+               ((manifest-entry-item . "/gnu/store/foo.drv")
+                (profile . "/gnu/store/bar.drv")))))))
 
         (mock
          ((guix-data-service jobs load-new-guix-revision)
-          extract-information-from
-          (lambda* (conn store guix-revision-id commit
-                         guix-source store-path
-                         #:key skip-system-tests?
-                         parallelism)
-            #t))
+          channel-derivations-by-system->guix-store-item
+          (lambda (store channel-derivations-by-system)
+            "/gnu/store/test"))
 
          (mock
-          ((guix-data-service model channel-instance)
-           insert-channel-instances
-           (lambda (conn guix-revision-id derivations-by-system)
+          ((guix-data-service jobs load-new-guix-revision)
+           extract-information-from
+           (lambda* (conn store guix-revision-id commit
+                          guix-source store-path
+                          #:key skip-system-tests?
+                          parallelism)
              #t))
 
           (mock
-           ((guix channels)
-            channel-news-for-commit
-            (lambda (channel commit)
-              '()))
-
-           (match (enqueue-load-new-guix-revision-job
-                   conn
-                   (git-repository-url->git-repository-id conn "test-url")
-                   "test-commit"
-                   "test-source")
-             ((id)
-              (process-load-new-guix-revision-job id))))))))))
+           ((guix-data-service model channel-instance)
+            insert-channel-instances
+            (lambda (conn guix-revision-id derivations-by-system)
+              #t))
+
+           (mock
+            ((guix channels)
+             channel-news-for-commit
+             (lambda (channel commit)
+               '()))
+
+            (mock
+             ((guix store)
+              add-temp-root
+              (lambda _ #f))
+
+             (mock
+              ((guix store)
+               close-connection
+               (lambda _ #f))
+
+              (match (enqueue-load-new-guix-revision-job
+                      conn
+                      (git-repository-url->git-repository-id conn "test-url")
+                      "test-commit"
+                      "test-source")
+                ((id)
+                 (process-load-new-guix-revision-job id)))))))))))))
 
    (exec-query conn "TRUNCATE guix_revisions CASCADE")
    (exec-query conn "TRUNCATE load_new_guix_revision_jobs CASCADE")