Improve overall statuses to take tags in to account

2 files changed, 125 insertions, 70 deletions

diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index ee3e210..14eb34b 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -20,53 +20,89 @@
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (guix-qa-frontpage derivation-changes)
-  #:export (issue-patches-overall-status))
+  #:export (%overall-statuses
+            status-index
 
-(define (issue-patches-overall-status derivation-changes)
-  (define good-status
-    'important-checks-passing)
+            issue-patches-overall-status))
 
-  (let* ((base-builds
-          (builds-by-system-excluding-cross-builds
-           derivation-changes "base"))
-         (target-builds
-          (builds-by-system-excluding-cross-builds
-           derivation-changes "target"))
+(define good-status 'important-checks-passing)
+(define bad-status 'important-checks-failing)
+(define needs-looking-at-status 'needs-looking-at)
+(define unknown-status 'unknown)
 
-         (all-systems
-          (delete-duplicates
-           (append (map car base-builds)
-                   (map car target-builds))))
+(define %overall-statuses
+  (list good-status
+        needs-looking-at-status
+        bad-status
+        unknown-status))
 
-         (categorised-base-builds-by-system
-          (categorise-builds all-systems base-builds))
-         (categorised-target-builds-by-system
-          (categorise-builds all-systems target-builds)))
+(define (status-index status)
+  (list-index (lambda (s)
+                (eq? s status))
+              %overall-statuses))
 
-    (if (null? target-builds)
-        good-status
-        (every
-         (match-lambda
-           ((system . categorised-target-builds)
-            (let ((categorised-base-builds
-                   (assoc-ref categorised-base-builds-by-system
-                              system)))
-              (define (count side status)
-                (length
-                 (assoc-ref
-                  (if (eq? side 'base)
-                      categorised-base-builds
-                      categorised-target-builds)
-                  status)))
+(define (issue-patches-overall-status derivation-changes mumi-tags)
+  (define builds-status
+    (let* ((base-builds
+            (builds-by-system-excluding-cross-builds
+             derivation-changes "base"))
+           (target-builds
+            (builds-by-system-excluding-cross-builds
+             derivation-changes "target"))
 
-              (if (and (>= (count 'target 'succeeding)
-                           (count 'base 'succeeding))
-                       (> (count 'target 'succeeding)
-                          0)
-                       (<= (count 'target 'failing)
-                           (count 'base 'failing))
-                       (<= (count 'target 'unknown)
-                           (count 'base 'unknown)))
-                  good-status
-                  #f))))
-         categorised-target-builds-by-system))))
+           (all-systems
+            (delete-duplicates
+             (append (map car base-builds)
+                     (map car target-builds))))
+
+           (categorised-base-builds-by-system
+            (categorise-builds all-systems base-builds))
+           (categorised-target-builds-by-system
+            (categorise-builds all-systems target-builds)))
+
+      (if (null? target-builds)
+          good-status
+          (or
+           (every
+            (match-lambda
+              ((system . categorised-target-builds)
+               (let ((categorised-base-builds
+                      (assoc-ref categorised-base-builds-by-system
+                                 system)))
+                 (define (count side status)
+                   (length
+                    (assoc-ref
+                     (if (eq? side 'base)
+                         categorised-base-builds
+                         categorised-target-builds)
+                     status)))
+
+                 (if (and (>= (count 'target 'succeeding)
+                              (count 'base 'succeeding))
+                          (> (count 'target 'succeeding)
+                             0)
+                          (<= (count 'target 'failing)
+                              (count 'base 'failing))
+                          (<= (count 'target 'unknown)
+                              (count 'base 'unknown)))
+                     good-status
+                     #f))))
+            categorised-target-builds-by-system)
+           unknown-status))))
+
+  (define tags-status
+    (if (member "moreinfo" mumi-tags)
+        needs-looking-at-status
+        good-status))
+
+  (let ((lowest-status
+         (list-ref
+          %overall-statuses
+          (apply min
+                 (map (lambda (status)
+                        (list-index (lambda (x)
+                                      (eq? x status))
+                                    %overall-statuses))
+                      (list builds-status
+                            tags-status))))))
+    lowest-status))
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