[no subject]

[Ludovic Courtès]

branch: master
commit 8536509804e098e569950f2b84968dad33d84ef7
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Oct 18 12:24:31 2023 +0200

    database: Add ‘db-get-first-build-failure’.
    
    * src/cuirass/database.scm (db-get-previous-successful-build)
    (db-get-first-build-failure): New procedures.
    * tests/database.scm ("db-get-first-build-failure"): New test.
---
 src/cuirass/database.scm | 29 +++++++++++++++++++++++++++++
 tests/database.scm       | 31 +++++++++++++++++++++++++++++++
 2 files changed, 60 insertions(+)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index df5f95b..14e1427 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -162,6 +162,8 @@
             db-get-build-percentages
             db-get-jobs
             db-get-jobs-history
+            db-get-previous-successful-build
+            db-get-first-build-failure
             db-add-build-dependencies
             db-get-build-dependencies
             db-update-resumable-builds!
@@ -1024,6 +1026,33 @@ AND Jobs.name = ANY(:names);")
                                (jobs . ,(list job)))
                              evaluations))))))))))
 
+(define (db-get-previous-successful-build build)
+  "Return the previous successful build of the same job as BUILD, or #f if
+none was found."
+  (match (db-get-builds
+          `((jobset . ,(build-specification-name build))
+            (job . ,(build-job-name build))
+            (oldevaluation . ,(build-evaluation-id build))
+            (status . succeeded)
+            (order . evaluation)
+            (nr . 1)))
+    ((success) success)
+    (() #f)))
+
+(define (db-get-first-build-failure build)
+  "Return the first build failure of the same job as BUILD, or #f if BUILD is
+not actually failing or if that builds of that job have always failed."
+  (and (= (build-status failed)
+          (build-current-status build))
+       (match (db-get-builds
+               `((jobset . ,(build-specification-name build))
+                 (job . ,(build-job-name build))
+                 (oldevaluation . ,(build-evaluation-id build))
+                 (weather . new)
+                 (nr . 1)))
+         ((first) first)
+         (() #f))))
+
 (define (db-add-build-dependencies source-derivation target-derivations)
   "Insert into the BuildDependencies table the TARGET-DERIVATIONS as
 dependencies of the given SOURCE-DERIVATION."
diff --git a/tests/database.scm b/tests/database.scm
index 5f988ed..7a189bd 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -37,6 +37,7 @@
              (ice-9 control)
              (ice-9 exceptions)
              (ice-9 match)
+             (srfi srfi-1)
              (srfi srfi-19)
              (srfi srfi-64))
 
@@ -960,6 +961,36 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 
0, 0);")
              (eq? (status drv-6) (build-status failed-dependency))
              (eq? (status drv-7) (build-status failed-dependency))))))
 
+  (test-equal "db-get-first-build-failure"
+    '("/thing.drv2"                               ;last success
+      "/thing.drv3")                              ;first failure
+    (with-fibers
+     (let ((derivation "/thing.drv")
+           (job "thing-that-starts-failing"))
+       (for-each (lambda (status n)
+                   (let ((id (db-add-evaluation "guix"
+                                                (make-dummy-instances
+                                                 (number->string n)
+                                                 "fakesha2")))
+                         (drv (string-append derivation (number->string n))))
+                     (db-add-build (make-dummy-build drv id
+                                                     #:jobset "guix"
+                                                     #:job-name job))
+                     (db-update-build-status! drv status)))
+                 (list (build-status failed)      ;0
+                       (build-status succeeded)   ;1
+                       (build-status succeeded)   ;2
+                       (build-status failed)      ;3
+                       (build-status failed))     ;4
+                 (iota 5))
+       (let ((last (db-get-build (string-append derivation "4")))
+             (all  (db-get-builds `((job . ,job)
+                                    (order . evaluation)))))
+         (and (= (build-id last) (build-id (first all)))
+              (map build-derivation
+                   (list (db-get-previous-successful-build last)
+                         (db-get-first-build-failure last))))))))
+
   (test-assert "db-close"
     (begin
       (false-if-exception (delete-file tmp-mail))