cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Avoid long running store connections

Browse source 
As I think this can cause the guix-daemon WAL to grow excessively.
This commit is contained in:
Christopher Baines 2024-07-19 11:47:36 +01:00
parent 0ca9c3f64f
commit b8d9ed19b2
1 changed files with 32 additions and 89 deletions
Download patch file Download diff file Expand all files Collapse all files

121
guix-data-service/jobs/load-new-guix-revision.scm
View file

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