path: root/guix-qa-frontpage/view/issue.scm

(define-module (guix-qa-frontpage view issue)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (web uri)
  #:use-module (guix-data-service web sxml)
  #: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)
  #:use-module (guix-qa-frontpage view shared)
  #:export (issue-view
            issue-package-changes-view
            issue-package-cross-changes-view

            issue-prepare-review-view))

(define (issue-view issue-number series branch mumi-tags
                    base-and-target-refs
                    create-branch-for-issue-log
                    comparison-link
                    derivation-changes
                    cross-derivation-changes
                    builds-missing?
                    change-details comparison-details
                    systems-with-low-substitute-availability)

  (define tagged-as-moreinfo?
    (member "moreinfo" mumi-tags))

  (define debbugs-usertags
    (assq-ref series 'usertags))

  (define derivation-changes-counts
    (assq-ref derivation-changes 'counts))

  (define cross-derivation-changes-counts
    (and cross-derivation-changes
         (filter
          (match-lambda
            (((system . target) . derivations) #t)
            (_ #f))
          (assq-ref cross-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")
        ,@(let ((merged-with
                 (assq-ref (assq-ref series 'mumi)
                           'merged-with)))
            (if (null? merged-with)
                '()
                `((br)
                  "Merged with:"
                  (ul
                   ,@(map
                      (lambda (number)
                        `(li
                          (a (@ (href
                                 ,(simple-format #f "https://issues.guix.gnu.org/~A"
                                                 number)))
                             ,number)))
                      merged-with))))))
       ,@(if base-and-target-refs
             `((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)
                (and (null? derivation-changes-counts)
                     (null? cross-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))

      (h4 "Cross builds from "
          (code "x86_64-linux"))

      ,(package-cross-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"))))
        cross-derivation-changes-counts
        (string-append "/issue/" issue-number))))

  (define prepare-review-section
    `(section
      (form
       (@ (action ,(simple-format #f "/issue/~A/prepare-review"
                                  issue-number)))
       (header
        (@ (style "padding: 0; margin: 0;"))
        (h3 "Mark patches as reviewed")
        (p "This feature is for people other than those involved in submitting the
patches to record a review, which will highlight that these patches should be
ready to merge.")

        (p "Here's a list of common things to check, tick them off as you review
the patches:"))

       ,@(map
          (match-lambda
            ((id label)
             `(div
               (input (@ (type "checkbox")
                         (id ,id)
                         (name ,id)))
               (label (@ (for ,id)) ,label))))
          '(("lint-warnings" "Are these changes not adding to the lint warnings?")
            ("package-builds" "Do these changes not cause packages to fail to build?")
            ("commit-messages" "Are the commit messages written well?")))

       "New packages"
       (div
        (@ (style "margin-left: 0.4em;"))
        ,@(map
           (match-lambda
             ((id label)
              `(div
                (input (@ (type "checkbox")
                          (id ,id)
                          (name ,id)))
                (label (@ (for ,id)) ,label))))
           '(("license" "Is the license information complete?")
             ("package-tests" "Are package tests being run (if available)?")
             ("synopsis-and-description"
              "Are the synopsis and description well written?"))))

       (div
        (label (@ (for "notes")) "Notes to include in the review")
        (textarea (@ (id "notes")
                     (name "notes")
                     (rows 5)
                     (style "width: 96%"))))

       (button (@ (type "submit")) "Prepare review"))))

  (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;
}

div.bad {
  padding: 0.05rem 0.65rem;
  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
      ,links-div

      (h2 ,(assoc-ref series "name")
          ,@(map
             (lambda (tag)
               `(span (@ (class "tag"))
                      ,tag))
             (or mumi-tags '()))
          ,@(map
             (lambda (tag)
               `(span (@ (class "tag"))
                      "(guix) "
                      ,tag))
             (or debbugs-usertags '())))

      (h3 (@ (style ,(if (string=? branch "master")
                         ""
                         "padding-left: 0.2em; border-left-width: 0.3em; border-left-style: solid; border-left-color: orange")))
          "For branch: " (code ,branch))

      (ul
       ,@(map
          (lambda (patch)
            `(li ,(assoc-ref patch "name")))
          (vector->list
           (assoc-ref series "patches"))))

      ,@(if base-and-target-refs
            `(,lint-warnings-div
              ,package-changes-div)
            (if create-branch-for-issue-log
                `((div
                   (@ (class "bad")
                      (style "width: fit-content;"))
                   (h3 "Unable to apply "
                       ,(if (= 0 (vector-length
                                  (assoc-ref series "patches")))
                            "patch"
                            "patches"))
                   (pre ,create-branch-for-issue-log)))
                '()))

      ,prepare-review-section

      (div
       (h3 "Badges (work in progress)")
       (img
        (@ (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))

(define (issue-package-cross-changes-view issue-number
                                          system
                                          cross-derivation-changes
                                          query-parameters)
  (package-cross-changes-view
   (simple-format #f "Issue ~A" issue-number)
   system
   cross-derivation-changes
   query-parameters))

(define (issue-prepare-review-view issue-number query-parameters)
  (define (escape str)
    (call-with-output-string
      (lambda (port)
        (sxml->html str port))))

  (define checkboxes
    ;; Form field name -> text in the email
    `(("lint-warnings" . "Lint warnings")
      ("package-builds" . "Package builds")
      ("commit-messages" . "Commit messages")
      ("license" . "New package licenses")
      ("package-tests" . "New package tests")
      ("synopsis-and-description" . "New package synopsis and descriptions")))

  (define email-text
    (string-append
     "user guix
usertag "
     issue-number
     " + reviewed-looks-good
thanks

Guix QA review form submission:"
     (or
      (and=> (assoc-ref query-parameters "notes")
             (lambda (notes)
               (string-append
                "\n"
                (escape notes))))
      "")
     (let ((things-checked
            (filter-map
             (lambda (param)
               (if (and (member (car param)
                                (map car checkboxes))
                        (string=? (cdr param) "on"))
                   (assoc-ref checkboxes (car param))
                   #f))
             query-parameters)))
       (if (null? things-checked)
           "\n\nNo checks recorded."
           (string-append
            "\n\nItems marked as checked: "
            (string-join things-checked ", "))))))

  (layout
   #:title (simple-format #f "Prepare review - Issue ~A" issue-number)
   #:body
   `((main
      (p "Like patches, reviews are submitted by email.")
      (a (@ (href
             ,(string-append
               "mailto:control@debbugs.gnu.org"
               (simple-format #f ",~A@debbugs.gnu.org" issue-number)
               "?"
               "subject="
               (uri-encode
                (simple-format #f "QA review for ~A" issue-number))
               "&body="
               (uri-encode email-text))))
         (b "Open mail client to send review email"))
      (p "If the above link doesn't work for you, the contents of the suggested email is given below, and can be sent "
         (strong "to control@debbugs.gnu.org and 66195@debbugs.gnu.org"))
      (pre ,email-text)))))