01/01: website: packages: Add reproducibility page.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix-artwork.

commit d6b53b0399534bd6d93bbd0688b4ff44f250f736
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jan 12 23:37:23 2017 +0100

    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 <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2015 Mathieu Lirzin <address@hidden>
 ;;; Copyright © 2013 Alex Sassmannshausen <address@hidden>
 ;;; Initially written by Luis Felipe López Acevedo <address@hidden>
@@ -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))))
 
@@ -457,6 +465,124 @@ 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