diff options
Diffstat (limited to 'guix-data-service')
-rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 85 |
1 files changed, 69 insertions, 16 deletions
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index a8e056d..2d6af34 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -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))))) - (store-item->guix-store-item - (derivation->output-path derivation-for-current-system))) + (values + (store-item->guix-store-item + (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,17 +1746,33 @@ 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 - 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))) + (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 + 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 #: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? |