diff options
-rw-r--r-- | guix-qa-frontpage/issue.scm | 98 | ||||
-rw-r--r-- | guix-qa-frontpage/server.scm | 33 | ||||
-rw-r--r-- | guix-qa-frontpage/view/patches.scm | 6 | ||||
-rw-r--r-- | guix-qa-frontpage/view/util.scm | 9 |
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; |