diff options
Diffstat (limited to 'guix-qa-frontpage/view')
| -rw-r--r-- | guix-qa-frontpage/view/issue.scm | 386 |
1 files changed, 198 insertions, 188 deletions
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm index 68ed8f1..fc5915d 100644 --- a/guix-qa-frontpage/view/issue.scm +++ b/guix-qa-frontpage/view/issue.scm @@ -24,6 +24,200 @@ (define derivation-changes-counts (assq-ref derivation-changes 'counts)) + (define links-div + `(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")))))) + + (define lint-warnings-div + `(div + (h3 "Lint warnings") + (table + (thead + (tr + (th "Change") + (th "Linter") + (th "Message"))) + (tbody + ,@(if (and comparison-details + (not (assq-ref comparison-details 'exception))) + (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=> + (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))))))) + '()))))))))) + + (define package-changes-div + `(div + (h3 "Package changes") + + ,@(if (or (not builds-missing?) + (eq? #f systems-with-low-substitute-availability) + (null? systems-with-low-substitute-availability) + (not comparison-details) + (assq-ref comparison-details 'exception) + (null? derivation-changes-counts)) + '() + ;; TODO: Only show (and apply) this if it relates to these + ;; changes. So just look at the systems relevant to the changes. + `((p (@ (style ,(string-join + '("text-align: center;" + "font-weight: bold;" + "padding: 1rem;" + "max-width: 46rem;" + "border-width: 0.35em;" + "border-style: dashed;" + "border-color: red")))) + "Builds for this patch series not yet submitted as " + (a (@ (href "/branch/master")) + "master branch substitute availability") + " is low for: " + ,@(append-map + (lambda (system) + `((span (@ (style "font-family: monospace; white-space: nowrap;")) + ,system + " "))) + systems-with-low-substitute-availability)))) + + ,(package-changes-summary-table + (let ((revisions (assoc-ref change-details "revisions"))) + `((base . ,(assoc-ref (assoc-ref revisions "base") + "commit")) + (target . ,(assoc-ref (assoc-ref revisions "target") + "commit")))) + derivation-changes-counts + (string-append "/issue/" issue-number)))) + + (define review-checklist-div + `(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")))))) + (layout #:title (simple-format #f "Issue ~A" issue-number) #:head @@ -58,53 +252,7 @@ td.bad { ")) #: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"))))) + ,links-div (h2 ,(assoc-ref series "name") ,@(map @@ -119,147 +267,9 @@ td.bad { `(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 (assq-ref comparison-details 'exception))) - (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=> - (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))))))) - '())))))))) - - (div - (h3 "Package changes") - - ,@(if (or (not builds-missing?) - (eq? #f systems-with-low-substitute-availability) - (null? systems-with-low-substitute-availability) - (not comparison-details) - (assq-ref comparison-details 'exception) - (null? derivation-changes-counts)) - '() - ;; TODO: Only show (and apply) this if it relates to these - ;; changes. So just look at the systems relevant to the changes. - `((p (@ (style ,(string-join - '("text-align: center;" - "font-weight: bold;" - "padding: 1rem;" - "max-width: 46rem;" - "border-width: 0.35em;" - "border-style: dashed;" - "border-color: red")))) - "Builds for this patch series not yet submitted as " - (a (@ (href "/branch/master")) - "master branch substitute availability") - " is low for: " - ,@(append-map - (lambda (system) - `((span (@ (style "font-family: monospace; white-space: nowrap;")) - ,system - " "))) - systems-with-low-substitute-availability)))) - - ,(package-changes-summary-table - (let ((revisions (assoc-ref change-details "revisions"))) - `((base . ,(assoc-ref (assoc-ref revisions "base") - "commit")) - (target . ,(assoc-ref (assoc-ref revisions "target") - "commit")))) - derivation-changes-counts - (string-append "/issue/" issue-number))) - - (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"))))) + ,lint-warnings-div + ,package-changes-div + ,review-checklist-div (div (h3 "Badges (work in progress)") |