Try to address the issue of missing derivation outputs

2 files changed, 80 insertions, 40 deletions

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 4ba7d5e..1d740a7 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -135,7 +135,24 @@
                #:on-exception on-exception))
             (raise-exception exn)))
     thunk
-    #:unwind? #t))
+    #:unwind? #t
+    #:unwind-for-type &missing-store-item-error))
+
+(define* (retry-on-missing-derivation-output thunk #:key on-exception)
+  (with-exception-handler
+      (lambda (exn)
+        (simple-format (current-error-port)
+                       "missing derivation output ~A ~A, retrying ~A\n"
+                       (missing-derivation-output-error-name exn)
+                       (missing-derivation-output-error-path exn)
+                       thunk)
+        (when on-exception (on-exception))
+        (retry-on-missing-store-item
+         thunk
+         #:on-exception on-exception))
+    thunk
+    #:unwind? #t
+    #:unwind-for-type &missing-derivation-output-error))
 
 (define (inferior-guix-systems inf)
   ;; The order shouldn't matter here, but bugs in Guix can lead to different
@@ -1182,6 +1199,32 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
                 (values derivations
                         derivation-ids)))))))
 
+  (define (insert-input-derivations derivations)
+    (with-time-logging
+        (string-append
+         "insert-missing-derivations: ensure-input-derivations-exist ("
+         log-tag ")")
+      (let ((input-derivations
+             (vector-fold
+              (lambda (_ result drv)
+                (append! (map derivation-input-derivation
+                              (derivation-inputs drv))
+                         result))
+              '()
+              derivations)))
+        (unless (null? input-derivations)
+          ;; Ensure all the input derivations exist
+          (chunk-for-each!
+           (lambda (chunk)
+             (insert-missing-derivations
+              postgresql-connection-pool
+              call-with-utility-thread
+              derivation-ids-hash-table
+              chunk
+              #:log-tag log-tag))
+           1000
+           input-derivations)))))
+
   (let ((derivations
          derivation-ids
          (insert-derivations)))
@@ -1204,44 +1247,29 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
                                          (derivation-outputs derivation)))
             derivation-ids
             derivations)))
-
-       (with-time-logging
-           (string-append
-            "insert-missing-derivations: ensure-input-derivations-exist ("
-            log-tag ")")
-         (let ((input-derivations
-                (vector-fold
-                 (lambda (_ result drv)
-                   (append! (map derivation-input-derivation
-                                 (derivation-inputs drv))
-                            result))
-                 '()
-                 derivations)))
-           (unless (null? input-derivations)
-             ;; Ensure all the input derivations exist
-             (chunk-for-each!
-              (lambda (chunk)
-                (insert-missing-derivations
-                 postgresql-connection-pool
-                 call-with-utility-thread
-                 derivation-ids-hash-table
-                 chunk
-                 #:log-tag log-tag))
-              1000
-              input-derivations)))))
+       (insert-input-derivations derivations))
 
       (simple-format
        (current-error-port)
        "debug: insert-missing-derivations: done parallel (~A)\n" log-tag)
-      (with-resource-from-pool postgresql-connection-pool conn
-        (with-time-logging
-            (simple-format
-             #f "insert-missing-derivations: inserting inputs for ~A derivations (~A)"
-             (vector-length derivations)
-             log-tag)
-          (insert-derivation-inputs conn
-                                    derivation-ids
-                                    derivations))))))
+      (retry-on-missing-derivation-output
+       (lambda ()
+         (with-resource-from-pool postgresql-connection-pool conn
+           (with-time-logging
+               (simple-format
+                #f "insert-missing-derivations: inserting inputs for ~A derivations (~A)"
+                (vector-length derivations)
+                log-tag)
+             (insert-derivation-inputs conn
+                                       derivation-ids
+                                       derivations))))
+       #:on-exception
+       (lambda ()
+         ;; If this has happened because derivations have been removed, it
+         ;; might be necessary to insert them in the database where they
+         ;; previously existed
+         (hash-clear! derivation-ids-hash-table)
+         (insert-input-derivations derivations))))))
 
 (define (fix-derivation file-name)
   (define (derivation-missing-inputs? conn drv-id)
diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm
index 215b46f..6ee7de1 100644
--- a/guix-data-service/model/derivation.scm
+++ b/guix-data-service/model/derivation.scm
@@ -21,6 +21,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 exceptions)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
   #:use-module (squee)
@@ -73,7 +74,12 @@
             update-derivation-inputs-statistics
             vacuum-derivation-inputs-table
             update-derivation-outputs-statistics
-            vacuum-derivation-outputs-table))
+            vacuum-derivation-outputs-table
+
+            &missing-derivation-output-error
+            missing-derivation-output-error?
+            missing-derivation-output-error-name
+            missing-derivation-output-error-path))
 
 (define (valid-targets conn)
   '("arm-linux-gnueabihf"
@@ -1128,12 +1134,19 @@ ON CONFLICT DO NOTHING"
                 (vector->list (json-string->scm env_vars)))
            system))))
 
+(define-exception-type &missing-derivation-output-error &error
+  make-derivation-output-error
+  missing-derivation-output-error?
+  (name missing-derivation-output-error-name)
+  (path missing-derivation-output-error-path))
+
 (define select-derivation-output-id
   (mlambda (conn name path)
     (match (exec-query
             conn
             "
-SELECT derivation_outputs.id FROM derivation_outputs
+SELECT derivation_outputs.id
+FROM derivation_outputs
 INNER JOIN derivations
   ON derivation_outputs.derivation_id = derivations.id
 WHERE derivations.file_name = $1
@@ -1143,9 +1156,8 @@ WHERE derivations.file_name = $1
       (((id))
        id)
       (()
-       (error (simple-format
-               #f "cannot find derivation-output with name ~A and path ~A"
-               name path))))))
+       (raise-exception
+        (make-derivation-output-error name path))))))
 
 (define (select-derivation-outputs-by-derivation-id conn id)
   (define query