cbaines pushed a commit to branch master
in repository data-service.
commit b8d9ed19b209831e577a4ef5012204e1b31e61da
Author: Christopher Baines <[email protected]>
AuthorDate: Fri Jul 19 11:47:36 2024 +0100
Avoid long running store connections
As I think this can cause the guix-daemon WAL to grow excessively.
---
guix-data-service/jobs/load-new-guix-revision.scm | 121 ++++++----------------
1 file 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)
