cbaines pushed a commit to branch master
in repository data-service.
commit 0592fba35b2ed7fda152280a06714d1b3a13bd79
Author: Christopher Baines <[email protected]>
AuthorDate: Fri Aug 16 11:56:17 2024 +0100
Check the WAL size more frequently when using inferiors
Since getting an inferior from the pool can take some time, it's not
sufficient to just check prior to attempting to fetch an inferior from the
pool. Instead set a timeout and check periodically.
---
guix-data-service/jobs/load-new-guix-revision.scm | 125 ++++++++++++----------
guix-data-service/utils.scm | 1 +
2 files changed, 72 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
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index 697d6df..71426f8 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -44,6 +44,7 @@
resource-pool-default-timeout
%resource-pool-timeout-handler
+ resource-pool-timeout-error?
make-resource-pool
destroy-resource-pool
call-with-resource-from-pool
