Port the package changes functionality from branches to issues

1 files changed, 9 insertions, 440 deletions

diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
index 830b5cb..1bddbba 100644
--- a/guix-qa-frontpage/view/branch.scm
+++ b/guix-qa-frontpage/view/branch.scm
@@ -7,6 +7,7 @@
   #:use-module (guix-qa-frontpage manage-builds)
   #:use-module (guix-qa-frontpage derivation-changes)
   #:use-module (guix-qa-frontpage view util)
+  #:use-module (guix-qa-frontpage view shared)
   #:export (branch-view
             branch-package-changes-view
 
@@ -16,17 +17,6 @@
                      substitute-availability
                      up-to-date-with-master
                      master-branch-systems-with-low-substitute-availability)
-  (define* (package-derivations-comparison-link system
-                                                #:key build-change)
-    (string-append
-     (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none"
-                    (assq-ref revisions 'base)
-                    (assq-ref revisions 'target)
-                    system)
-     (if build-change
-         (simple-format #f "&build_change=~A" build-change)
-         "")))
-
   (define derivation-changes-counts
     (assq-ref derivation-changes 'counts))
 
@@ -191,158 +181,10 @@ td.bad {
                     master-branch-systems-with-low-substitute-availability))))
 
       (div
-       (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 branch changes")
-          (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 derivation-changes-counts
-                    (not (assq-ref derivation-changes-counts 'exception)))
-               (if (null? derivation-changes-counts)
-                   `((tr
-                      (td (@ (colspan 7))
-                          "No package derivation changes")))
-                   (map
-                    (match-lambda
-                      ((system . derivations)
-
-                       (define (count side status)
-                         (assoc-ref (assoc-ref
-                                     derivations
-                                     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")))
-                                   '())
-                             (a (@ (href
-                                    ,(string-append
-                                      "/branch/" branch
-                                      "/package-changes?"
-                                      system "-change=fixed&"
-                                      system "-change=still-working&"
-                                      system "-change=new-working")))
-                                ,(count 'target 'succeeding)))
-                         (td ,@(if (> (count 'target 'failing)
-                                      (count 'base 'failing))
-                                   '((@ (class "bad")))
-                                   '())
-                             (a (@ (href
-                                    ,(string-append
-                                      "/branch/" branch
-                                      "/package-changes?"
-                                      system "-change=broken&"
-                                      system "-change=still-failing&"
-                                      system "-change=new-failing")))
-                                ,(count 'target 'failing)))
-                         (td ,@(if (> (count 'target 'blocked)
-                                      (count 'base 'blocked))
-                                   '((@ (class "bad")))
-                                   '())
-                             (a (@ (href
-                                    ,(string-append
-                                      "/branch/" branch
-                                      "/package-changes?"
-                                      system "-change=blocked&"
-                                      system "-change=still-blocked&"
-                                      system "-change=new-blocked")))
-                                ,(count 'target 'blocked)))
-                         (td (@ ,@(if (> (count 'target 'unknown)
-                                         (count 'base 'unknown))
-                                      '((class "bad"))
-                                      '()))
-                             (a (@ (href
-                                    ,(string-append
-                                      "/branch/" branch
-                                      "/package-changes?"
-                                      system "-change=unknown")))
-                                ,(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 derivation-changes-counts
-                                       'invalid_query_parameters)
-                             (lambda (params)
-                               (append-map
-                                (match-lambda
-                                  ((param . details)
-                                   (let ((error
-                                          (assq-ref details 'error)))
-                                     (cond
-                                      ((member param '("base_commit"
-                                                       "target_commit"))
-                                       `((br)
-                                         (a
-                                          (@ (href
-                                              ,(string-append
-                                                "https://data.qa.guix.gnu.org"
-                                                "/revision/"
-                                                (assq-ref
-                                                 revisions
-                                                 (if (string=? param "base_commit")
-                                                     'base
-                                                     'target)))))
-                                          ,(cond
-                                            ((member error
-                                                     '(yet-to-process-revision
-                                                       failed-to-process-revision))
-                                             (simple-format
-                                              #f "~A to process ~A"
-                                              (if (eq? error 'yet-to-process-revision)
-                                                  "Yet"
-                                                  "Failed")
-                                              (if (string=? param "base_commit")
-                                                  "base revision (from master branch)"
-                                                  (string-append
-                                                   "target revision (from "
-                                                   branch " branch)"))))))))))))
-                                params)))
-                            '()))))))))))))
+       ,(package-changes-summary-table
+         revisions
+         derivation-changes-counts
+         (string-append "/branch/" branch)))))))
 
 (define* (delete-duplicates/sort! unsorted-lst less #:key (eq eq?))
   (if (null? unsorted-lst)
@@ -369,283 +211,10 @@ td.bad {
                                      derivation-changes
                                      up-to-date-with-master
                                      query-parameters)
-  (define (derivation-for-system side system)
-    (vector-any
-     (lambda (derivation)
-       (if (string=? (assoc-ref derivation "system")
-                     system)
-           derivation
-           #f))
-     side))
-
-  (define (builds-by-system base target)
-    (map
-     (lambda (system)
-       (cons
-        system
-        `(("base" . ,(and=>
-                      (derivation-for-system base system)
-                      (lambda (derivation)
-                        (vector->list
-                         (assoc-ref derivation "builds")))))
-          ("target" . ,(and=>
-                        (derivation-for-system target system)
-                        (lambda (derivation)
-                          (vector->list
-                           (assoc-ref derivation "builds"))))))))
-     %systems-to-submit-builds-for))
-
-  (define (derivations-by-system base target)
-    (map
-     (lambda (system)
-       (cons
-        system
-        `(("base" . ,(and=>
-                      (derivation-for-system base system)
-                      (lambda (derivation)
-                        (assoc-ref derivation "derivation-file-name"))))
-          ("target" . ,(and=>
-                        (derivation-for-system target system)
-                        (lambda (derivation)
-                          (assoc-ref derivation "derivation-file-name")))))))
-     %systems-to-submit-builds-for))
-
-  (define (builds->overall-status side-builds)
-    (if (eq? #f side-builds)
-        'not-present
-        (let ((build-statuses
-               (map
-                (lambda (build)
-                  (let ((status
-                         (assoc-ref build "status")))
-                    (if (and (string=? status "scheduled")
-                             (assoc-ref build "potentially_blocked"))
-                        "blocked"
-                        status)))
-                side-builds)))
-          (cond
-           ((member "succeeded" build-statuses)
-            'succeeding)
-           ((and (not (member "succeeded" build-statuses))
-                 (member "failed" build-statuses))
-            'failing)
-           ((member "blocked" build-statuses)
-            'blocked)
-           (else
-            'unknown)))))
-
-  (define %changes
-    '(broken
-      fixed
-      blocked
-      still-working
-      still-failing
-      still-blocked
-      new-working
-      new-failing
-      new-blocked
-      removed-working
-      removed-failing
-      removed-blocked
-      unknown))
-
-  (define (builds->change-by-system builds-by-system)
-    (map
-     (match-lambda
-       ((system . builds)
-        (let ((base-status (builds->overall-status
-                            (assoc-ref builds "base")))
-              (target-status (builds->overall-status
-                              (assoc-ref builds "target"))))
-          (cons
-           system
-           (cond
-            ((and (eq? base-status 'succeeding)
-                  (eq? target-status 'failing))
-             'broken)
-            ((and (eq? base-status 'succeeding)
-                  (eq? target-status 'blocked))
-             'blocked)
-            ((and (or (eq? base-status 'failing)
-                      (eq? base-status 'blocked))
-                  (eq? target-status 'succeeding))
-             'fixed)
-            ((and (eq? 'not-present base-status)
-                  (eq? 'succeeding target-status))
-             'new-working)
-            ((and (eq? 'not-present base-status)
-                  (eq? 'failing target-status))
-             'new-failing)
-            ((and (eq? 'not-present base-status)
-                  (eq? 'blocked target-status))
-             'new-blocked)
-            ((and (eq? 'succeeding base-status)
-                  (eq? 'not-present target-status))
-             'removed-working)
-            ((and (eq? 'failing base-status)
-                  (eq? 'not-present target-status))
-             'removed-failing)
-            ((and (eq? 'blocked base-status)
-                  (eq? 'not-present target-status))
-             'removed-blocked)
-            ((and (eq? base-status target-status 'succeeding))
-             'still-working)
-            ((and (eq? base-status target-status 'failing))
-             'still-failing)
-            ((and (eq? base-status target-status 'blocked))
-             'still-blocked)
-            (else 'unknown))))))
-     builds-by-system))
-
-  (define (display-builds builds derivations change)
-    (define %color-for-change
-      '((fixed           . "green")
-        (broken          . "red")
-        (blocked         . "yellow")
-        (still-working   . "lightgreen")
-        (still-failing   . "#FFCCCB")
-        (still-blocked   . "lightyellow")
-        (new-working     . "lightgreen")
-        (new-failing     . "red")
-        (new-blocked     . "lightyellow")
-        (removed-working . "")
-        (removed-failing . "")
-        (removed-blocked . "")
-        (unknown         . "lightgrey")))
-
-    (if builds
-        (let ((base-status
-               (builds->overall-status
-                (assoc-ref builds "base")))
-              (target-status
-               (builds->overall-status
-                (assoc-ref builds "target"))))
-          (if (and
-               (eq? base-status 'not-present)
-               (eq? target-status 'not-present))
-              '(td)
-              `(td
-                (@ (style ,(simple-format
-                            #f
-                            "background-color: ~A;"
-                            (assq-ref
-                             %color-for-change
-                             change))))
-                ,(if (eq? base-status 'not-present)
-                     `(div "was not present")
-                     `(div
-                       (a (@ (href ,(string-append
-                                     "https://data.qa.guix.gnu.org"
-                                     (assoc-ref derivations "base"))))
-                          "was " ,base-status)))
-                ,(if (eq? target-status 'not-present)
-                     `(div "now not present")
-                     `(div
-                       (a (@ (href ,(string-append
-                                     "https://data.qa.guix.gnu.org"
-                                     (assoc-ref derivations "target"))))
-                          "now " ,target-status))))))
-        '(td)))
-
-  (define grouped-query-parameters
-    (group-to-alist
-     identity
-     query-parameters))
-
-  (define system-change
-    (map
-     (lambda (system)
-       (cons (string-append system "-change")
-             system))
-     %systems-to-submit-builds-for))
-
-  (define (display? package-and-version change-by-system)
-    (every
-     (match-lambda
-       ((key . vals)
-        (cond
-         ((assoc-ref system-change key)
-          (let ((system (assoc-ref system-change key)))
-            (->bool
-             (member (assoc-ref change-by-system system)
-                     (map string->symbol vals)))))
-         (else #t))))
-     grouped-query-parameters))
-
-  (layout
-   #:title (simple-format #f "Branch ~A" branch)
-   #:body
-   `((main
-      (table
-       (form
-        (@ (id "filter-form")
-           (method "get"))
-        (thead
-         (tr
-          (td "Name")
-          (td "Version")
-          ,@(map
-             (lambda (system)
-               `(td ,system
-                    (select
-                     (@ (name
-                         ,(simple-format #f "~A-change"
-                                         system))
-                        (multiple #t))
-                     ,@(let ((system-change-selected-options
-                              (or (assoc-ref
-                                   grouped-query-parameters
-                                   (string-append system "-change"))
-                                  '())))
-                         (map
-                          (match-lambda
-                            ((value . label)
-                             `(option
-                               (@ (value ,value)
-                                  ,@(if (member (symbol->string value)
-                                                system-change-selected-options)
-                                        '((selected ""))
-                                        '()))
-                               ,label)))
-                          (map
-                           (lambda (change)
-                             (cons change change))
-                           %changes))))
-                    (button
-                     (@ (type "submit"))
-                     "Update")))
-             %systems-to-submit-builds-for))))
-       (tbody
-        (@ (style "overflow: auto; max-height: 40em;"))
-        ,@(vector-fold-right
-           (lambda (_ result package-and-version)
-             (let* ((builds
-                     (builds-by-system
-                      (assoc-ref package-and-version "base")
-                      (assoc-ref package-and-version "target")))
-                    (change-by-system
-                     (builds->change-by-system builds))
-                    (derivations
-                     (derivations-by-system
-                      (assoc-ref package-and-version "base")
-                      (assoc-ref package-and-version "target"))))
-               (cons
-                `(tr
-                  (@ ,@(if (display? package-and-version
-                                     change-by-system)
-                           '()
-                           '((style "display: none;"))))
-                  (td ,(assoc-ref package-and-version "name"))
-                  (td ,(assoc-ref package-and-version "version"))
-                  ,@(map
-                     (lambda (system)
-                       (display-builds (assoc-ref builds system)
-                                       (assoc-ref derivations system)
-                                       (assoc-ref change-by-system system)))
-                     %systems-to-submit-builds-for))
-                result)))
-           '()
-           (assoc-ref derivation-changes "derivation_changes"))))))))
+  (package-changes-view
+   (simple-format #f "Branch ~A" branch)
+   derivation-changes
+   query-parameters))
 
 (define (master-branch-view substitute-availability)
   (layout