From d7282c05c0fffa88596d092fd68aea3597f0000b Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Mon, 1 Feb 2021 14:27:24 +0100
Subject: [PATCH] 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 f89e6340..d59c1b02 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 fab98886..e973926d 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 8ec63f4e..84fde8ad 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 7fde88bc..b87b4500 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 9c44b8ec..b814c4eb 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)
--
GitLab