From 57410b6cc27b4474360b0a397604a4eb8d29f28a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 8 Feb 2018 14:01:42 +0100
Subject: base: Account for derivations built behind our back.

Previously any derivation not directly built by Cuirass would be
considered as failed because 'handle-build-event' wouldn't see any build
event.  Here we just make sure the build status recorded in the database
corresponds to reality.

* src/cuirass/base.scm (update-build-statuses!): New procedure.
(spawn-builds): Call it after 'build-derivations&'.
---
 src/cuirass/base.scm | 39 +++++++++++++++++++++++++++++++--------
 1 file changed, 31 insertions(+), 8 deletions(-)

(limited to 'src')

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 9a2024b..ec0a016 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -329,6 +329,19 @@ Essentially this procedure inverts the inversion-of-control that
 
   (sort jobs job<?))
 
+(define (update-build-statuses! store db lst)
+  "Update the build status of the derivations listed in LST, which have just
+been passed to 'build-derivations' (meaning that we can assume that, if their
+outputs are invalid, that they failed to build.)"
+  (define (update! drv)
+    (match (derivation-path->output-paths drv)
+      (((_ . outputs) ...)
+       (if (any (cut valid-path? store <>) outputs)
+           (db-update-build-status! db drv (build-status succeeded))
+           (db-update-build-status! db drv (build-status failed))))))
+
+  (for-each update! lst))
+
 (define* (spawn-builds store db jobs
                        #:key (max-batch-size 200))
   "Build the derivations associated with JOBS, a list of job alists, updating
@@ -362,10 +375,14 @@ MAX-BATCH-SIZE items."
              (count total))
     (if (zero? count)
         (log-message "done with ~a derivations" total)
-        (let-values (((batch rest)
-                      (if (> total max-batch-size)
-                          (split-at jobs max-batch-size)
-                          (values jobs '()))))
+        (let*-values (((batch rest)
+                       (if (> total max-batch-size)
+                           (split-at jobs max-batch-size)
+                           (values jobs '())))
+                      ((drv)
+                       (map (lambda (job)
+                              (assq-ref job #:derivation))
+                            batch)))
           (guard (c ((nix-protocol-error? c)
                      (log-message "batch of builds (partially) failed:\
 ~a (status: ~a)"
@@ -374,16 +391,22 @@ MAX-BATCH-SIZE items."
             (log-message "building batch of ~a jobs (~a/~a)"
                          max-batch-size (- total count) total)
             (let-values (((port finish)
-                          (build-derivations& store
-                                              (map (lambda (job)
-                                                     (assq-ref job #:derivation))
-                                                   batch))))
+                          (build-derivations& store drv)))
               (process-build-log port
                                  (lambda (event state)
                                    (handle-build-event db event))
                                  #t)
               (close-port port)
               (finish)))
+
+          ;; Most of the time 'handle-build-event' will update the build
+          ;; status of derivations.  However, it could be that some
+          ;; derivations were built "behind our back", in which case
+          ;; 'build-derivations' doesn't actually do anything and
+          ;; 'handle-build-event' doesn't see any event.  Because of that,
+          ;; adjust DB here.
+          (update-build-statuses! store db drv)
+
           (loop rest (max (- total max-batch-size) 0))))))
 
 (define* (handle-build-event db event)
-- 
cgit v1.2.3