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

Start trying to handle GC happening while processing revisions

Browse source
This commit is contained in:
Christopher Baines 2024-08-08 13:31:14 +01:00
parent 7869082816
commit 371d76456f
2 changed files with 70 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -22,6 +22,7 @@
#:use-module (srfi srfi-71) #:use-module (srfi srfi-71)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 threads) #:use-module (ice-9 threads)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
#:use-module (ice-9 hash-table) #:use-module (ice-9 hash-table)
#:use-module (ice-9 suspendable-ports) #:use-module (ice-9 suspendable-ports)
@ -101,6 +102,25 @@
(simple-format #t "debug: Finished ~A, took ~A seconds\n" (simple-format #t "debug: Finished ~A, took ~A seconds\n"
action time-taken))))) action time-taken)))))
(define-exception-type &missing-store-item-error &error
make-missing-store-item-error
missing-store-item-error?
(item missing-store-item-error-item))
(define (retry-on-missing-store-item thunk)
(with-exception-handler
(lambda (exn)
(if (missing-store-item-error? exn)
(begin
(simple-format (current-error-port)
"missing store item ~A, retrying ~A\n"
(missing-store-item-error-item exn)
thunk)
(retry-on-missing-store-item thunk))
(raise-exception exn)))
thunk
#:unwind? #t))
(define (inferior-guix-systems inf) (define (inferior-guix-systems inf)
;; The order shouldn't matter here, but bugs in Guix can lead to different ;; The order shouldn't matter here, but bugs in Guix can lead to different
;; results depending on the order, so sort the systems to try and provide ;; results depending on the order, so sort the systems to try and provide
@ -1063,6 +1083,10 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(lambda () (lambda ()
(open-bytevector-output-port)) (open-bytevector-output-port))
(lambda (port get-bytevector) (lambda (port get-bytevector)
(unless (file-exists? source-file)
(raise-exception
(make-missing-store-item-error
source-file)))
(write-file source-file port) (write-file source-file port)
(get-bytevector))))))) (get-bytevector)))))))
(letpar& (letpar&
@ -1164,7 +1188,13 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(lambda (chunk) (lambda (chunk)
(fibers-delay (fibers-delay
(lambda () (lambda ()
(map read-derivation-from-file chunk)))) (map (lambda (filename)
(if (file-exists? filename)
(read-derivation-from-file filename)
(raise-exception
(make-missing-store-item-error
filename))))
chunk))))
(chunk! missing-derivation-filenames 1000)))) (chunk! missing-derivation-filenames 1000))))
(for-each (for-each
@ -1547,8 +1577,10 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(lambda (store) (lambda (store)
(build-derivations store (list derivation-for-current-system))))) (build-derivations store (list derivation-for-current-system)))))
(store-item->guix-store-item (values
(derivation->output-path derivation-for-current-system))) (store-item->guix-store-item
(derivation->output-path derivation-for-current-system))
derivation-file-name-for-current-system))
#f))) #f)))
(prevent-inlining-for-tests channel-derivations-by-system->guix-store-item) (prevent-inlining-for-tests channel-derivations-by-system->guix-store-item)
@ -1693,6 +1725,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(define* (extract-information-from db-conn guix-revision-id commit (define* (extract-information-from db-conn guix-revision-id commit
guix-source store-item guix-source store-item
guix-derivation
utility-thread-channel utility-thread-channel
#:key skip-system-tests? #:key skip-system-tests?
extra-inferior-environment-variables extra-inferior-environment-variables
@ -1713,17 +1746,33 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(define inf-and-store-pool (define inf-and-store-pool
(make-resource-pool (make-resource-pool
(lambda () (lambda ()
(let* ((inferior-store (open-store-connection)) (let* ((inferior-store (open-store-connection)))
(inferior (start-inferior-for-data-extration (unless (valid-path? inferior-store store-item)
inferior-store (simple-format #t "warning: store item missing (~A)\n"
store-item store-item)
guix-locpath (unless (valid-path? inferior-store guix-derivation)
extra-inferior-environment-variables))) (simple-format #t "warning: attempting to substitute guix derivation (~A)\n"
(ensure-non-blocking-store-connection inferior-store) guix-derivation)
(make-inferior-non-blocking! inferior) (ensure-path inferior-store guix-derivation))
(simple-format #t "debug: started new inferior and store connection\n") (simple-format #t "warning: building (~A)\n"
guix-derivation)
(build-derivations inferior-store
(list (read-derivation-from-file
guix-derivation))))
;; Use this more to keep the store-path alive so long as there's a
;; inferior operating
(add-temp-root inferior-store store-item)
(cons inferior inferior-store))) (let ((inferior (start-inferior-for-data-extration
inferior-store
store-item
guix-locpath
extra-inferior-environment-variables)))
(ensure-non-blocking-store-connection inferior-store)
(make-inferior-non-blocking! inferior)
(simple-format #t "debug: started new inferior and store connection\n")
(cons inferior inferior-store))))
parallelism parallelism
#:min-size 0 #:min-size 0
#:idle-seconds 2 #:idle-seconds 2
@ -1933,7 +1982,9 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(par-map& (par-map&
(match-lambda (match-lambda
((system . target) ((system . target)
(process-system-and-target/fiberized system target))) (retry-on-missing-store-item
(lambda ()
(process-system-and-target/fiberized system target)))))
(with-resource-from-pool inf-and-store-pool res (with-resource-from-pool inf-and-store-pool res
(match res (match res
((inferior . inferior-store) ((inferior . inferior-store)
@ -1980,7 +2031,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(parallel-via-fibers (parallel-via-fibers
(fibers-force package-ids-promise) (fibers-force package-ids-promise)
(extract-and-store-package-derivations) (extract-and-store-package-derivations)
(extract-and-store-system-tests) (retry-on-missing-store-item extract-and-store-system-tests)
(extract-and-store-lint-checkers-and-warnings))) (extract-and-store-lint-checkers-and-warnings)))
#t) #t)
@ -2082,6 +2133,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
git-repository-id commit git-repository-id commit
channel-derivations-by-system))) channel-derivations-by-system)))
(let ((store-item (let ((store-item
guix-derivation
(channel-derivations-by-system->guix-store-item (channel-derivations-by-system->guix-store-item
channel-derivations-by-system))) channel-derivations-by-system)))
(if store-item (if store-item
@ -2089,6 +2141,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(extract-information-from conn (extract-information-from conn
guix-revision-id guix-revision-id
commit guix-source store-item commit guix-source store-item
guix-derivation
utility-thread-channel utility-thread-channel
#:skip-system-tests? #:skip-system-tests?
skip-system-tests? skip-system-tests?

3
tests/jobs-load-new-guix-revision.scm
View file

@ -58,7 +58,8 @@
((guix-data-service jobs load-new-guix-revision) ((guix-data-service jobs load-new-guix-revision)
channel-derivations-by-system->guix-store-item channel-derivations-by-system->guix-store-item
(lambda (channel-derivations-by-system) (lambda (channel-derivations-by-system)
"/gnu/store/test")) (values "/gnu/store/test"
"/gnu/store/test.drv")))
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((guix-data-service jobs load-new-guix-revision)