diff options
Diffstat (limited to 'guix-qa-frontpage')
| -rw-r--r-- | guix-qa-frontpage/debbugs.scm | 16 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 24 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/branch.scm | 92 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/reproducible-builds.scm | 40 | ||||
| -rw-r--r-- | guix-qa-frontpage/view/shared.scm | 95 |
5 files changed, 173 insertions, 94 deletions
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)))))))) |