[no subject]

[Ludovic Courtès]

branch: main
commit 12d79854ee7685b356a72ca374f2a90b8efe5903
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri May 24 11:45:49 2024 +0200

    database: When registering a build, reschedule it if it was canceled.
    
    Fixes a bug whereby, if a build had been canceled as part of a previous
    evaluation, it would remained canceled even when a new evaluation
    registers a build for that derivation.
    
    * src/cuirass/database.scm (db-register-builds)[new-outputs?]: Remove.
    [previous-build]: New procedure.
    [register]: Use it.  Reschedule PREVIOUS if it was canceled.
    * tests/database.scm ("db-register-builds, canceled build is
    rescheduled"): New test.
---
 src/cuirass/database.scm | 24 ++++++++++++++++++------
 tests/database.scm       | 20 +++++++++++++++++++-
 2 files changed, 37 insertions(+), 7 deletions(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 12b763f..9263338 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -1129,18 +1129,30 @@ WHERE Builds.status = " (build-status scheduled)
 " GROUP BY Builds.id) AS deps WHERE deps.id = Builds.id")))
 
 (define (db-register-builds builds specification)
-  (define (new-outputs? outputs)
-    (find (negate (compose db-get-output output-item))
-          outputs))
+  (define (previous-build outputs)
+    ;; Return the previous build producing OUTPUTS or #f if there is none.
+    (and=> (any (compose db-get-output output-item)
+                outputs)
+           (lambda (output)
+             (db-get-build (output-derivation output)))))
 
   (define (build-priority priority)
     (let ((spec-priority (specification-priority specification)))
       (+ (* spec-priority 10) priority)))
 
   (define (register build)
-    (let ((result (and (new-outputs? (build-outputs build))
-                       (and=> (db-add-build build)
-                              (cut set-build-id build <>)))))
+    (let* ((previous (previous-build (build-outputs build)))
+           (result (and (not previous)
+                        (and=> (db-add-build build)
+                               (cut set-build-id build <>)))))
+
+      (when previous
+        ;; If PREVIOUS is marked as canceled, reschedule it.
+        (with-db-connection db
+          (exec-query/bind db "\
+UPDATE Builds SET status = " (build-status scheduled)
+" WHERE id = " (build-id previous)
+" AND status = " (build-status canceled) ";")))
 
       ;; Always register JOB inside the Jobs table.  If there are new outputs,
       ;; JOB will refer to the newly created build.  Otherwise, it will refer
diff --git a/tests/database.scm b/tests/database.scm
index ecd7ba9..ad4d14a 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -1,7 +1,7 @@
 ;;;; database.scm - tests for (cuirass database) module
 ;;;
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2018, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
 ;;;
@@ -996,6 +996,24 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 
0, 0);")
                    (list (db-get-previous-successful-build last)
                          (db-get-first-build-failure last))))))))
 
+  (test-equal "db-register-builds, canceled build is rescheduled"
+    (build-status scheduled)
+    (with-fibers
+     (let ((drv "/test-cancellation.drv"))
+       (db-register-builds
+        (list (make-dummy-build drv 2 #:job-name "test-cancellation"))
+        (db-get-specification "guix"))
+
+       (db-update-build-status! drv (build-status canceled))
+
+       ;; Registering the same derivation for a new evaluation should cause
+       ;; the build to switch from "canceled" to "submitted".
+       (db-register-builds
+        (list (make-dummy-build drv 4 #:job-name "test-cancellation"))
+        (db-get-specification "guix"))
+
+       (build-current-status (db-get-build drv)))))
+
   (test-assert "db-close"
     (begin
       (false-if-exception (delete-file tmp-mail))