From 21d81034da0861f70c94e33dae221eb3d210c5b1 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 29 Oct 2023 09:45:27 +0000
Subject: Make "large-number-of-builds" an issue status

Rather than these falling within the unknown status.
---
 guix-qa-frontpage/issue.scm         | 86 +++++++++++++++++++++----------------
 guix-qa-frontpage/manage-builds.scm | 10 +++--
 guix-qa-frontpage/server.scm        | 21 +++++++++
 guix-qa-frontpage/view/patches.scm  |  8 ++++
 guix-qa-frontpage/view/util.scm     | 10 +++++
 5 files changed, 96 insertions(+), 39 deletions(-)

(limited to 'guix-qa-frontpage')

diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index 45603b5..cc4eebd 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -46,6 +46,7 @@
 (define bad-status 'important-checks-failing)
 (define needs-looking-at-status 'needs-looking-at)
 (define unknown-status 'unknown)
+(define large-number-of-builds-status 'large-number-of-builds)
 (define failed-to-apply-patches-status 'failed-to-apply-patches)
 (define patches-missing-status 'patches-missing)
 (define guix-data-service-failed-status 'guix-data-service-failed)
@@ -53,6 +54,7 @@
 (define %overall-statuses
   (list reviewed-looks-good-status
         good-status
+        large-number-of-builds-status
         unknown-status
         needs-looking-at-status
         failed-to-apply-patches-status
@@ -99,43 +101,55 @@
     (define derivation-changes-counts
       (assq-ref derivation-changes 'counts))
 
-    (if builds-missing?
-        unknown-status
-        (if (null? derivation-changes-counts)
-            good-status
-            (worst-status
-             (map
-              (match-lambda
-                ((system . counts)
-                 (define (count side status)
-                   (assoc-ref (assoc-ref
-                               counts
-                               side)
-                              status))
+    (define builds-count
+      (and
+       derivation-changes
+       (length
+        (derivation-changes->builds-to-keep-and-submit derivation-changes
+                                                       0))))
+
+    (cond
+     ((and builds-count
+           (> builds-count %patches-builds-limit))
+      large-number-of-builds-status)
+     (builds-missing?
+      unknown-status)
+     ((null? derivation-changes-counts)
+      good-status)
+     (else
+      (worst-status
+       (map
+        (match-lambda
+          ((system . counts)
+           (define (count side status)
+             (assoc-ref (assoc-ref
+                         counts
+                         side)
+                        status))
 
-                 (let ((base-failure-count (count 'base 'failing))
-                       (target-failure-count (count 'target 'failing)))
-                   (if (and (<= target-failure-count
-                                base-failure-count)
-                            (= (count 'target 'unknown) 0))
-                       good-status
-                       (if (= (count 'target 'unknown) 0)
-                           (let ((unblocked-builds
-                                  (- (count 'base 'blocked)
-                                     (count 'target 'blocked)))
-                                 (new-failures
-                                  (- target-failure-count
-                                     base-failure-count)))
-                             (if (>= unblocked-builds
-                                     new-failures)
-                                 needs-looking-at-status
-                                 bad-status))
-                           unknown-status)))))
-              (filter
-               (lambda (builds-by-system)
-                 (member (car builds-by-system)
-                         %systems-to-consider))
-               derivation-changes-counts))))))
+           (let ((base-failure-count (count 'base 'failing))
+                 (target-failure-count (count 'target 'failing)))
+             (if (and (<= target-failure-count
+                          base-failure-count)
+                      (= (count 'target 'unknown) 0))
+                 good-status
+                 (if (= (count 'target 'unknown) 0)
+                     (let ((unblocked-builds
+                            (- (count 'base 'blocked)
+                               (count 'target 'blocked)))
+                           (new-failures
+                            (- target-failure-count
+                               base-failure-count)))
+                       (if (>= unblocked-builds
+                               new-failures)
+                           needs-looking-at-status
+                           bad-status))
+                     unknown-status)))))
+        (filter
+         (lambda (builds-by-system)
+           (member (car builds-by-system)
+                   %systems-to-consider))
+         derivation-changes-counts))))))
 
   (define tags-status
     (cond
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index e1d175f..0658daf 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -21,8 +21,10 @@
   #:use-module (guix-qa-frontpage manage-patch-branches)
   #:export (%systems-to-submit-builds-for
             %systems-with-expected-low-substitute-availability
+            %patches-builds-limit
 
             builds-missing-for-derivation-changes?
+            derivation-changes->builds-to-keep-and-submit
 
             submit-builds-for-issue
 
@@ -46,6 +48,10 @@
     "riscv64-linux"
     "powerpc64le-linux"))
 
+(define %patches-builds-limit
+  (* (length %systems-to-submit-builds-for)
+     300))
+
 (define* (submit-builds-for-issue
           database
           build-coordinator
@@ -182,9 +188,7 @@
           guix-data-service
           issue-number
           #:priority priority-for-change
-          #:build-limit
-          (* (length %systems-to-submit-builds-for)
-             300)))
+          #:build-limit %patches-builds-limit))
        first-n-series-issue-numbers)))
 
   (spawn-fiber
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index 5c7023e..9ae9bb1 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -436,6 +436,27 @@
     <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
     <text x=\"90\" y=\"22\" fill=\"#000\">Investigate</text>
   </g>
+</svg>")
+                   ((eq? overall-status 'large-number-of-builds)
+                    "
+<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=\"purple\" />
+    <stop offset=\"1\" stop-color=\"purple\" />
+  </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\">Investigate</text>
+  </g>
 </svg>")
                    ((eq? overall-status 'guix-data-service-failed)
                     "
diff --git a/guix-qa-frontpage/view/patches.scm b/guix-qa-frontpage/view/patches.scm
index f79e4a7..5eecbd0 100644
--- a/guix-qa-frontpage/view/patches.scm
+++ b/guix-qa-frontpage/view/patches.scm
@@ -31,6 +31,10 @@
       '(span (@ (aria-label "status: darkred")
                 (class "darkred-dot"))
              (*ENTITY* "#10005")))
+     ((eq? status 'large-number-of-builds)
+      '(span (@ (aria-label "status: purple")
+                (class "purple-dot"))
+             (*ENTITY* "#10005")))
      ((eq? status 'patches-missing)
       '(span (@ (aria-label "status: pink")
                 (class "pink-dot"))
@@ -136,6 +140,10 @@ will appear first.")
                            `((span (@ (aria-label "status: darkred")
                                       (class "darkred-dot"))
                                    (*ENTITY* "#10005"))))
+                          ((eq? status 'large-number-of-builds)
+                           `((span (@ (aria-label "status: purple")
+                                      (class "purple-dot"))
+                                   (*ENTITY* "#10005"))))
                           ((eq? status 'patches-missing)
                            `((span (@ (aria-label "status: pink")
                                       (class "pink-dot"))
diff --git a/guix-qa-frontpage/view/util.scm b/guix-qa-frontpage/view/util.scm
index 500560f..4479fc8 100644
--- a/guix-qa-frontpage/view/util.scm
+++ b/guix-qa-frontpage/view/util.scm
@@ -176,6 +176,16 @@ main > header {
   text-align: center;
 }
 
+.purple-dot {
+  vertical-align: text-bottom;
+  height: 23px;
+  width: 23px;
+  background-color: purple;
+  border-radius: 50%;
+  display: inline-block;
+  text-align: center;
+}
+
 .red-dot {
   vertical-align: text-bottom;
   height: 23px;
-- 
cgit v1.2.3