05/14: Make sure to keep roots for channel instance derivations

[Christopher Baines]

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

commit 0f7b31c605150eeca14c10d8c14913a1318e9506
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Jan 28 08:18:44 2024 +0000

    Make sure to keep roots for channel instance derivations
---
 guix-data-service/jobs/load-new-guix-revision.scm | 26 +++++++++++++++++++++--
 1 file changed, 24 insertions(+), 2 deletions(-)

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm 
b/guix-data-service/jobs/load-new-guix-revision.scm
index 464a5d7..141ebdd 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -1132,6 +1132,7 @@
                                            (list channel)
                                            #:authenticate?
                                            fetch-with-authentication?)))))))
+         (pool-store-connections '())
          (inferior-and-store-pool
           (make-resource-pool
            (lambda ()
@@ -1139,14 +1140,20 @@
                     (inferior (start-inferior inferior-store)))
                (ensure-non-blocking-store-connection inferior-store)
                (make-inferior-non-blocking! inferior)
+               (call-with-blocked-asyncs
+                (lambda ()
+                  (set! pool-store-connections
+                        (cons inferior-store pool-store-connections))))
                (cons inferior inferior-store)))
            parallelism
            #:min-size 0
            #:idle-seconds 10
            #:destructor (match-lambda
                           ((inferior . store)
-                           (close-inferior inferior)
-                           (close-connection store)))))
+                           ;; Just close the inferior here, close the store
+                           ;; connection later to keep the temporary roots
+                           ;; alive
+                           (close-inferior inferior)))))
          (systems
           (with-resource-from-pool inferior-and-store-pool res
             (match res
@@ -1173,6 +1180,21 @@
                        system)))))))
            systems)))
 
+    (for-each
+     (match-lambda
+       ((_ . 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)))