aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--guix-qa-frontpage/issue.scm98
-rw-r--r--guix-qa-frontpage/server.scm33
-rw-r--r--guix-qa-frontpage/view/patches.scm6
-rw-r--r--guix-qa-frontpage/view/util.scm9
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;
generated by cgit v1.2.3 (git 2.49.0) at 2025-05-29 06:34:08 +0000