(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 manage-builds)
#: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
derivation-changes
change-details comparison-details)
(define comparison-link
(and=>
(assoc-ref change-details "revisions")
(lambda (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
#: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 ,(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 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)
(map
(lambda (warning)
`(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 ,@(let ((checker (assoc-ref warning "checker")))
`((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))
"Comparison unavailable")))))))
(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)) "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 ,header-style))
"Succeeding")
(th (@ (style ,header-style))
"Failing")
(th (@ (style ,header-style))
"Blocked")
(th (@ (style ,header-style))
"Unknown")
(th)))))
(tbody
,@(if (and comparison-details
derivation-changes)
(let* ((base-builds
(builds-by-system-excluding-cross-builds
derivation-changes "base"))
(target-builds
(builds-by-system-excluding-cross-builds
derivation-changes "target"))
(all-systems
(delete-duplicates
(append (map car base-builds)
(map car target-builds))))
(categorised-base-builds-by-system
(categorise-builds all-systems base-builds))
(categorised-target-builds-by-system
(categorise-builds all-systems target-builds)))
(if (null? target-builds)
`((tr
(td (@ (colspan 7))
"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 . categorised-target-builds)
(let ((categorised-base-builds
(assoc-ref categorised-base-builds-by-system
system))
(highlighed-common
" "))
(define (count side status)
(length
(assoc-ref
(if (eq? side 'base)
categorised-base-builds
categorised-target-builds)
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"))
(a (@ (href ,(package-derivations-comparison-link
system
#:build-change "broken")))
,(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"))
(a (@ (href ,(package-derivations-comparison-link
system
#:build-change "unknown")))
,(count 'target 'unknown)))
`(td ,(count 'target 'unknown)))
(td (a (@ (href
,(package-derivations-comparison-link system)))
"View comparison"))))))
(sort
categorised-target-builds-by-system
(lambda (a b)
(< (or (list-index
(lambda (s)
(string=? (car a) s))
%systems-to-submit-builds-for)
10)
(or (list-index
(lambda (s)
(string=? (car b) s))
%systems-to-submit-builds-for)
10)))))))
'((tr
(td (@ (colspan 10))
"Comparison unavailable")))))))
(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
(h3 "Badges (work in progress)")
(img
(@ (src ,(simple-format #f "/issue/~A/status-badge-medium.svg"
issue-number)))))))))