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

Check the WAL size more frequently when using inferiors

Browse source 
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.
This commit is contained in:
Christopher Baines 2024-08-16 11:56:17 +01:00
parent c335775ed4
commit 0592fba35b
2 changed files with 71 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -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)
(call-with-inferior
(lambda (inferior inferior-store)
(ensure-gds-inferior-packages-defined! inferior)
(inferior-package-derivations
inferior-store
inferior
system
target
start-index
count))))))
(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

1
guix-data-service/utils.scm
View file

@ -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