diff options
| author | Christopher Baines <mail@cbaines.net> | 2022-10-05 12:24:35 +0100 |
|---|---|---|
| committer | Christopher Baines <mail@cbaines.net> | 2022-10-05 12:24:35 +0100 |
| commit | 81defc23af7e82f22c574b365bed3d0a7e380b8a (patch) | |
| tree | e67f7705eabf0293dcfb7952be597679f9087a62 /guix-qa-frontpage/server.scm | |
| parent | 5710fd1cdad49c787ed5ab820f19360599ac0749 (diff) | |
| download | qa-frontpage-81defc23af7e82f22c574b365bed3d0a7e380b8a.tar qa-frontpage-81defc23af7e82f22c574b365bed3d0a7e380b8a.tar.gz | |
Improve overall statuses to take tags in to account
Diffstat (limited to 'guix-qa-frontpage/server.scm')
| -rw-r--r-- | guix-qa-frontpage/server.scm | 71 |
1 files changed, 45 insertions, 26 deletions
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 4baddad..4bf3184 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -142,18 +142,24 @@ (sort latest-series-with-overall-statuses (lambda (a b) ; a less than b - (if (eq? (assq-ref a 'overall-status) - 'important-checks-passing) - (if (eq? (assq-ref b 'overall-status) - 'important-checks-passing) - (< (first a) - (first b)) - #t) - (if (eq? (assq-ref b 'overall-status) - 'important-checks-passing) - #f - (> (first a) - (first b)))))))) + (let* ((a-overall-status (or (assq-ref a 'overall-status) + 'unknown)) + (b-overall-status (or (assq-ref b 'overall-status) + 'unknown)) + + (a-overall-status-index (status-index a-overall-status)) + (b-overall-status-index (status-index b-overall-status))) + + (if (eq? a-overall-status-index + b-overall-status-index) + (if (eq? a-overall-status + 'important-checks-passing) + (< (first a) + (first b)) + (> (first a) + (first b))) + (< a-overall-status-index + b-overall-status-index))))))) (render-html #:sxml (patches-view (if (> (length sorted-latest-series) @@ -172,21 +178,25 @@ #:args (list number) #:ttl 3600)) (fill - (match overall-status - ('important-checks-passing "green") - (#f "grey")))) + (or (assq-ref + '((important-checks-passing . "green") + (important-checks-failing . "red") + (needs-looking-at . "orange") + (unknown . "grey")) + overall-status) + "grey"))) - (list (build-response - #:code 200 - #:headers '((content-type . (image/svg+xml)))) - (lambda (port) - (simple-format - port - " + (list (build-response + #:code 200 + #:headers '((content-type . (image/svg+xml)))) + (lambda (port) + (simple-format + port + " <svg viewBox=\"0 0 100 100\" xmlns=\"http://www.w3.org/2000/svg\"> <circle cx=\"50\" cy=\"50\" r=\"50\" style=\"fill: ~A;\" /> </svg>" - fill))))) + fill))))) (('GET "issue" number) (let ((series (assq-ref (with-sqlite-cache database @@ -336,14 +346,23 @@ port. Also, the port used can be changed by passing the --port option.\n" 'derivation-changes patch-series-derivation-changes #:args (list url) - #:ttl (* 60 20)))))) + #:ttl (* 60 20))))) + (mumi-tags + (with-sqlite-cache + database + 'mumi-issue-tags + mumi-issue-tags + #:args (list (car series)) + #:ttl 60))) + (and derivation-changes + mumi-tags (with-sqlite-cache database 'issue-patches-overall-status (lambda (id) - (issue-patches-overall-status - derivation-changes)) + (issue-patches-overall-status derivation-changes + mumi-tags)) #:args (list (car series)) #:ttl 0))))) latest-series |