Avoid long running store connections
As I think this can cause the guix-daemon WAL to grow excessively.
This commit is contained in:
parent
0ca9c3f64f
commit
b8d9ed19b2
1 changed files with 32 additions and 89 deletions
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue