diff options
Diffstat (limited to 'guix-data-service/jobs')
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 125 |
1 files changed, 71 insertions, 54 deletions
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index a7da8a8..0059f85 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1785,6 +1785,46 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (close-connection store) (close-inferior inferior))))) + (define (call-with-inferior proc) + (define (check-wal-size) + (let loop ((wal-bytes + (catch #t + (lambda () + (stat:size (stat "/var/guix/db/db.sqlite-wal"))) + (lambda _ 0)))) + (when (> wal-bytes (* 512 (expt 2 20))) + (simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n" + wal-bytes) + + (sleep 30) + (loop (catch #t + (lambda () + (stat:size (stat "/var/guix/db/db.sqlite-wal"))) + (lambda _ 0)))))) + + (let loop () + (check-wal-size) + (match + (with-exception-handler + (lambda (exn) + (if (resource-pool-timeout-error? exn) + 'retry + (raise-exception exn))) + (lambda () + (call-with-resource-from-pool inf-and-store-pool + (match-lambda + ((inferior . inferior-store) + (call-with-values + (lambda () + (proc inferior inferior-store)) + (lambda vals + (cons 'result vals))))) + #:timeout 20)) + #:unwind? #t) + ('retry (loop)) + (('result . vals) + (apply values vals))))) + (define postgresql-connection-pool (make-resource-pool (lambda () @@ -1824,22 +1864,6 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (with-resource-from-pool postgresql-connection-pool conn (insert-packages conn packages-data)))))) - (define (check-wal-size) - (let loop ((wal-bytes - (catch #t - (lambda () - (stat:size (stat "/var/guix/db/db.sqlite-wal"))) - (lambda _ 0)))) - (when (> wal-bytes (* 512 (expt 2 20))) - (simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n" - wal-bytes) - - (sleep 30) - (loop (catch #t - (lambda () - (stat:size (stat "/var/guix/db/db.sqlite-wal"))) - (lambda _ 0)))))) - (define (extract-and-store-lint-checkers-and-warnings) (define inferior-lint-checkers-data (with-resource-from-pool inf-and-store-pool res @@ -1869,13 +1893,11 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" ;; currently infeasible (not (eq? checker-name 'derivation))) (begin - (check-wal-size) - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (inferior-lint-warnings inferior - inferior-store - checker-name)))))))) + (call-with-inferior + (lambda (inferior inferior-store) + (inferior-lint-warnings inferior + inferior-store + checker-name))))))) inferior-lint-checkers-data))) (let ((package-ids (fibers-force package-ids-promise))) @@ -1900,12 +1922,11 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (define (extract-and-store-package-derivations) (define packages-count - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (ensure-gds-inferior-packages-defined! inferior) + (call-with-inferior + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) - (inferior-eval '(vector-length gds-inferior-packages) inferior))))) + (inferior-eval '(vector-length gds-inferior-packages) inferior)))) (define chunk-size 3000) @@ -1916,24 +1937,22 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (with-time-logging (simple-format #f "getting derivations for ~A" (cons system target)) (let loop ((start-index 0)) - (check-wal-size) (let* ((count (if (>= (+ start-index chunk-size) packages-count) (- packages-count start-index) chunk-size)) (chunk - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (ensure-gds-inferior-packages-defined! inferior) - - (inferior-package-derivations - inferior-store - inferior - system - target - start-index - count)))))) + (call-with-inferior + (lambda (inferior inferior-store) + (ensure-gds-inferior-packages-defined! inferior) + + (inferior-package-derivations + inferior-store + inferior + system + target + start-index + count))))) (vector-copy! derivations-vector start-index chunk) @@ -1989,10 +2008,9 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (retry-on-missing-store-item (lambda () (process-system-and-target/fiberized system target))))) - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (inferior-fetch-system-target-pairs inferior))))))) + (call-with-inferior + (lambda (inferior inferior-store) + (inferior-fetch-system-target-pairs inferior)))))) (define (extract-and-store-system-tests) (if skip-system-tests? @@ -2000,15 +2018,14 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" (simple-format #t "debug: skipping system tests\n") '()) (let ((data-with-derivation-file-names - (with-resource-from-pool inf-and-store-pool res - (match res - ((inferior . inferior-store) - (with-time-logging "getting inferior system tests" - (all-inferior-system-tests - inferior - inferior-store - guix-source - commit))))))) + (call-with-inferior + (lambda (inferior inferior-store) + (with-time-logging "getting inferior system tests" + (all-inferior-system-tests + inferior + inferior-store + guix-source + commit)))))) (when data-with-derivation-file-names (let ((data-with-derivation-ids (map (match-lambda |