Start trying to handle GC happening while processing revisions

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?