From d6b53b0399534bd6d93bbd0688b4ff44f250f736 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 12 Jan 2017 23:37:23 +0100 Subject: website: packages: Add reproducibility page. * website/www/packages.scm (%substitute-servers): New variable. (local-nar-url, discrepancy->sxml) (package->reproducibility-sxml, packages->reproducibility-sxml) (reproducibility-page): New procedures. --- website/www/packages.scm | 160 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 157 insertions(+), 3 deletions(-) diff --git a/website/www/packages.scm b/website/www/packages.scm index 55d494e..397f953 100644 --- a/website/www/packages.scm +++ b/website/www/packages.scm @@ -1,5 +1,5 @@ ;;; GuixSD website --- GNU's advanced distro website -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin ;;; Copyright © 2013 Alex Sassmannshausen ;;; Initially written by Luis Felipe López Acevedo @@ -27,10 +27,17 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix licenses) + #:use-module (guix monads) + #:use-module (guix grafts) #:use-module (guix gnu-maintenance) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix base32) #:use-module ((guix download) #:select (%mirrors)) #:use-module ((guix build download) #:select (maybe-expand-mirrors)) #:use-module (guix scripts lint) + #:use-module (guix scripts challenge) + #:use-module (guix scripts substitute) #:use-module (gnu packages) #:use-module (sxml simple) #:use-module (sxml fold) @@ -49,6 +56,7 @@ package-pages paginated-packages-page issues-page + reproducibility-page packages->json)) (define lookup-gnu-package @@ -428,8 +436,8 @@ generated by CHECKERS." (p ;; Issue count ,(issue-count->sxml (length issues)) ". " - "See " (a (@ (href ,(source-url package))) "package definition ") - "in Guix source code.") + "See " (a (@ (href ,(source-url package))) "package definition") + " in Guix source code.") ,(issues->sxml package issues)))) @@ -455,6 +463,124 @@ PACKAGES." #:checkers checkers)) packages))) + +;;; +;;; Reproducibility issues reported by 'challenge'. +;;; + +(define %substitute-servers + ;; List of remote substitute servers against which we are comparing. + '("https://bayfront.guixsd.org")) + +(define (local-nar-url item) + (string-append "https://mirror.hydra.gnu.org/nar/" + (basename item))) + +(define (discrepancy->sxml discrepancy) + "Return the HTML for DISCREPANCY." + (let ((item (discrepancy-item discrepancy))) + `(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 + #:key anchor) + "Return an SXML representation of DISCREPANCIES for PACKAGE." + (let ((name (string-append (package-name package) " " + (package-version package)))) + `(div + (@ (class "issues-list")) + (h2 + (@ (id ,anchor)) + ,name + (a + (@ (class "anchor-link") (href ,(string-append "#" anchor)) + (title "Link to this section")) + "§")) + (p + ;; Issue count + ,@(if discrepancies + (list (issue-count->sxml (length discrepancies)) ". ") + '("No idea if it's reproducible. ")) + "See " (a (@ (href ,(source-url package))) "package definition") + " in Guix source code.") + + ,(and discrepancies + `(div (@ (class "issue")) + (ul ,@(map discrepancy->sxml discrepancies))))))) + +(define* (packages->reproducibility-sxml packages + #:key (servers %substitute-servers)) + "Return an SXML tree representing the discrepancies found in the outputs of +PACKAGES on SERVERS." + (define total (length packages)) + + (define package-anchor + (packages->anchors packages)) + + (define valid? + (store-lift valid-path?)) + + (define (one-of lst) + (lambda (discrepancy) + (member (discrepancy-item discrepancy) lst))) + + (define (add-package-outputs package mapping) + ;; Add PACKAGE to MAPPING, a vhash that maps packages to outputs. + (mlet* %store-monad ((drv (package->derivation package)) + (outputs -> (match (derivation->output-paths drv) + (((_ . outputs) ...) + outputs)))) + (foldm %store-monad + (lambda (output result) + (mlet %store-monad ((valid? (valid? output))) + (return (if valid? + (vhash-consq package output mapping) + result)))) + mapping + outputs))) + + (mlet* %store-monad ((mapping (foldm %store-monad add-package-outputs + vlist-null packages)) + (items -> (vlist-fold (lambda (item result) + (match item + ((_ . output) + (cons output result)))) + '() + mapping)) + (result (discrepancies 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 + #:anchor + (package-anchor package)))) + + (let ((considered (vlist-length mapping))) + (return `(div "Considered " ,considered + " packages out of " ,total + ", corresponding to " ,(length items) " " + (tt "/gnu/store") " items.\n" + "Out of these, " + ,(issue-count->sxml (length result)) + " were found (" + ,(inexact->exact + (round (* 100. (/ (length result) (length items))))) + "%).\n\n" + + ,@(map ->sxml packages)))))) + ;;; ;;; Pages. @@ -578,6 +704,34 @@ and PAGE is the corresponding SXML." ,(html-page-footer)))) +(define* (reproducibility-page) + `(html + (@ (lang "en")) + ,(html-page-header "Package Reproducibility" #:css "packages.css") + (body + ,(html-page-description) + ,(html-page-links) + + (div + (@ (id "content-box")) + (article + (h1 "Package Reproducibility") + (p "Which of our packages is not " + (a (@ (href "https://reproducible-builds.org")) + "reproducible") "? " + "This page lists problems reported by " + (a + (@ (href ,(base-url "manual/html_node/Invoking-guix-challenge.html"))) + (code "guix challenge")) " comparing two independent " + "build machines (" + "Updated " ,(date->string (current-date) "~B ~e, ~Y") ").") + + ,(parameterize ((%graft? #f)) + (with-store store + (run-with-store store + (packages->reproducibility-sxml (all-packages))))))) + + ,(html-page-footer)))) ;;; ;;; SXML Components -- cgit v1.2.3