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-connection store)
(close-inferior inferior))))) (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 (define postgresql-connection-pool
(make-resource-pool (make-resource-pool
(lambda () (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 (with-resource-from-pool postgresql-connection-pool conn
(insert-packages conn packages-data)))))) (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 (extract-and-store-lint-checkers-and-warnings)
(define inferior-lint-checkers-data (define inferior-lint-checkers-data
(with-resource-from-pool inf-and-store-pool res (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 ;; currently infeasible
(not (eq? checker-name 'derivation))) (not (eq? checker-name 'derivation)))
(begin (begin
(check-wal-size) (call-with-inferior
(with-resource-from-pool inf-and-store-pool res (lambda (inferior inferior-store)
(match res (inferior-lint-warnings inferior
((inferior . inferior-store) inferior-store
(inferior-lint-warnings inferior checker-name)))))))
inferior-store
checker-name))))))))
inferior-lint-checkers-data))) inferior-lint-checkers-data)))
(let ((package-ids (fibers-force package-ids-promise))) (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 (extract-and-store-package-derivations)
(define packages-count (define packages-count
(with-resource-from-pool inf-and-store-pool res (call-with-inferior
(match res (lambda (inferior inferior-store)
((inferior . inferior-store) (ensure-gds-inferior-packages-defined! inferior)
(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) (define chunk-size 3000)
@ -1916,24 +1937,22 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(with-time-logging (with-time-logging
(simple-format #f "getting derivations for ~A" (cons system target)) (simple-format #f "getting derivations for ~A" (cons system target))
(let loop ((start-index 0)) (let loop ((start-index 0))
(check-wal-size)
(let* ((count (let* ((count
(if (>= (+ start-index chunk-size) packages-count) (if (>= (+ start-index chunk-size) packages-count)
(- packages-count start-index) (- packages-count start-index)
chunk-size)) chunk-size))
(chunk (chunk
(with-resource-from-pool inf-and-store-pool res (call-with-inferior
(match res (lambda (inferior inferior-store)
((inferior . inferior-store) (ensure-gds-inferior-packages-defined! inferior)
(ensure-gds-inferior-packages-defined! inferior)
(inferior-package-derivations (inferior-package-derivations
inferior-store inferior-store
inferior inferior
system system
target target
start-index start-index
count)))))) count)))))
(vector-copy! derivations-vector (vector-copy! derivations-vector
start-index start-index
chunk) chunk)
@ -1989,10 +2008,9 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(retry-on-missing-store-item (retry-on-missing-store-item
(lambda () (lambda ()
(process-system-and-target/fiberized system target))))) (process-system-and-target/fiberized system target)))))
(with-resource-from-pool inf-and-store-pool res (call-with-inferior
(match res (lambda (inferior inferior-store)
((inferior . inferior-store) (inferior-fetch-system-target-pairs inferior))))))
(inferior-fetch-system-target-pairs inferior)))))))
(define (extract-and-store-system-tests) (define (extract-and-store-system-tests)
(if skip-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") (simple-format #t "debug: skipping system tests\n")
'()) '())
(let ((data-with-derivation-file-names (let ((data-with-derivation-file-names
(with-resource-from-pool inf-and-store-pool res (call-with-inferior
(match res (lambda (inferior inferior-store)
((inferior . inferior-store) (with-time-logging "getting inferior system tests"
(with-time-logging "getting inferior system tests" (all-inferior-system-tests
(all-inferior-system-tests inferior
inferior inferior-store
inferior-store guix-source
guix-source commit))))))
commit)))))))
(when data-with-derivation-file-names (when data-with-derivation-file-names
(let ((data-with-derivation-ids (let ((data-with-derivation-ids
(map (match-lambda (map (match-lambda

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

@ -44,6 +44,7 @@
resource-pool-default-timeout resource-pool-default-timeout
%resource-pool-timeout-handler %resource-pool-timeout-handler
resource-pool-timeout-error?
make-resource-pool make-resource-pool
destroy-resource-pool destroy-resource-pool
call-with-resource-from-pool call-with-resource-from-pool