Show the changes to cross derivations on issue pages

6 files changed, 733 insertions, 224 deletions

diff --git a/guix-qa-frontpage/derivation-changes.scm b/guix-qa-frontpage/derivation-changes.scm
index 6953603..cda0084 100644
--- a/guix-qa-frontpage/derivation-changes.scm
+++ b/guix-qa-frontpage/derivation-changes.scm
@@ -128,16 +128,26 @@
                          (cons system '())))
                    all-systems))
           (lambda (a b)
-            (< (or (list-index
-                    (lambda (s)
-                      (string=? (car a) s))
-                    all-systems)
-                   10)
-               (or (list-index
-                    (lambda (s)
-                      (string=? (car b) s))
-                    all-systems)
-                   10)))))))
+            (let ((a-key (car a))
+                  (b-key (car b)))
+              (cond
+               ((and (string? a-key)
+                     (string? b-key))
+                (< (or (list-index
+                        (lambda (s)
+                          (string=? (car a) s))
+                        all-systems)
+                       10)
+                   (or (list-index
+                        (lambda (s)
+                          (string=? (car b) s))
+                        all-systems)
+                       10)))
+               ((and (pair? a-key)
+                     (pair? b-key))
+                (string<? (cdr a-key)
+                          (cdr b-key)))
+               (else #f))))))))
 
   `(,@derivation-changes
     (counts  . ,counts)))
diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm
index 8de4e21..03bb39d 100644
--- a/guix-qa-frontpage/guix-data-service.scm
+++ b/guix-qa-frontpage/guix-data-service.scm
@@ -22,6 +22,7 @@
             guix-data-service-error->sexp
 
             compare-package-derivations-url
+            compare-package-cross-derivations-url
             compare-package-derivations
 
             revision-comparison-url
@@ -178,6 +179,18 @@
    "&target=none"
    "&field=builds&limit_results=&all_results=on"))
 
+(define* (compare-package-cross-derivations-url base-and-target-refs #:key systems)
+  (string-append
+   "https://data.qa.guix.gnu.org/compare/package-derivations.json?"
+   "base_commit=" (assq-ref base-and-target-refs 'base)
+   "&target_commit=" (assq-ref base-and-target-refs 'target)
+   (string-join
+    (map (lambda (system)
+           (simple-format #f "&system=~A" system))
+         (or systems '()))
+    "")
+   "&field=builds&limit_results=&all_results=on"))
+
 (define (compare-package-derivations url)
   (let ((json-body
          (guix-data-service-request url)))
diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index 345aafe..87d7a64 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -151,62 +151,82 @@
                             tags-status))))))
 
 (define (issue-data number)
+  (define (call-with-data-service-error-handling thunk)
+    (with-exception-handler
+        (lambda (exn)
+          (if (guix-data-service-error? exn)
+              `((exception . guix-data-service-invalid-parameters)
+                (invalid_query_parameters
+                 .
+                 ,(filter-map
+                   (match-lambda
+                     ((param . val)
+                      (and=>
+                       (assoc-ref val "invalid_value")
+                       (lambda (value)
+                         (let ((message
+                                (assoc-ref val "message")))
+                           (cons
+                            param
+                            `((value . ,value)
+                              (error
+                               ;; Convert the HTML error messages
+                               ;; to something easier to handle
+                               . ,(cond
+                                   ((string-contains message
+                                                     "failed to process revision")
+                                    'failed-to-process-revision)
+                                   ((string-contains message
+                                                     "yet to process revision")
+                                    'yet-to-process-revision)
+                                   (else
+                                    'unknown))))))))))
+                   (assoc-ref
+                    (guix-data-service-error-response-body exn)
+                    "query_parameters"))))
+              `((exception . ,(simple-format #f "~A" exn)))))
+      thunk
+      #:unwind? #t))
+
   (let* ((base-and-target-refs
           (get-issue-branch-base-and-target-refs
            number))
+         (derivation-changes-raw-data
+          (if base-and-target-refs
+              (call-with-data-service-error-handling
+               (lambda ()
+                 (compare-package-derivations
+                  (compare-package-derivations-url
+                   base-and-target-refs
+                   #:systems %systems-to-submit-builds-for))))
+              #f))
          (derivation-changes-data
+          (if (and derivation-changes-raw-data
+                   (not (assq-ref derivation-changes-raw-data 'exception)))
+              (derivation-changes
+               derivation-changes-raw-data
+               %systems-to-submit-builds-for)
+              #f))
+         (cross-derivation-changes-raw-data
           (if base-and-target-refs
-              (with-exception-handler
-                  (lambda (exn)
-                    (if (guix-data-service-error? exn)
-                        `((exception . guix-data-service-invalid-parameters)
-                          (invalid_query_parameters
-                           .
-                           ,(filter-map
-                             (match-lambda
-                               ((param . val)
-                                (and=>
-                                 (assoc-ref val "invalid_value")
-                                 (lambda (value)
-                                   (let ((message
-                                          (assoc-ref val "message")))
-                                     (cons
-                                      param
-                                      `((value . ,value)
-                                        (error
-                                         ;; Convert the HTML error messages
-                                         ;; to something easier to handle
-                                         . ,(cond
-                                             ((string-contains message
-                                                               "failed to process revision")
-                                              'failed-to-process-revision)
-                                             ((string-contains message
-                                                               "yet to process revision")
-                                              'yet-to-process-revision)
-                                             (else
-                                              'unknown))))))))))
-                             (assoc-ref
-                              (guix-data-service-error-response-body exn)
-                              "query_parameters"))))
-                        `((exception . ,(simple-format #f "~A" exn)))))
-                (lambda ()
-                  (compare-package-derivations
-                   (compare-package-derivations-url
-                    base-and-target-refs
-                    #:systems %systems-to-submit-builds-for)))
-                #:unwind? #t)
+              (call-with-data-service-error-handling
+               (lambda ()
+                 (compare-package-derivations
+                  (compare-package-cross-derivations-url
+                   base-and-target-refs
+                   #:systems %systems-to-submit-builds-for))))
               #f))
-         (derivation-changes
-          (if (and derivation-changes-data
-                   (not (assq-ref derivation-changes-data 'exception)))
+         (cross-derivation-changes-data
+          (if (and cross-derivation-changes-raw-data
+                   (not (assq-ref cross-derivation-changes-raw-data 'exception)))
               (derivation-changes
-               derivation-changes-data
+               cross-derivation-changes-raw-data
                %systems-to-submit-builds-for)
               #f))
          (builds-missing?
-          (if derivation-changes
+          (if derivation-changes-data
               (builds-missing-for-derivation-changes?
-               (assoc-ref derivation-changes-data
+               (assoc-ref derivation-changes-raw-data
                           "derivation_changes"))
               #t))
          (comparison-details
@@ -253,8 +273,9 @@
 
     (values
      base-and-target-refs
-     derivation-changes
-     (and=> derivation-changes-data
+     derivation-changes-data
+     cross-derivation-changes-data
+     (and=> derivation-changes-raw-data
             (lambda (changes)
               (alist-delete "derivation_changes" changes)))
      builds-missing?
@@ -300,6 +321,7 @@
             (lambda ()
               (let ((base-and-target-refs
                      derivation-changes
+                     cross-derivation-changes
                      change-details
                      builds-missing?
                      comparison-details
@@ -309,7 +331,7 @@
                       issue-data
                       #:args
                       (list issue-number)
-                      #:version 2
+                      #:version 3
                       #:ttl (/ frequency 2))))
 
                 (with-sqlite-cache
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index 4a45720..f397011 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -509,6 +509,7 @@
          (if series
              (let* ((base-and-target-refs
                      derivation-changes
+                     cross-derivation-changes
                      change-details
                      builds-missing?
                      comparison-details
@@ -518,7 +519,7 @@
                       issue-data
                       #:args
                       (list (string->number number))
-                      #:version 2
+                      #:version 3
                       #:ttl 6000))
                     (create-branch-for-issue-log
                      (select-create-branch-for-issue-log
@@ -549,6 +550,7 @@
                                          base-and-target-refs
                                          #:json? #f))
                                    derivation-changes
+                                   cross-derivation-changes
                                    builds-missing?
                                    change-details
                                    comparison-details
@@ -575,6 +577,7 @@ has no patches or has been closed.")
       (('GET "issue" number "package-changes")
        (let ((revisions
               derivation-changes
+              cross-derivation-changes
               substitute-availability
               up-to-date-with-master
               master-branch-systems-with-low-substitute-availability
@@ -584,7 +587,7 @@ has no patches or has been closed.")
                issue-data
                #:args
                (list (string->number number))
-               #:version 2
+               #:version 3
                #:ttl 6000)))
          (render-html
           #:sxml
@@ -595,9 +598,35 @@ has no patches or has been closed.")
                                         (uri-query (request-uri request))
                                         parse-query-string)
                                        '())))))
+      (('GET "issue" number "package-cross-changes")
+       (let ((revisions
+              derivation-changes
+              cross-derivation-changes
+              substitute-availability
+              up-to-date-with-master
+              master-branch-systems-with-low-substitute-availability
+              (with-sqlite-cache
+               database
+               'issue-data
+               issue-data
+               #:args
+               (list (string->number number))
+               #:version 3
+               #:ttl 6000)))
+         (render-html
+          #:sxml
+          (issue-package-cross-changes-view number
+                                            "x86_64-linux"
+                                            cross-derivation-changes
+                                            (or
+                                             (and=>
+                                              (uri-query (request-uri request))
+                                              parse-query-string)
+                                             '())))))
       (('GET "issue" number "prepare-review")
        (let ((revisions
               derivation-changes
+              cross-derivation-changes
               substitute-availability
               up-to-date-with-master
               master-branch-systems-with-low-substitute-availability
@@ -607,7 +636,7 @@ has no patches or has been closed.")
                issue-data
                #:args
                (list (string->number number))
-               #:version 2
+               #:version 3
                #:ttl 6000)))
          (render-html
           #:sxml
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index f7e83f9..e149cc4 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -11,6 +11,7 @@
   #:use-module (guix-qa-frontpage view shared)
   #:export (issue-view
             issue-package-changes-view
+            issue-package-cross-changes-view
 
             issue-prepare-review-view))
 
@@ -19,6 +20,7 @@
                     create-branch-for-issue-log
                     comparison-link
                     derivation-changes
+                    cross-derivation-changes
                     builds-missing?
                     change-details comparison-details
                     systems-with-low-substitute-availability)
@@ -32,6 +34,14 @@
   (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"))
@@ -189,7 +199,8 @@
                 (null? systems-with-low-substitute-availability)
                 (not comparison-details)
                 (assq-ref comparison-details 'exception)
-                (null? derivation-changes-counts))
+                (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.
@@ -219,6 +230,18 @@
             (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
@@ -363,6 +386,16 @@ div.bad {
    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
diff --git a/guix-qa-frontpage/view/shared.scm b/guix-qa-frontpage/view/shared.scm
index 3411224..3cf92b8 100644
--- a/guix-qa-frontpage/view/shared.scm
+++ b/guix-qa-frontpage/view/shared.scm
@@ -27,19 +27,177 @@
   #:use-module (guix-qa-frontpage manage-builds)
   #:use-module (guix-qa-frontpage view util)
   #:export (package-changes-view
-            package-changes-summary-table))
+            package-cross-changes-view
+            package-changes-summary-table
+            package-cross-changes-summary-table))
+
+(define (builds->overall-status builds)
+  (if (eq? #f 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)))
+              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-to-working
+    unknown-to-failing
+    unknown-to-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)
+          ((and (or (eq? 'unknown base-status)
+                    (eq? 'blocked base-status))
+                (eq? 'succeeding target-status))
+           'unknown-to-working)
+          ((and (or (eq? 'unknown base-status)
+                    (eq? 'blocked base-status))
+                (eq? 'failing target-status))
+           'unknown-to-failing)
+          ((and (eq? 'unknown base-status)
+                (eq? 'blocked target-status))
+           'unknown-to-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-to-working . "lightgreen")
+      (unknown-to-failing . "#FFCCCB")
+      (unknown-to-blocked . "lightyellow")
+      (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"
+                                   (uri-encode-filename
+                                    (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"
+                                   (uri-encode-filename
+                                    (assoc-ref derivations "target")))))
+                        "now " ,target-status))))))
+      '(td)))
 
 (define (package-changes-view title
                               derivation-changes
                               query-parameters)
-  (define (derivation-for-system side system)
+  (define (derivation-for-system derivations system)
     (vector-any
      (lambda (derivation)
        (if (string=? (assoc-ref derivation "system")
                      system)
            derivation
            #f))
-     side))
+     derivations))
 
   (define (builds-by-system base target)
     (map
@@ -73,162 +231,6 @@
                           (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-to-working
-      unknown-to-failing
-      unknown-to-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)
-            ((and (or (eq? 'unknown base-status)
-                      (eq? 'blocked base-status))
-                  (eq? 'succeeding target-status))
-             'unknown-to-working)
-            ((and (or (eq? 'unknown base-status)
-                      (eq? 'blocked base-status))
-                  (eq? 'failing target-status))
-             'unknown-to-failing)
-            ((and (eq? 'unknown base-status)
-                  (eq? 'blocked target-status))
-             'unknown-to-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-to-working . "lightgreen")
-        (unknown-to-failing . "#FFCCCB")
-        (unknown-to-blocked . "lightyellow")
-        (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"
-                                     (uri-encode-filename
-                                      (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"
-                                     (uri-encode-filename
-                                      (assoc-ref derivations "target")))))
-                          "now " ,target-status))))))
-        '(td)))
-
   (define grouped-query-parameters
     (group-to-alist
      identity
@@ -365,6 +367,214 @@
            '()
            (assoc-ref derivation-changes "derivation_changes"))))))))
 
+(define (package-cross-changes-view title
+                                    system
+                                    derivation-changes
+                                    query-parameters)
+  (define (derivation-for-target derivations target)
+    (vector-any
+     (lambda (derivation)
+       (if (string=? (assoc-ref derivation "target")
+                     target)
+           derivation
+           #f))
+     derivations))
+
+  ;; TODO This probably performs poorly when there are lots of changes
+  (define all-targets
+    (delete-duplicates!
+     (vector-fold-right
+      (lambda (_ result package-and-version)
+        (vector-fold-right
+         (lambda (_ result derivation)
+           (let ((target
+                  (assoc-ref derivation "target")))
+             (if (string-null? target)
+                 result
+                 (cons target result))))
+         (vector-fold-right
+          (lambda (_ result derivation)
+            (let ((target
+                   (assoc-ref derivation "target")))
+              (if (string-null? target)
+                  result
+                  (cons target result))))
+          result
+          (assoc-ref package-and-version "target"))
+         (assoc-ref package-and-version "base")))
+      '()
+      (assoc-ref derivation-changes "derivation_changes"))))
+
+  (define (builds-by-target base-data target-data)
+    (map
+     (lambda (target)
+       (cons
+        target
+        `(("base" . ,(and=>
+                      (derivation-for-target base-data target)
+                      (lambda (derivation)
+                        (vector->list
+                         (assoc-ref derivation "builds")))))
+          ("target" . ,(and=>
+                        (derivation-for-target target-data target)
+                        (lambda (derivation)
+                          (vector->list
+                           (assoc-ref derivation "builds"))))))))
+     all-targets))
+
+  (define (derivations-by-target base-data target-data)
+    (map
+     (lambda (target)
+       (cons
+        target
+        `(("base" . ,(and=>
+                      (derivation-for-target base-data target)
+                      (lambda (derivation)
+                        (assoc-ref derivation "derivation-file-name"))))
+          ("target" . ,(and=>
+                        (derivation-for-target target-data target)
+                        (lambda (derivation)
+                          (assoc-ref derivation "derivation-file-name")))))))
+     all-targets))
+
+  (define grouped-query-parameters
+    (group-to-alist
+     identity
+     query-parameters))
+
+  (define target-change
+    (map
+     (lambda (target)
+       (cons (string-append target "-change")
+             target))
+     all-targets))
+
+  (define (display? package-and-version change-by-target)
+    (every
+     (match-lambda
+       ((key . vals)
+        (cond
+         ((assoc-ref target-change key)
+          (let ((system (assoc-ref target-change key)))
+            (->bool
+             (member (assoc-ref change-by-target system)
+                     (map string->symbol vals)))))
+         (else #t))))
+     grouped-query-parameters))
+
+  (layout
+   #:title title
+   #:body
+   `((main
+      (@ (style "max-width: 98%;"))
+      (table
+       (form
+        (@ (id "filter-form")
+           (method "get"))
+        (thead
+         (tr
+          (td "Name")
+          (td "Version")
+          ,@(map
+             (lambda (target)
+               `(td (span (@ (style "font-size: 1.5em; font-family: monospace;"))
+                          ,target)
+                    (select
+                     (@ (name
+                         ,(simple-format #f "~A-change"
+                                         target))
+                        (style "margin-bottom: 0;")
+                        (multiple #t))
+                     ,@(let ((target-change-selected-options
+                              (or (assoc-ref
+                                   grouped-query-parameters
+                                   (string-append target "-change"))
+                                  '())))
+                         (map
+                          (match-lambda
+                            ((value . label)
+                             `(option
+                               (@ (value ,value)
+                                  ,@(if (member (symbol->string value)
+                                                target-change-selected-options)
+                                        '((selected ""))
+                                        '()))
+                               ,label)))
+                          (map
+                           (lambda (change)
+                             (cons change change))
+                           %changes))))
+                    (button
+                     (@ (type "submit")
+                        (style "padding: 0; width: 100%;"))
+                     "Update")))
+             all-targets))
+         (tr
+          (td)
+          (td)
+          ,@(map
+             (lambda (target)
+               (let* ((target-change-selected-options
+                       (or (assoc-ref
+                            grouped-query-parameters
+                            (string-append target "-change"))
+                           '()))
+                      (selected-labels
+                       (filter-map
+                        (match-lambda
+                          ((value . label)
+                           (if (member (symbol->string value)
+                                       target-change-selected-options)
+                               label
+                               #f)))
+                        (map
+                         (lambda (change)
+                           (cons change change))
+                         %changes))))
+                 (if (null? selected-labels)
+                     '(td)
+                     `(td
+                       "Filtering for:"
+                       (ul
+                        (@ (style "margin: 0;"))
+                        ,@(map (lambda (label)
+                                 `(li ,label))
+                               selected-labels))))))
+             all-targets))))
+       (tbody
+        (@ (style "overflow: auto; max-height: 40em;"))
+        ,@(vector-fold-right
+           (lambda (_ result package-and-version)
+             (let* ((builds
+                     (builds-by-target
+                      (assoc-ref package-and-version "base")
+                      (assoc-ref package-and-version "target")))
+                    (derivations
+                     (derivations-by-target
+                      (assoc-ref package-and-version "base")
+                      (assoc-ref package-and-version "target")))
+                    (change-by-target
+                     ;; This works, even though the naming is wrong as it's
+                     ;; being used to group builds by target
+                     (builds->change-by-system builds)))
+               (cons
+                `(tr
+                  (@ ,@(if (display? package-and-version
+                                     change-by-target)
+                           '()
+                           '((style "display: none;"))))
+                  (td ,(assoc-ref package-and-version "name"))
+                  (td ,(assoc-ref package-and-version "version"))
+                  ,@(map
+                     (lambda (target)
+                       (display-builds (assoc-ref builds target)
+                                       (assoc-ref derivations target)
+                                       (assoc-ref change-by-target target)))
+                     all-targets))
+                result)))
+           '()
+           (assoc-ref derivation-changes "derivation_changes"))))))))
+
 (define (package-changes-summary-table revisions
                                        derivation-changes-counts
                                        package-changes-url-prefix)
@@ -372,10 +582,17 @@
   (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"
+     (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A"
                     (assq-ref revisions 'base)
-                    (assq-ref revisions 'target)
-                    system)
+                    (assq-ref revisions 'target))
+     (match system
+       ((system . target)
+        (simple-format #f "&system=~A&target=~A"
+                       system
+                       target))
+       (system
+        (simple-format #f "&system=~A&target=none"
+                       system)))
      (if build-change
          (simple-format #f "&build_change=~A" build-change)
          "")))
@@ -545,3 +762,188 @@
                                               "target revision.")))))))))))
                             params)))
                         '()))))))))
+
+(define (package-cross-changes-summary-table revisions
+                                             cross-derivation-changes-counts
+                                             package-changes-url-prefix)
+
+  (define* (package-derivations-comparison-link system target
+                                                #:key build-change)
+    (string-append
+     (simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A"
+                    (assq-ref revisions 'base)
+                    (assq-ref revisions 'target))
+     (simple-format #f "&system=~A&target=~A"
+                    system
+                    target)
+     (if build-change
+         (simple-format #f "&build_change=~A" build-change)
+         "")))
+
+  `(table
+    (@ (style "border-collapse: collapse;"))
+    (thead
+     (tr
+      (th (@ (rowspan 3)) "Target")
+      (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 cross-derivation-changes-counts
+                (not (assq-ref cross-derivation-changes-counts 'exception)))
+           (if (null? cross-derivation-changes-counts)
+               `((tr
+                  (td (@ (colspan 7))
+                      "No package derivation changes")))
+               (map
+                (match-lambda
+                  (((system . target) . derivations)
+
+                   (define (count side status)
+                     (assoc-ref (assoc-ref
+                                 derivations
+                                 side)
+                                status))
+
+                   `(tr
+                     (td (@ (class "monospace")) ,target)
+                     ,@(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-cross-changes?"
+                                  target "-change=fixed&"
+                                  target "-change=still-working&"
+                                  target "-change=unknown-to-working&"
+                                  target "-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-cross-changes?"
+                                  target "-change=broken&"
+                                  target "-change=still-failing&"
+                                  target "-change=unknown-to-failing&"
+                                  target "-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-cross-changes?"
+                                  target "-change=blocked&"
+                                  target "-change=still-blocked&"
+                                  target "-change=unknown-to-blocked&"
+                                  target "-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-cross-changes?"
+                                  target "-change=unknown")))
+                            ,(count 'target 'unknown)))
+                     (td (a (@ (href
+                                ,(package-derivations-comparison-link system
+                                                                      target)))
+                            "View comparison")))))
+                cross-derivation-changes-counts))
+           `((tr
+              (td (@ (colspan 10)
+                     (class "bad"))
+                  "Comparison unavailable"
+                  ,@(or (and=>
+                         (assq-ref cross-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
+                                        ((eq? error 'unknown-commit)
+                                         (string-append
+                                          (if (string=? param "base_commit")
+                                              "Base revision "
+                                              "Target revision ")
+                                          "unknown to the data service."))
+                                        ((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")))
+                                        (else
+                                         (string-append
+                                          "Error with "
+                                          (if (string=? param "base_commit")
+                                              "base revision."
+                                              "target revision.")))))))))))
+                            params)))
+                        '()))))))))