diff options
Diffstat (limited to 'website')
| -rw-r--r-- | website/www/packages.scm | 83 |
1 files changed, 39 insertions, 44 deletions
diff --git a/website/www/packages.scm b/website/www/packages.scm index 397f953..42f6de0 100644 --- a/website/www/packages.scm +++ b/website/www/packages.scm @@ -476,25 +476,27 @@ PACKAGES." (string-append "https://mirror.hydra.gnu.org/nar/" (basename item))) -(define (discrepancy->sxml discrepancy) - "Return the HTML for DISCREPANCY." - (let ((item (discrepancy-item discrepancy))) +(define (comparison-report->sxml report) + "Return the HTML for REPORT." + (let ((item (comparison-report-item report))) `(li (tt ,item) (ol - (li (a (@ (href ,(local-nar-url item)))) - (tt ,(bytevector->base32-string - (discrepancy-local-sha256 discrepancy)))) - ,@(map (lambda (narinfo) - `(li (a (@ (href ,(uri->string - (narinfo-uri narinfo))))) - (tt ,(bytevector->base32-string - (narinfo-hash->sha256 - (narinfo-hash narinfo)))))) - (discrepancy-narinfos discrepancy)))))) - -(define* (package->reproducibility-sxml package discrepancies + ,(if (comparison-report-inconclusive? report) + "No idea if this one is reproducible." + `(li (a (@ (href ,(local-nar-url item)))) + (tt ,(bytevector->base32-string + (comparison-report-local-sha256 report))) + ,@(map (lambda (narinfo) + `(li (a (@ (href ,(uri->string + (narinfo-uri narinfo))))) + (tt ,(bytevector->base32-string + (narinfo-hash->sha256 + (narinfo-hash narinfo)))))) + (comparison-report-narinfos report)))))))) + +(define* (package->reproducibility-sxml package reports #:key anchor) - "Return an SXML representation of DISCREPANCIES for PACKAGE." + "Return an SXML representation of REPORTS for PACKAGE." (let ((name (string-append (package-name package) " " (package-version package)))) `(div @@ -507,16 +509,17 @@ PACKAGES." (title "Link to this section")) "ยง")) (p - ;; Issue count - ,@(if discrepancies - (list (issue-count->sxml (length discrepancies)) ". ") - '("No idea if it's reproducible. ")) + ,@(if (every comparison-report-inconclusive? reports) + '("No idea if it's reproducible. ") + (list (issue-count->sxml + (count comparison-report-mismatch? reports)) + ". ")) "See " (a (@ (href ,(source-url package))) "package definition") " in Guix source code.") - ,(and discrepancies + ,(and (any comparison-report-mismatch? reports) `(div (@ (class "issue")) - (ul ,@(map discrepancy->sxml discrepancies))))))) + (pre (ul ,@(map comparison-report->sxml reports)))))))) (define* (packages->reproducibility-sxml packages #:key (servers %substitute-servers)) @@ -527,12 +530,9 @@ PACKAGES on SERVERS." (define package-anchor (packages->anchors packages)) - (define valid? - (store-lift valid-path?)) - (define (one-of lst) - (lambda (discrepancy) - (member (discrepancy-item discrepancy) lst))) + (lambda (report) + (member (comparison-report-item report) lst))) (define (add-package-outputs package mapping) ;; Add PACKAGE to MAPPING, a vhash that maps packages to outputs. @@ -541,11 +541,7 @@ PACKAGES on SERVERS." (((_ . outputs) ...) outputs)))) (foldm %store-monad - (lambda (output result) - (mlet %store-monad ((valid? (valid? output))) - (return (if valid? - (vhash-consq package output mapping) - result)))) + (lift2 (cut vhash-consq package <> <>) %store-monad) mapping outputs))) @@ -557,26 +553,25 @@ PACKAGES on SERVERS." (cons output result)))) '() mapping)) - (result (discrepancies items %substitute-servers))) + (reports (compare-contents items + %substitute-servers))) (define (->sxml package) - (let* ((outputs (vhash-foldq* cons '() package mapping)) - (discrepancies (and (not (null? outputs)) - (filter (one-of outputs) result)))) - (package->reproducibility-sxml package - discrepancies + (let* ((outputs (vhash-foldq* cons '() package mapping)) + (reports (filter (one-of outputs) reports))) + (package->reproducibility-sxml package reports #:anchor (package-anchor package)))) - (let ((considered (vlist-length mapping))) - (return `(div "Considered " ,considered - " packages out of " ,total - ", corresponding to " ,(length items) " " + (let ((mismatches (count comparison-report-mismatch? reports))) + (return `(div "Considered " ,total + " packages, corresponding to " + ,(length items) " " (tt "/gnu/store") " items.\n" "Out of these, " - ,(issue-count->sxml (length result)) + ,(issue-count->sxml mismatches) " were found (" ,(inexact->exact - (round (* 100. (/ (length result) (length items))))) + (round (* 100. (/ mismatches (length items))))) "%).\n\n" ,@(map ->sxml packages)))))) |