From 6687339143d58afa0f26a674b24f83fab4a16556 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 30 Oct 2023 12:43:08 +0000 Subject: Add a reproducible-builds page to display data and issues Maybe this will be a useful starting point. --- Makefile.am | 1 + README.org | 2 +- guix-qa-frontpage/debbugs.scm | 16 ++++- guix-qa-frontpage/server.scm | 24 +++++++ guix-qa-frontpage/view/branch.scm | 92 ------------------------- guix-qa-frontpage/view/reproducible-builds.scm | 40 +++++++++++ guix-qa-frontpage/view/shared.scm | 95 +++++++++++++++++++++++++- 7 files changed, 175 insertions(+), 95 deletions(-) create mode 100644 guix-qa-frontpage/view/reproducible-builds.scm 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) - (stringoverall-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