(define-module (guix-qa-frontpage view issue) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (web uri) #:use-module (guix-qa-frontpage issue) #:use-module (guix-qa-frontpage manage-builds) #: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)) (define (issue-view issue-number series mumi-tags comparison-link derivation-changes-counts builds-missing? change-details comparison-details) (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)) (layout #:title (simple-format #f "Issue ~A" issue-number) #:head '((style " td.good { padding: 0.05rem 0.65rem; font-weight: bold; border: 0.3rem dashed green; } td.bad { padding: 0.05rem 0.65rem; font-weight: bold; border: 0.3rem dashed red; } .tag { display: inline-block; padding: 0.25em 0.4em; margin-left: 0.25em; font-size: 75%; font-weight: 700; line-height: 1; text-align: center; white-space: nowrap; vertical-align: baseline; border-radius: 0.25rem; background-color: var(--color-accent); } ")) #:body `((main (div (@ (class "large-screen-float-right")) (h3 "Links") (ul (li (a (@ (href ,(simple-format #f "https://issues.guix.gnu.org/~A" issue-number))) "View issue on issues.guix.gnu.org")) (li (a (@ (href ,(let ((branch-name (simple-format #f "issue-~A" issue-number)) (base-tag (simple-format #f "base-for-issue-~A" issue-number))) (simple-format #f "~A/log/?h=~A&qt=range&q=~A..~A" "https://git.guix-patches.cbaines.net/guix-patches" branch-name base-tag branch-name)))) "View Git branch")) (li (a (@ (href ,(assoc-ref series "web_url"))) "View series on Patchwork")) ,@(if comparison-link `((li (a (@ (href ,comparison-link)) "View Guix Data Service comparison"))) '()) (li (a (@ (href ,(string-append "mailto:control@debbugs.gnu.org?" "subject=" (uri-encode (simple-format #f "tag ~A moreinfo" issue-number)) "&body=" (uri-encode (string-append (simple-format #f "tags ~A ~A moreinfo" issue-number (if tagged-as-moreinfo? "-" "+")) "\nquit\n"))))) ,(if tagged-as-moreinfo? "Remove moreinfo tag" "Mark as moreinfo"))))) (h2 ,(assoc-ref series "name") ,@(map (lambda (tag) `(span (@ (class "tag")) ,tag)) (or mumi-tags '()))) (ul ,@(map (lambda (patch) `(li ,(assoc-ref patch "name"))) (assoc-ref series "patches"))) (div (h3 "Lint warnings") (table (thead (tr (th "Change") (th "Linter") (th "Message"))) (tbody ,@(if (and comparison-details (not (guix-data-service-error? comparison-details))) (if (eq? (vector-length (assoc-ref comparison-details "lint_warnings")) 0) `((tr (td (@ (colspan 3)) "No lint warning changes" (br) (small "(for lint checkers that don't require the network)")))) (append-map (lambda (package-warnings) (filter-map (lambda (warning) (let ((checker (assoc-ref warning "checker"))) (if (string=? (assoc-ref checker "name") "derivation") #f `(tr (td (@ (style ,(string-join `("border-left-width: 0.35em;" "border-left-style: solid;" ,(string-append "border-left-color: " (if (string=? (assoc-ref warning "change") "new") "red" "green")))))) ,(assoc-ref warning "change")) (td (span (@ (class "monospace") (style "display: block;")) ,(assoc-ref checker "name")) (p (@ (style "font-size: small;")) ,(assoc-ref checker "description"))) (td ,(assoc-ref warning "message")))))) (vector->list (assoc-ref package-warnings "warnings")))) (vector->list (assoc-ref comparison-details "lint_warnings")))) `((tr (td (@ (colspan 3) (class "bad")) "Comparison unavailable" ,@(or (and=> (and (guix-data-service-error? comparison-details) (assoc-ref (guix-data-service-error-response-body comparison-details) "target_job")) (lambda (target-job) `((p "Yet to process " (a (@ (href ,(string-append "https://data.qa.guix.gnu.org/revision/" (assoc-ref target-job "commit")))) "revision") ", job " ,(assoc-ref target-job "state"))))) '())))))))) (div (h3 "Package changes") (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 (guix-data-service-error? comparison-details)) 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=> (and (guix-data-service-error? comparison-details) (assoc-ref (guix-data-service-error-response-body comparison-details) "target_job")) (lambda (target-job) `((p "Yet to process " (a (@ (href ,(string-append "https://data.qa.guix.gnu.org/revision/" (assoc-ref target-job "commit")))) "revision") ", job " ,(assoc-ref target-job "state"))))) '())))))))) (div (h3 "Review checklist") (p "This is just to help anyone reviewing the changes.") ,@(map (match-lambda ((id label) `(div (input (@ (type "checkbox") (id ,id))) (label (@ (for ,id)) ,label)))) '(("lint-warnings" "Lint warnings") ("license" "License") ("package-builds" "Package builds") ("package-tests" "Package tests") ("synopsis-and-description" "Synopsis and description") ("commit-messages" "Commit messages"))) (div (label (@ (for "notes")) "Notes") (textarea (@ (id "notes"))))) (div (h3 "Badges (work in progress)") (img (@ (src ,(simple-format #f "/issue/~A/status-badge-medium.svg" issue-number)))))))))