diff options
Diffstat (limited to 'guix-qa-frontpage/view/issue.scm')
| -rw-r--r-- | guix-qa-frontpage/view/issue.scm | 156 |
1 files changed, 14 insertions, 142 deletions
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm index 62701f8..052aaed 100644 --- a/guix-qa-frontpage/view/issue.scm +++ b/guix-qa-frontpage/view/issue.scm @@ -7,7 +7,9 @@ #:use-module (guix-qa-frontpage guix-data-service) #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage view util) - #:export (issue-view)) + #:use-module (guix-qa-frontpage view shared) + #:export (issue-view + issue-package-changes-view)) (define (issue-view issue-number series mumi-tags comparison-link @@ -16,21 +18,6 @@ change-details comparison-details systems-with-low-substitute-availability) - (define* (package-derivations-comparison-link system - #:key build-change) - (let ((revisions - (assoc-ref change-details "revisions"))) - (string-append - (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none" - (assoc-ref (assoc-ref revisions "base") - "commit") - (assoc-ref (assoc-ref revisions "target") - "commit") - system) - (if build-change - (simple-format #f "&build_change=~A" build-change) - "")))) - (define tagged-as-moreinfo? (member "moreinfo" mumi-tags)) @@ -243,132 +230,10 @@ td.bad { " "))) systems-with-low-substitute-availability)))) - (table - (@ (style "border-collapse: collapse;")) - (thead - (tr - (th (@ (rowspan 3)) "System") - (th (@ (colspan 8)) "Package build status") - (th)) - (tr - (th (@ (colspan 4)) "Base") - (th (@ (colspan 4) - (style "border-left-width: 0.1em; border-left-style: solid; border-left-color: black")) - "With patches applied") - (th)) - (tr - ,@(let ((header-style - "font-size: 80%; min-width: 3.5rem;")) - `((th (@ (style ,header-style)) - "Succeeding") - (th (@ (style ,header-style)) - "Failing") - (th (@ (style ,header-style)) - "Blocked") - (th (@ (style ,header-style)) - "Unknown") - (th (@ (style - ,(string-append - header-style - " border-left-width: 0.125em; border-left-style: solid; border-left-color: black;"))) - "Succeeding") - (th (@ (style ,header-style)) - "Failing") - (th (@ (style ,header-style)) - "Blocked") - (th (@ (style ,header-style)) - "Unknown") - (th))))) - (tbody - ,@(if (and comparison-details - (not (assq-ref comparison-details 'exception)) - derivation-changes-counts) - (if (null? derivation-changes-counts) - `((tr - (td (@ (colspan 10)) - "No package derivation changes" - (br) - (small "(for the following systems: " - ,@(drop-right - (append-map - (lambda (system) - `((span (@ (style "font-family: monospace;")) - ,system) - ", ")) - %systems-to-submit-builds-for) - 1) - ")")))) - (map - (match-lambda - ((system . counts) - (define (count side status) - (assoc-ref (assoc-ref - counts - side) - status)) - `(tr - (td (@ (class "monospace")) ,system) - ,@(map (lambda (status) - `(td ,(count 'base status))) - '(succeeding failing blocked unknown)) - (td ,@(if (and (>= (count 'target 'succeeding) - (count 'base 'succeeding)) - (> (count 'target 'succeeding) - 0)) - `((@ (class "good"))) - '()) - ,(count 'target 'succeeding)) - ,(if (> (count 'target 'failing) - (count 'base 'failing)) - `(td (@ (class "bad")) - ,(count 'target 'failing)) - `(td ,(count 'target 'failing))) - ,(if (> (count 'target 'blocked) - (count 'base 'blocked)) - `(td (@ (class "bad")) - ,(count 'target 'blocked)) - `(td ,(count 'target 'blocked))) - ,(if (> (count 'target 'unknown) - (count 'base 'unknown)) - `(td (@ (class "bad")) - ,(count 'target 'unknown)) - `(td ,(count 'target 'unknown))) - (td (a (@ (href - ,(package-derivations-comparison-link system))) - "View comparison"))))) - derivation-changes-counts)) - `((tr - (td (@ (colspan 10) - (class "bad")) - "Comparison unavailable" - - ,@(or (and=> - (assq-ref comparison-details 'exception) - (lambda (exception) - (and=> - (assq-ref comparison-details 'invalid_query_parameters) - (lambda (invalid-params) - (let ((target-commit - (assoc-ref invalid-params "target_commit"))) - (cond - (target-commit - (let ((error (assq-ref target-commit 'error)) - (value (assq-ref target-commit 'value))) - `((p - ,(cond - ((eq? error 'yet-to-process-revision) - "Yet to process ") - ((eq? error 'failed-to-process-revision) - "Failed to process ") - (else - "Unknown issue with ")) - (a (@ (href ,(string-append - "https://data.qa.guix.gnu.org/revision/" - value))) - "revision"))))) - (else - #f))))))) - '())))))))) + ,(package-changes-summary-table + (assoc-ref change-details "revisions") + derivation-changes-counts + (string-append "/issue/" issue-number))) (div (h3 "Review checklist") @@ -398,3 +263,10 @@ td.bad { (@ (src ,(simple-format #f "/issue/~A/status-badge-medium.svg" issue-number))))))))) +(define (issue-package-changes-view issue-number + derivation-changes + query-parameters) + (package-changes-view + (simple-format #f "Issue ~A" issue-number) + derivation-changes + query-parameters)) |