branch master updated: Add build weather support.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository guix-cuirass.

The following commit(s) were added to refs/heads/master by this push:
     new d7282c0  Add build weather support.
d7282c0 is described below

commit d7282c05c0fffa88596d092fd68aea3597f0000b
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Mon Feb 1 14:27:24 2021 +0100

    Add build weather support.
    
    * src/cuirass/database.scm (build-weather): New macro.
    (build-status->weather): New procedure.
    (db-get-builds): Return the build weather using the new procedure.
    * src/cuirass/http.scm (build->hydra-build): Also return the weather.
    * src/cuirass/templates.scm (weather-class, weather-title): New procedures.
    (build-eval-table): Display the weather.
    * tests/database.scm ("db-get-build weather"): New tests.
    * tests/http.scm (build-query-result): Adapt it.
---
 src/cuirass/database.scm  | 81 +++++++++++++++++++++++++++++++----------------
 src/cuirass/http.scm      |  1 +
 src/cuirass/templates.scm | 30 ++++++++++++++++++
 tests/database.scm        | 26 +++++++++++++++
 tests/http.scm            |  1 +
 5 files changed, 111 insertions(+), 28 deletions(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index f89e634..d59c1b0 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -58,6 +58,7 @@
             db-set-evaluation-status
             db-set-evaluation-time
             build-status
+            build-weather
             db-add-output
             db-add-build
             db-add-build-product
@@ -930,6 +931,26 @@ ORDER BY Builds.id DESC;"))
                          (#:buildproducts . ,(db-get-build-products id)))
                        result))))))))
 
+(define-enumeration build-weather
+  (unknown          -1)
+  (new-success       0)
+  (new-failure       1)
+  (still-succeeding  2)
+  (still-failing     3))
+
+(define (build-status->weather status last-status)
+  (cond
+   ((or (< status 0) (not last-status))
+    (build-weather unknown))
+   ((and (= status 0) (> last-status 0))
+    (build-weather new-success))
+   ((and (> status 0) (= last-status 0))
+    (build-weather new-failure))
+   ((and (= status 0) (= last-status 0))
+    (build-weather still-succeeding))
+   ((and (> status 0) (> last-status 0))
+    (build-weather still-failing))))
+
 (define (db-get-builds filters)
   "Retrieve all builds in the database which are matched by given FILTERS.
 FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset |
@@ -1084,34 +1105,38 @@ ORDER BY ~a;"
                         products-id products-type products-file-size
                         products-checksum products-path)
             . rest)
-           (loop rest
-                 (cons `((#:derivation . ,derivation)
-                         (#:id . ,(string->number id))
-                         (#:timestamp . ,(string->number timestamp))
-                         (#:starttime . ,(string->number starttime))
-                         (#:stoptime . ,(string->number stoptime))
-                         (#:log . ,log)
-                         (#:status . ,(string->number status))
-                         (#:last-status . ,(and last-status
-                                                (string->number last-status)))
-                         (#:priority . ,(string->number priority))
-                         (#:max-silent . ,(string->number max-silent))
-                         (#:timeout . ,(string->number timeout))
-                         (#:job-name . ,job-name)
-                         (#:system . ,system)
-                         (#:worker . ,worker)
-                         (#:nix-name . ,nix-name)
-                         (#:eval-id . ,(string->number eval-id))
-                         (#:specification . ,specification)
-                         (#:outputs . ,(format-outputs outputs-name
-                                                       outputs-path))
-                         (#:buildproducts .
-                          ,(format-build-products products-id
-                                                  products-type
-                                                  products-file-size
-                                                  products-checksum
-                                                  products-path)))
-                       result))))))))
+           (let* ((status (string->number status))
+                  (last-status (and last-status
+                                    (string->number last-status)))
+                  (weather (build-status->weather status last-status)))
+             (loop rest
+                   (cons `((#:derivation . ,derivation)
+                           (#:id . ,(string->number id))
+                           (#:timestamp . ,(string->number timestamp))
+                           (#:starttime . ,(string->number starttime))
+                           (#:stoptime . ,(string->number stoptime))
+                           (#:log . ,log)
+                           (#:status . ,status)
+                           (#:last-status . ,last-status)
+                           (#:weather . ,weather)
+                           (#:priority . ,(string->number priority))
+                           (#:max-silent . ,(string->number max-silent))
+                           (#:timeout . ,(string->number timeout))
+                           (#:job-name . ,job-name)
+                           (#:system . ,system)
+                           (#:worker . ,worker)
+                           (#:nix-name . ,nix-name)
+                           (#:eval-id . ,(string->number eval-id))
+                           (#:specification . ,specification)
+                           (#:outputs . ,(format-outputs outputs-name
+                                                         outputs-path))
+                           (#:buildproducts .
+                            ,(format-build-products products-id
+                                                    products-type
+                                                    products-file-size
+                                                    products-checksum
+                                                    products-path)))
+                         result)))))))))
 
 (define (db-get-build derivation-or-id)
   "Retrieve a build in the database which corresponds to DERIVATION-OR-ID."
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index fab9888..e973926 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -105,6 +105,7 @@
     (#:system . ,(assq-ref build #:system))
     (#:nixname . ,(assq-ref build #:nix-name))
     (#:buildstatus . ,(assq-ref build #:status))
+    (#:weather . ,(assq-ref build #:weather))
     (#:busy . ,(bool->int (eqv? (build-status started)
                                 (assq-ref build #:status))))
     (#:priority . 0)
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 8ec63f4..84fde8a 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -34,6 +34,7 @@
   #:use-module ((guix utils) #:select (string-replace-substring
                                        version>?))
   #:use-module ((cuirass database) #:select (build-status
+                                             build-weather
                                              evaluation-status))
   #:use-module (cuirass remote)
   #:export (html-page
@@ -489,6 +490,27 @@ system whose names start with " (code "guile-") ":" (br)
                              "~e ~b ~Y ~H:~M")))
            (date->string date format)))))
 
+(define (weather-class status)
+  (cond
+   ((= (build-weather unknown) status)
+    "oi oi-media-record text-primary mt-1")
+   ((= (build-weather new-success) status)
+    "oi oi-arrow-thick-top text-success mt-1")
+   ((= (build-weather new-failure) status)
+    "oi oi-arrow-thick-bottom text-danger mt-1")
+   ((= (build-weather still-succeeding) status)
+    "oi oi-media-record text-success mt-1")
+   ((= (build-weather still-failing) status)
+    "oi oi-media-record text-danger mt-1")))
+
+(define (weather-title status)
+  (cond
+   ((= (build-weather unknown) status) "Unknown")
+   ((= (build-weather new-success) status) "New success")
+   ((= (build-weather new-failure) status) "New failure")
+   ((= (build-weather still-succeeding) status) "Still succeeding")
+   ((= (build-weather still-failing) status) "Still failing")))
+
 (define (build-eval-table eval-id builds build-min build-max status)
   "Return HTML for the BUILDS table evaluation with given STATUS.  BUILD-MIN
 and BUILD-MAX are global minimal and maximal (stoptime, rowid) pairs."
@@ -501,6 +523,7 @@ and BUILD-MAX are global minimal and maximal (stoptime, 
rowid) pairs."
        (th (@ (scope "col") (class "border-0")) "Completion time")
        (th (@ (scope "col") (class "border-0")) "Job")
        (th (@ (scope "col") (class "border-0")) "Name")
+       (th (@ (scope "col") (class "border-0")) "Weather")
        (th (@ (scope "col") (class "border-0")) "System")
        (th (@ (scope "col") (class "border-0")) "Log"))))
 
@@ -508,6 +531,9 @@ and BUILD-MAX are global minimal and maximal (stoptime, 
rowid) pairs."
     (define status
       (assq-ref build #:buildstatus))
 
+    (define weather
+      (assq-ref build #:weather))
+
     (define completed?
       (or (= (build-status succeeded) status)
           (= (build-status failed) status)))
@@ -526,6 +552,10 @@ and BUILD-MAX are global minimal and maximal (stoptime, 
rowid) pairs."
                "—"))
       (td ,(assq-ref build #:job))
       (td ,(assq-ref build #:nixname))
+      (td (span (@ (class ,(weather-class weather))
+                   (title ,(weather-title weather))
+                   (aria-hidden "true"))
+                ""))
       (td ,(assq-ref build #:system))
       (td (a (@ (href "/build/" ,(assq-ref build #:id) "/log/raw"))
                "raw"))))
diff --git a/tests/database.scm b/tests/database.scm
index 7fde88b..b87b450 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -464,6 +464,32 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 
0, 0);")
            (list (db-get-build "/old-build.drv")
                  (db-get-build "/new-build.drv")))))
 
+  (test-equal "db-get-builds weather"
+    (build-weather new-success)
+    (begin
+      (assq-ref (db-get-build "/new-build.drv") #:weather)))
+
+  (test-equal "db-get-builds weather"
+    (build-weather new-failure)
+    (begin
+      (db-update-build-status! "/old-build.drv" 0)
+      (db-update-build-status! "/new-build.drv" 1)
+      (assq-ref (db-get-build "/new-build.drv") #:weather)))
+
+  (test-equal "db-get-builds weather"
+    (build-weather still-succeeding)
+    (begin
+      (db-update-build-status! "/old-build.drv" 0)
+      (db-update-build-status! "/new-build.drv" 0)
+      (assq-ref (db-get-build "/new-build.drv") #:weather)))
+
+  (test-equal "db-get-builds weather"
+    (build-weather still-failing)
+    (begin
+      (db-update-build-status! "/old-build.drv" 1)
+      (db-update-build-status! "/new-build.drv" 1)
+      (assq-ref (db-get-build "/new-build.drv") #:weather)))
+
   (test-assert "db-close"
     (begin
       (exec-query (%db) (format #f "DROP OWNED BY CURRENT_USER;"))
diff --git a/tests/http.scm b/tests/http.scm
index 9c44b8e..b814c4e 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -65,6 +65,7 @@
     (#:system . "x86_64-linux")
     (#:nixname . "fake-1.0")
     (#:buildstatus . 0)
+    (#:weather . -1)
     (#:busy . 0)
     (#:priority . 0)
     (#:finished . 1)