From afa6b13f6e3369f611917f5ffe5e0534c6cf4dc4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 29 Oct 2023 11:52:47 +0000 Subject: Fetch and display package reproducibility information for branches This involved some refactoring of branch data in general. --- guix-qa-frontpage/branch.scm | 47 +++++++++------ guix-qa-frontpage/guix-data-service.scm | 10 +++- guix-qa-frontpage/manage-builds.scm | 29 ++++----- guix-qa-frontpage/server.scm | 52 +++++++++------- guix-qa-frontpage/view/branch.scm | 102 +++++++++++++++++++++++++++++++- 5 files changed, 175 insertions(+), 65 deletions(-) (limited to 'guix-qa-frontpage') 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)))))) -- cgit v1.2.3