Fetch and display package reproducibility information for branches

This involved some refactoring of branch data in general.

5 files changed, 175 insertions, 65 deletions

diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm
index 016d544..125437e 100644
--- a/guix-qa-frontpage/branch.scm
+++ b/guix-qa-frontpage/branch.scm
@@ -227,32 +227,39 @@
              #:unwind? #t
              #:unwind-for-type &guix-data-service-error))
 
-          ;; TODO: Only include systems for which derivations are changed by
-          ;; this branch
-          (master-branch-systems-with-low-substitute-availability
-           (get-systems-with-low-substitute-availability
-            (master-branch-data)
-            (lset-difference
-             string=?
-             %systems-to-submit-builds-for
-             %systems-with-expected-low-substitute-availability))))
-
+          (package-reproducibility
+           (guix-data-service-request
+            (package-reproducibility-url branch-commit))))
      (values
       revisions
       derivation-changes-data
       substitute-availability
-      up-to-date-with-master?
-      master-branch-systems-with-low-substitute-availability))
+      package-reproducibility
+      up-to-date-with-master?))
 
-   (values #f #f #f #f #f)))
+   (values #f #f #f #f #f #f)))
 
 (define* (master-branch-data)
   (let* ((substitute-availability
           (package-substitute-availability
-           "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-substitute-availability.json")))
+           "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-substitute-availability.json"))
+
+         (package-reproducibility
+          (guix-data-service-request
+           "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-reproducibility.json"))
+
+         (systems-with-low-substitute-availability
+          (get-systems-with-low-substitute-availability
+           substitute-availability
+           (lset-difference
+            string=?
+            %systems-to-submit-builds-for
+            %systems-with-expected-low-substitute-availability))))
 
     (values
-     substitute-availability)))
+     substitute-availability
+     systems-with-low-substitute-availability
+     package-reproducibility)))
 
 (define* (get-systems-with-low-substitute-availability substitute-availability
                                                        systems
@@ -379,15 +386,15 @@
                    (let ((revisions
                           derivation-change-counts
                           substitute-availability
+                          package-reproducibility
                           up-to-date-with-master?
-                          master-branch-systems-with-low-substitute-availability
                           (with-sqlite-cache
                            database
                            'branch-data
                            branch-data
                            #:args
                            (list branch-name)
-                           #:version 2
+                           #:version 3
                            #:ttl (/ frequency 2))))
 
                      (unless (or (not substitute-availability)
@@ -402,12 +409,14 @@
        branches))
 
     (let ((master-branch-substitute-availability
+           master-branch-systems-with-low-substitute-availability
+           master-branch-package-reproducibility
            (with-sqlite-cache
             database
             'master-branch-data
             master-branch-data
-            #:ttl 0)))
-
+            #:ttl 0
+            #:version 2)))
       (update-branch-substitute-availability-metrics
        "master"
        master-branch-substitute-availability)))
diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm
index cd26518..7a01e7f 100644
--- a/guix-qa-frontpage/guix-data-service.scm
+++ b/guix-qa-frontpage/guix-data-service.scm
@@ -47,7 +47,9 @@
             revision-system-tests
 
             package-substitute-availability-url
-            package-substitute-availability))
+            package-substitute-availability
+
+            package-reproducibility-url))
 
 (define-exception-type &guix-data-service-error &error
   make-guix-data-service-error
@@ -298,3 +300,9 @@
     (if json-body
         (assoc-ref json-body "substitute_servers")
         #f)))
+
+(define* (package-reproducibility-url commit)
+  (simple-format
+   #f
+   "https://data.qa.guix.gnu.org/revision/~A/package-reproducibility.json"
+   commit))
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index 0658daf..4de85d1 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -203,19 +203,15 @@
          (lambda ()
            (with-throw-handler #t
              (lambda ()
-               (let* ((master-branch-substitute-availability
+               (let* ((substitute-availability
+                       systems-with-low-substitute-availability
+                       package-reproducibility
                        (with-sqlite-cache
                         database
                         'master-branch-data
                         master-branch-data
-                        #:ttl 6000))
-                      (systems-with-low-substitute-availability
-                       (get-systems-with-low-substitute-availability
-                        master-branch-substitute-availability
-                        (lset-difference
-                         string=?
-                         %systems-to-submit-builds-for
-                         %systems-with-expected-low-substitute-availability))))
+                        #:ttl 6000
+                        #:version 2)))
 
                  (if (null? systems-with-low-substitute-availability)
                      (call-with-duration-metric
@@ -415,20 +411,15 @@
         (unless (null? branches-with-builds-to-cancel)
           (cancel-branch-builds branches-with-builds-to-cancel)))
 
-      (let* ((master-branch-substitute-availability
+      (let* ((substitute-availability
+              systems-with-low-substitute-availability
+              package-reproducibility
               (with-sqlite-cache
                database
                'master-branch-data
                master-branch-data
-               #:ttl 6000))
-             (systems-with-low-substitute-availability
-              (get-systems-with-low-substitute-availability
-               master-branch-substitute-availability
-               (lset-difference
-                string=?
-                %systems-to-submit-builds-for
-                %systems-with-expected-low-substitute-availability))))
-
+               #:ttl 6000
+               #:version 2)))
         (if (null? systems-with-low-substitute-availability)
             (submit-builds branch-names)
             (simple-format
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index 9ae9bb1..ee3441d 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -154,49 +154,63 @@
           (branches-view branches))))
       (('GET "branch" "master")
        (let ((substitute-availability
+              systems-with-low-substitute-availability
+              package-reproducibility
               (with-sqlite-cache
                database
                'master-branch-data
                master-branch-data
-               #:ttl 6000)))
+               #:ttl 6000
+               #:version 2)))
          (render-html
           #:sxml
-          (master-branch-view substitute-availability))))
+          (master-branch-view substitute-availability
+                              package-reproducibility))))
       (('GET "branch" branch)
        (let ((revisions
               derivation-changes
               substitute-availability
+              package-reproducibility
               up-to-date-with-master
-              master-branch-systems-with-low-substitute-availability
               (with-sqlite-cache
                database
                'branch-data
                branch-data
                #:args
                (list branch)
-               #:version 2
-               #:ttl 6000)))
+               #:version 3
+               #:ttl 6000))
+             (master-branch-substitute-availability
+              master-branch-systems-with-low-substitute-availability
+              master-branch-package-reproducibility
+              (with-sqlite-cache
+               database
+               'master-branch-data
+               master-branch-data
+               #:ttl 6000
+               #:version 2)))
          (render-html
           #:sxml
           (branch-view branch
                        revisions
                        derivation-changes
                        substitute-availability
+                       package-reproducibility
                        up-to-date-with-master
                        master-branch-systems-with-low-substitute-availability))))
       (('GET "branch" branch "package-changes")
        (let ((revisions
               derivation-changes
               substitute-availability
+              package-reproducibility
               up-to-date-with-master
-              master-branch-systems-with-low-substitute-availability
               (with-sqlite-cache
                database
                'branch-data
                branch-data
                #:args
                (list branch)
-               #:version 2
+               #:version 3
                #:ttl 6000)))
          (render-html
           #:sxml
@@ -304,18 +318,14 @@
                           (< (first a)
                              (first b)))))))))
               (master-branch-substitute-availability
+               systems-with-low-substitute-availability
+               master-branch-package-reproducibility
                (with-sqlite-cache
                 database
                 'master-branch-data
                 master-branch-data
-                #:ttl 6000))
-              (systems-with-low-substitute-availability
-               (get-systems-with-low-substitute-availability
-                master-branch-substitute-availability
-                (lset-difference
-                 string=?
-                 %systems-to-submit-builds-for
-                 %systems-with-expected-low-substitute-availability))))
+                #:ttl 6000
+                #:version 2)))
          (render-html
           #:sxml
           (patches-view sorted-latest-series
@@ -573,18 +583,14 @@
                     (branch
                      (patchwork-series->branch series))
                     (master-branch-substitute-availability
+                     systems-with-low-substitute-availability
+                     master-branch-package-reproducibility
                      (with-sqlite-cache
                       database
                       'master-branch-data
                       master-branch-data
-                      #:ttl 6000))
-                    (systems-with-low-substitute-availability
-                     (get-systems-with-low-substitute-availability
-                      master-branch-substitute-availability
-                      (lset-difference
-                       string=?
-                       %systems-to-submit-builds-for
-                       %systems-with-expected-low-substitute-availability))))
+                      #:ttl 6000
+                      #:version 2)))
                (render-html
                 #:sxml (issue-view number
                                    series
diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
index 3170b06..9deaf61 100644
--- a/guix-qa-frontpage/view/branch.scm
+++ b/guix-qa-frontpage/view/branch.scm
@@ -13,8 +13,94 @@
 
             master-branch-view))
 
+(define (package-reproducibility-table package-reproducibility)
+  `(table
+    (thead
+     (tr
+      (th (@ (rowspan 2))
+          "System")
+      (th (@ (colspan 4))
+          "Package reproducibility"))
+     (tr (th "Matching")
+         (th "Not matching")
+         (th "Unknown")
+         (th (@ (style "min-width: 20em;")))))
+    (tbody
+     ,@(map
+        (match-lambda
+          ((system . details)
+           (let* ((matching
+                   (or (assoc-ref details "matching")
+                       0))
+                  (not-matching
+                   (or (assoc-ref details "not-matching")
+                       0))
+                  (unknown
+                   (or (assoc-ref details "unknown")
+                       0))
+                  (total
+                   (+ matching not-matching unknown))
+                  (matching-percent
+                   (round (/ (* 100 matching) total)))
+                  (not-matching-percent
+                   (round (/ (* 100 not-matching) total)))
+                  (unknown-percent
+                   (- 100 (+ matching-percent not-matching-percent))))
+             `(tr
+               (td
+                (@ (style "font-family: monospace;"))
+                ,system)
+               (td (a (@ (href
+                          ,(string-append
+                            "https://data.qa.guix.gnu.org/revision/"
+                            (assoc-ref package-reproducibility "commit")
+                            "/package-derivation-outputs"
+                            "?output_consistency=matching&system="
+                            system)))
+                      ,matching))
+               (td (a (@ (href
+                          ,(string-append
+                            "https://data.qa.guix.gnu.org/revision/"
+                            (assoc-ref package-reproducibility "commit")
+                            "/package-derivation-outputs"
+                            "?output_consistency=not-matching&system="
+                            system)))
+                      ,not-matching))
+               (td (a (@ (href
+                          ,(string-append
+                            "https://data.qa.guix.gnu.org/revision/"
+                            (assoc-ref package-reproducibility "commit")
+                            "/package-derivation-outputs"
+                            "?output_consistency=unknown&system="
+                            system)))
+                      ,unknown))
+               (td
+                (span (@ (style ,(string-append
+                                  "display: inline-block;"
+                                  "background-color: green;"
+                                  "padding: 0.5em 0 0.5em 0;"
+                                  (simple-format #f "width: ~A%;"
+                                                 matching-percent))))
+                      "")
+                (span (@ (style ,(string-append
+                                  "display: inline-block;"
+                                  "background-color: red;"
+                                  "padding: 0.5em 0 0.5em 0;"
+                                  (simple-format #f "width: ~A%;"
+                                                 not-matching-percent))))
+                      "")
+                (span (@ (style ,(string-append
+                                  "display: inline-block;"
+                                  "background-color: grey;"
+                                  "padding: 0.5em 0 0.5em 0;"
+                                  (simple-format #f "width: ~A%;"
+                                                 unknown-percent))))
+                      ""))))))
+        (assoc-ref package-reproducibility "systems")))))
+
 (define (branch-view branch revisions derivation-changes
                      substitute-availability
+                     package-reproducibility
                      up-to-date-with-master
                      master-branch-systems-with-low-substitute-availability)
   (define derivation-changes-counts
@@ -216,7 +302,13 @@ td.bad {
        ,(package-changes-summary-table
          revisions
          derivation-changes-counts
-         (string-append "/branch/" branch)))))))
+         (string-append "/branch/" branch)))
+
+      (h2 "Package reproducibility")
+       (div
+        ,(if package-reproducibility
+             (package-reproducibility-table package-reproducibility)
+             "Information unavailable"))))))
 
 (define* (delete-duplicates/sort! unsorted-lst less #:key (eq eq?))
   (if (null? unsorted-lst)
@@ -248,7 +340,8 @@ td.bad {
    derivation-changes
    query-parameters))
 
-(define (master-branch-view substitute-availability)
+(define (master-branch-view substitute-availability
+                            package-reproducibility)
   (layout
    #:title "Branch master"
    #:body
@@ -305,4 +398,7 @@ td.bad {
                       (assoc-ref details "target")))
                    (vector->list
                     (assoc-ref details "availability")))))))
-          (vector->list substitute-availability)))))))
+          (vector->list substitute-availability)))
+      (h2 "Package reproducibility")
+      (div
+       ,(package-reproducibility-table package-reproducibility))))))