diff options
| -rw-r--r-- | guix-qa-frontpage/server.scm | 10 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/issue.scm | 112 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/util.scm | 19 |
3 files changed, 120 insertions, 21 deletions
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 1747098..911b90a 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -19,6 +19,7 @@ (define-module (guix-qa-frontpage server) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (web http) #:use-module (web request) @@ -64,9 +65,10 @@ database 'latest-patchwork-series-by-issue latest-patchwork-series-by-issue - #:ttl 600) + #:ttl 1200) (string->number number))) (derivation-changes + change-details (with-sqlite-cache database 'derivation-changes @@ -75,8 +77,10 @@ (list (patch-series-derivation-changes-url series)) #:ttl 6000))) (render-html - #:sxml (issue-view series - derivation-changes)))) + #:sxml (issue-view number + series + derivation-changes + change-details)))) ((method path ...) (render-html #:sxml (general-not-found diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm index e3e380f..ad574e6 100644 --- a/guix-qa-frontpage/view/issue.scm +++ b/guix-qa-frontpage/view/issue.scm @@ -4,39 +4,117 @@ #:use-module (guix-qa-frontpage view util) #:export (issue-view)) -(define (issue-view series derivation-changes) - (define builds-by-system-excluding-cross-builds +(define (issue-view issue-number series derivation-changes + change-details) + (define (builds-by-system-excluding-cross-builds side) (fold (lambda (package result) (fold (lambda (change result) (if (string=? (assoc-ref change "target") "") (let ((system (assoc-ref change "system"))) - `((,system . ,(+ 1 - (or (assoc-ref result system) - 0))) + `((,system . ,(append + (vector->list (assoc-ref change "builds")) + (or (assoc-ref result system) + '()))) ,@(alist-delete system result))) result)) result (vector->list - (assoc-ref package "target")))) + (assoc-ref package side)))) '() derivation-changes)) + (define base-builds + (builds-by-system-excluding-cross-builds "base")) + + (define target-builds + (builds-by-system-excluding-cross-builds "target")) + + (define comparison-link + (let ((revisions + (assoc-ref change-details "revisions"))) + (simple-format #f "https://data.qa.guix.gnu.org/compare?base_commit=~A&target_commit=~A" + (assoc-ref (assoc-ref revisions "base") + "commit") + (assoc-ref (assoc-ref revisions "target") + "commit")))) + + (define (package-derivations-comparison-link system) + (let ((revisions + (assoc-ref change-details "revisions"))) + (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A" + (assoc-ref (assoc-ref revisions "base") + "commit") + (assoc-ref (assoc-ref revisions "target") + "commit") + system))) + + (define (count-builds-by-status builds status) + (fold + (lambda (build result) + (+ result + (if (string=? status + (assoc-ref build "status")) + 1 + 0))) + 0 + builds)) + (layout - #:description "Guix Quality Assurance" + #:title (simple-format #f "Issue ~A" issue-number) #:body `((main + (div + (a (@ (href ,(simple-format #f "https://issues.guix.gnu.org/~A" + issue-number))) + "View issue on issues.guix.gnu.org")) - (table - (tbody - ,@(map - (match-lambda - ((system . build-count) - `(tr - (td ,system) - (td ,build-count)))) - builds-by-system-excluding-cross-builds))) + (div + (a (@ (href ,(assoc-ref series "web_url"))) + "View series on Patchwork")) - ,(assoc-ref series "web_url"))))) + (div + (a (@ (href ,comparison-link)) + "View Guix Data Service comparison")) + (div + (table + (thead + (tr + (th (@ (rowspan 3)) "System") + (th (@ (colspan 6)) "Testing") + (th)) + (tr + (th (@ (colspan 3)) "Base") + (th (@ (colspan 3)) "With patches applied") + (th)) + (tr + (th "Succeeding") + (th "Failing") + (th "Unknown") + (th "Succeeding") + (th "Failing") + (th "Unknown") + (th))) + (tbody + ,@(map + (match-lambda + ((system . builds) + (peek "BUILDS" builds) + `(tr + (td (@ (class "monospace")) ,system) + ,@(append-map + (lambda (builds) + (map + (lambda (status) + `(td ,(count-builds-by-status + (or (assoc-ref builds system) + '()) + status))) + '("succeeded" "failed" "scheduled"))) + (list base-builds + target-builds)) + (td (a (@ (href ,(package-derivations-comparison-link system))) + "View comparison"))))) + target-builds)))))))) diff --git a/guix-qa-frontpage/view/util.scm b/guix-qa-frontpage/view/util.scm index 784e499..b66c1e8 100644 --- a/guix-qa-frontpage/view/util.scm +++ b/guix-qa-frontpage/view/util.scm @@ -78,8 +78,17 @@ (href "/assets/css/mvp.css"))) (style " + + :root { --justify-important: left; + --justify-normal: center; +} + +table td, +table th, +table tr { + text-align: center; } header, main { @@ -113,10 +122,18 @@ header { border-right: 2px dashed orange; } +.monospace { + font-family: monospace; + font-size: 16px; +} + ") ,@head) (body (header - (h1 "Guix QA")) + (h1 "Guix QA" + ,@(if title + `(": " ,title) + '()))) ,@body (footer (p "Copyright © 2016—2020 by the GNU Guix community." |