Add a reproducible-builds page to display data and issues

Maybe this will be a useful starting point.

7 files changed, 175 insertions, 95 deletions

diff --git a/Makefile.am b/Makefile.am
index b0cc621..b0065d1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -47,6 +47,7 @@ SOURCES =									\
   guix-qa-frontpage/view/patches.scm						\
   guix-qa-frontpage/view/branch.scm						\
   guix-qa-frontpage/view/shared.scm						\
+  guix-qa-frontpage/view/reproducible-builds.scm				\
   guix-qa-frontpage/view/issue.scm
 
 README.html: README.org
diff --git a/README.org b/README.org
index a9e83f3..435868d 100644
--- a/README.org
+++ b/README.org
@@ -40,7 +40,7 @@ cached data to use.
 **** TODO Show broken system tests
 **** TODO Show broken fixed output package derivations
 **** TODO Show new lint warnings
-*** TODO Show package reproducibility statistics
+*** DONE Show package reproducibility statistics
 
 This will provide a better URL and faster page load times compared to
 directly going to data.guix.gnu.org or data.qa.guix.gnu.org.
diff --git a/guix-qa-frontpage/debbugs.scm b/guix-qa-frontpage/debbugs.scm
index ea37e13..656865d 100644
--- a/guix-qa-frontpage/debbugs.scm
+++ b/guix-qa-frontpage/debbugs.scm
@@ -18,8 +18,22 @@
 
 (define-module (guix-qa-frontpage debbugs)
   #:use-module (debbugs)
-  #:export (debbugs-get-issues-with-guix-usertag))
+  #:use-module (guix-qa-frontpage mumi)
+  #:export (debbugs-get-issues-with-guix-usertag
+
+            fetch-issues-with-guix-tag))
 
 (define (debbugs-get-issues-with-guix-usertag)
   (soap-invoke (%gnu) get-usertag "guix"))
 
+(define (fetch-issues-with-guix-tag tag)
+  (define issues
+    (let ((data (assoc-ref (debbugs-get-issues-with-guix-usertag)
+                           tag)))
+      (if (number? data)
+          (list data)
+          data)))
+
+  (map cons
+       issues
+       (mumi-bulk-issues issues)))
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index ee3441d..f401fe2 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -48,6 +48,7 @@
   #:use-module (guix-qa-frontpage derivation-changes)
   #:use-module (guix-qa-frontpage patchwork)
   #:use-module (guix-qa-frontpage mumi)
+  #:use-module (guix-qa-frontpage debbugs)
   #:use-module (guix-qa-frontpage branch)
   #:use-module (guix-qa-frontpage issue)
   #:use-module (guix-qa-frontpage git-repository)
@@ -60,6 +61,7 @@
   #:use-module (guix-qa-frontpage view branches)
   #:use-module (guix-qa-frontpage view branch)
   #:use-module (guix-qa-frontpage view issue)
+  #:use-module (guix-qa-frontpage view reproducible-builds)
   #:export (start-guix-qa-frontpage))
 
 (define (branch-for-issue database issue-number)
@@ -700,6 +702,28 @@ has no patches or has been closed.")
                                        (uri-query (request-uri request))
                                        parse-query-string)
                                       '())))))
+      (('GET "reproducible-builds")
+       (let ((issue-data
+              (with-sqlite-cache
+               database
+               'fetch-issues-with-guix-tag
+               fetch-issues-with-guix-tag
+               #:ttl 3000
+               #:args '("reproducibility")))
+             (substitute-availability
+              systems-with-low-substitute-availability
+              package-reproducibility
+              (with-sqlite-cache
+               database
+               'master-branch-data
+               master-branch-data
+               #:ttl 6000
+               #:version 2)))
+         (render-html
+          #:sxml
+          (reproducible-builds-view package-reproducibility
+                                    issue-data))))
+
       (('GET "README")
        (let ((filename (string-append doc-dir "/README.html")))
          (if (file-exists? filename)
diff --git a/guix-qa-frontpage/view/branch.scm b/guix-qa-frontpage/view/branch.scm
index 6914586..b1701e2 100644
--- a/guix-qa-frontpage/view/branch.scm
+++ b/guix-qa-frontpage/view/branch.scm
@@ -13,98 +13,6 @@
 
             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))))
-                      ""))))))
-        (sort
-         (filter
-          (match-lambda
-            ((system . _)
-             (not (member system '("powerpc-linux" "mips64el-linux")))))
-          (assoc-ref package-reproducibility "systems"))
-         (lambda (a b)
-           (string<? (car a) (car b))))))))
-
 (define (branch-view branch revisions derivation-changes
                      substitute-availability
                      package-reproducibility
diff --git a/guix-qa-frontpage/view/reproducible-builds.scm b/guix-qa-frontpage/view/reproducible-builds.scm
new file mode 100644
index 0000000..b39f092
--- /dev/null
+++ b/guix-qa-frontpage/view/reproducible-builds.scm
@@ -0,0 +1,40 @@
+(define-module (guix-qa-frontpage view reproducible-builds)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 string-fun)
+  #:use-module (guix-qa-frontpage view util)
+  #:use-module (guix-qa-frontpage view shared)
+  #:export (reproducible-builds-view))
+
+(define (reproducible-builds-view package-reproducibility
+                                  issue-data)
+  (layout
+   #:title "Reproducible builds"
+   #:body
+   `((main
+      (p "The following table gives an overview of packages that can be built
+reproducibly, as well as known issues.  All data is from the master branch.")
+
+      ,(package-reproducibility-table package-reproducibility)
+
+      (h3 "Issues")
+      (table
+       (thead
+        (tr
+         (th "Issue")
+         (th "Title")
+         (th "Status")))
+       (tbody
+        ,@(map
+           (match-lambda
+             ((issue-number . details)
+              `(tr
+                (td (a (@ (href
+                           ,(simple-format #f "https://issues.guix.gnu.org/~A"
+                                           issue-number)))
+                       ,issue-number))
+                (td ,(assq-ref details 'title))
+                (td ,(if (assq-ref details 'open?)
+                         "Open"
+                         "Closed")))))
+           issue-data)))))))
diff --git a/guix-qa-frontpage/view/shared.scm b/guix-qa-frontpage/view/shared.scm
index 3cf92b8..e1f26ab 100644
--- a/guix-qa-frontpage/view/shared.scm
+++ b/guix-qa-frontpage/view/shared.scm
@@ -29,7 +29,8 @@
   #:export (package-changes-view
             package-cross-changes-view
             package-changes-summary-table
-            package-cross-changes-summary-table))
+            package-cross-changes-summary-table
+            package-reproducibility-table))
 
 (define (builds->overall-status builds)
   (if (eq? #f builds)
@@ -947,3 +948,95 @@
                                               "target revision.")))))))))))
                             params)))
                         '()))))))))
+
+(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))))
+                      ""))))))
+        (sort
+         (filter
+          (match-lambda
+            ((system . _)
+             (not (member system '("powerpc-linux" "mips64el-linux")))))
+          (assoc-ref package-reproducibility "systems"))
+         (lambda (a b)
+           (string<? (car a) (car b))))))))