diff options
Diffstat (limited to 'guix-data-service')
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 121 |
1 files 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) |