Make reviewed-looks-good an issue status

4 files changed, 98 insertions, 48 deletions

diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index 1dc56b7..1f20e22 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -40,13 +40,15 @@
             issue-data
             start-refresh-patch-branches-data-thread))
 
+(define reviewed-looks-good-status 'reviewed-looks-good)
 (define good-status 'important-checks-passing)
 (define bad-status 'important-checks-failing)
 (define needs-looking-at-status 'needs-looking-at)
 (define unknown-status 'unknown)
 
 (define %overall-statuses
-  (list good-status
+  (list reviewed-looks-good-status
+        good-status
         unknown-status
         needs-looking-at-status
         bad-status))
@@ -60,7 +62,10 @@
   (list-ref %overall-statuses
             (apply max (map status-index statuses))))
 
-(define (issue-patches-overall-status derivation-changes-counts builds-missing? mumi-tags)
+(define (issue-patches-overall-status derivation-changes-counts
+                                      builds-missing?
+                                      mumi-tags
+                                      debbugs-usertags)
   (define %systems-to-consider
     '("x86_64-linux"
       ;; "i686-linux" disabled while resolving bordeaux build issues
@@ -107,14 +112,17 @@
                derivation-changes-counts))))))
 
   (define tags-status
-    (if (member "moreinfo" mumi-tags)
-        needs-looking-at-status
-        good-status))
+    (cond
+     ((member "reviewed-looks-good" debbugs-usertags) reviewed-looks-good-status)
+     ((member "moreinfo" mumi-tags)                   needs-looking-at-status)
+     (else good-status)))
 
-  (let ((overall-status
-         (worst-status (list builds-status
-                             tags-status))))
-    overall-status))
+  ;; If it's reviewed and looks good, let this override the other status
+  ;; information
+  (if (eq? tags-status reviewed-looks-good-status)
+      reviewed-looks-good-status
+      (worst-status (list builds-status
+                          tags-status))))
 
 (define (issue-data number)
   (let* ((base-and-target-refs
@@ -252,43 +260,45 @@
 
       (n-par-for-each
        5
-       (lambda (series)
-         (with-exception-handler
-             (lambda (exn)
-               (simple-format
-                (current-error-port)
-                "failed fetching derivation changes for issue ~A: ~A\n"
-                (car series)
-                exn)
+       (match-lambda
+         ((issue-number . series-data)
+          (with-exception-handler
+              (lambda (exn)
+                (simple-format
+                 (current-error-port)
+                 "failed updating status for issue ~A: ~A\n"
+                 issue-number
+                 exn)
 
-               #f)
-           (lambda ()
-             (let ((base-and-target-refs
-                    derivation-changes
-                    change-details
-                    builds-missing?
-                    comparison-details
-                    (with-sqlite-cache
-                     database
-                     'issue-data
-                     issue-data
-                     #:args
-                     (list (car series))
-                     #:version 2
-                     #:ttl (/ frequency 2))))
+                #f)
+            (lambda ()
+              (let ((base-and-target-refs
+                     derivation-changes
+                     change-details
+                     builds-missing?
+                     comparison-details
+                     (with-sqlite-cache
+                      database
+                      'issue-data
+                      issue-data
+                      #:args
+                      (list issue-number)
+                      #:version 2
+                      #:ttl (/ frequency 2))))
 
-               (with-sqlite-cache
-                database
-                'issue-patches-overall-status
-                (lambda (id)
-                  (issue-patches-overall-status
-                   (assq-ref derivation-changes 'counts)
-                   builds-missing?
-                   (assq-ref (assq-ref series 'mumi)
-                             'tags)))
-                #:args (list (car series))
-                #:ttl 0)))
-           #:unwind? #t))
+                (with-sqlite-cache
+                 database
+                 'issue-patches-overall-status
+                 (lambda _
+                   (issue-patches-overall-status
+                    (assq-ref derivation-changes 'counts)
+                    builds-missing?
+                    (assq-ref (assq-ref series-data 'mumi)
+                              'tags)
+                    (assq-ref series-data 'usertags)))
+                 #:args (list issue-number)
+                 #:ttl 0)))
+            #:unwind? #t)))
        series-to-refresh)))
 
   (call-with-new-thread
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index 77999ba..1211ae4 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -240,13 +240,18 @@
                                                'unknown)))
                     (if (eq? a-overall-status
                              b-overall-status)
-                        (if (eq? a-overall-status
-                                 'important-checks-passing)
+                        (if (member a-overall-status
+                                    '(important-checks-passing
+                                      reviewed-looks-good))
                             (< (first a)
                                (first b))
                             (> (first a)
                                (first b)))
                         (cond
+                         ((eq? a-overall-status 'reviewed-looks-good)
+                          #t)
+                         ((eq? b-overall-status 'reviewed-looks-good)
+                          #f)
                          ((eq? a-overall-status 'important-checks-passing)
                           #t)
                          ((eq? b-overall-status 'important-checks-passing)
@@ -291,7 +296,8 @@
                 #:ttl 3600))
               (fill
                (or (assq-ref
-                    '((important-checks-passing . "green")
+                    '((reviewed-looks-good      . "darkgreen")
+                      (important-checks-passing . "green")
                       (important-checks-failing . "red")
                       (needs-looking-at         . "orange")
                       (unknown                  . "grey"))
@@ -325,6 +331,27 @@
                (lambda (port)
                  (display
                   (cond
+                   ((eq? overall-status 'reviewed-looks-good)
+                    "
+<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
+  <clipPath id=\"clip\">
+    <rect width=\"140\" height=\"36\" rx=\"4\"/>
+  </clipPath>
+  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
+    <stop offset=\"0\" stop-color=\"#666\" />
+    <stop offset=\"1\" stop-color=\"#333\" />
+  </linearGradient>
+  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
+    <stop offset=\"0\" stop-color=\"green\" />
+    <stop offset=\"1\" stop-color=\"darkgreen\" />
+  </linearGradient>
+  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
+    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
+    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
+    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
+    <text x=\"90\" y=\"22\" fill=\"#fff\">Reviewed</text>
+  </g>
+</svg>")
                    ((eq? overall-status 'important-checks-passing)
                     "
 <svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
diff --git a/guix-qa-frontpage/view/patches.scm b/guix-qa-frontpage/view/patches.scm
index 8a7665c..65c693a 100644
--- a/guix-qa-frontpage/view/patches.scm
+++ b/guix-qa-frontpage/view/patches.scm
@@ -11,7 +11,7 @@
    `((main
       (p "The aim with this page is that the patches to look at should be towards the
 top.")
-      (p "For issues with the green status (important checks passing), the oldest ones
+      (p "For issues with the green status (reviewed or important checks passing), the oldest ones
 will appear first.")
       ,@(if (or (eq? #f systems-with-low-substitute-availability)
                 (null? systems-with-low-substitute-availability))
@@ -38,6 +38,10 @@ will appear first.")
                       (td
                        (@ (style "vertical-align: middle;"))
                        ,@(cond
+                          ((eq? status 'reviewed-looks-good)
+                           `((span (@ (aria-label "status: darkgreen")
+                                      (class "darkgreen-dot"))
+                                   (*ENTITY* "#10004"))))
                           ((eq? status 'important-checks-passing)
                            `((span (@ (aria-label "status: green")
                                       (class "green-dot"))
diff --git a/guix-qa-frontpage/view/util.scm b/guix-qa-frontpage/view/util.scm
index 3ebc0ab..0605100 100644
--- a/guix-qa-frontpage/view/util.scm
+++ b/guix-qa-frontpage/view/util.scm
@@ -136,6 +136,15 @@ header {
   }
 }
 
+.darkgreen-dot {
+  vertical-align: text-bottom;
+  height: 23px;
+  width: 23px;
+  background-color: #006400;
+  border-radius: 50%;
+  display: inline-block;
+}
+
 .green-dot {
   vertical-align: text-bottom;
   height: 23px;