Port the package changes functionality from branches to issues

3 files changed, 497 insertions, 582 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
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index 62701f8..052aaed 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -7,7 +7,9 @@
   #: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))
+  #:use-module (guix-qa-frontpage view shared)
+  #:export (issue-view
+            issue-package-changes-view))
 
 (define (issue-view issue-number series mumi-tags
                     comparison-link
@@ -16,21 +18,6 @@
                     change-details comparison-details
                     systems-with-low-substitute-availability)
 
-  (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))
 
@@ -243,132 +230,10 @@ td.bad {
                                " ")))
                      systems-with-low-substitute-availability))))
 
-       (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 (assq-ref comparison-details 'exception))
-                    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=>
-                             (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)))))))
-                            '()))))))))
+       ,(package-changes-summary-table
+         (assoc-ref change-details "revisions")
+         derivation-changes-counts
+         (string-append "/issue/" issue-number)))
 
       (div
        (h3 "Review checklist")
@@ -398,3 +263,10 @@ td.bad {
         (@ (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))
diff --git a/guix-qa-frontpage/view/shared.scm b/guix-qa-frontpage/view/shared.scm
new file mode 100644
index 0000000..36670f3
--- /dev/null
+++ b/guix-qa-frontpage/view/shared.scm
@@ -0,0 +1,474 @@
+;;; Guix QA Frontpage
+;;;
+;;; Copyright © 2022 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-qa-frontpage view shared)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
+  #:use-module (ice-9 match)
+  #:use-module ((guix-data-service model utils) #:select (group-to-alist))
+  #:use-module (guix-qa-frontpage manage-builds)
+  #:use-module (guix-qa-frontpage view util)
+  #:export (package-changes-view
+            package-changes-summary-table))
+
+(define (package-changes-view title
+                              derivation-changes
+                              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 title
+   #: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"))))))))
+
+(define (package-changes-summary-table revisions
+                                       derivation-changes-counts
+                                       package-changes-url-prefix)
+
+  (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)
+         "")))
+
+  `(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
+                                  package-changes-url-prefix
+                                  "/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
+                                  package-changes-url-prefix
+                                  "/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
+                                  package-changes-url-prefix
+                                  "/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
+                                  package-changes-url-prefix
+                                  "/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)"
+                                              "target revision")))))))))))
+                            params)))
+                        '()))))))))