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

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

@ -22,6 +22,7 @@
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 suspendable-ports)
@ -101,6 +102,25 @@
(simple-format #t "debug: Finished ~A, took ~A seconds\n"
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)
;; 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
@ -1063,6 +1083,10 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(lambda ()
(open-bytevector-output-port))
(lambda (port get-bytevector)
(unless (file-exists? source-file)
(raise-exception
(make-missing-store-item-error
source-file)))
(write-file source-file port)
(get-bytevector)))))))
(letpar&
@ -1164,7 +1188,13 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(lambda (chunk)
(fibers-delay
(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))))
(for-each
@ -1547,8 +1577,10 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(lambda (store)
(build-derivations store (list derivation-for-current-system)))))
(values
(store-item->guix-store-item
(derivation->output-path derivation-for-current-system)))
(derivation->output-path derivation-for-current-system))
derivation-file-name-for-current-system))
#f)))
(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
guix-source store-item
guix-derivation
utility-thread-channel
#:key skip-system-tests?
extra-inferior-environment-variables
@ -1713,8 +1746,24 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(define inf-and-store-pool
(make-resource-pool
(lambda ()
(let* ((inferior-store (open-store-connection))
(inferior (start-inferior-for-data-extration
(let* ((inferior-store (open-store-connection)))
(unless (valid-path? inferior-store store-item)
(simple-format #t "warning: store item missing (~A)\n"
store-item)
(unless (valid-path? inferior-store guix-derivation)
(simple-format #t "warning: attempting to substitute guix derivation (~A)\n"
guix-derivation)
(ensure-path inferior-store guix-derivation))
(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)
(let ((inferior (start-inferior-for-data-extration
inferior-store
store-item
guix-locpath
@ -1723,7 +1772,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(make-inferior-non-blocking! inferior)
(simple-format #t "debug: started new inferior and store connection\n")
(cons inferior inferior-store)))
(cons inferior inferior-store))))
parallelism
#:min-size 0
#:idle-seconds 2
@ -1933,7 +1982,9 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(par-map&
(match-lambda
((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
(match res
((inferior . inferior-store)
@ -1980,7 +2031,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(parallel-via-fibers
(fibers-force package-ids-promise)
(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)))
#t)
@ -2082,6 +2133,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
git-repository-id commit
channel-derivations-by-system)))
(let ((store-item
guix-derivation
(channel-derivations-by-system->guix-store-item
channel-derivations-by-system)))
(if store-item
@ -2089,6 +2141,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(extract-information-from conn
guix-revision-id
commit guix-source store-item
guix-derivation
utility-thread-channel
#: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)
channel-derivations-by-system->guix-store-item
(lambda (channel-derivations-by-system)
"/gnu/store/test"))
(values "/gnu/store/test"
"/gnu/store/test.drv")))
(mock
((guix-data-service jobs load-new-guix-revision)