Fetch and display package reproducibility information for branches

This involved some refactoring of branch data in general.

1 files changed, 99 insertions, 3 deletions

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))))))