challenge: Add "--diff".

* guix/scripts/challenge.scm (dump-port*): New variable.
(archive-contents, store-item-contents, narinfo-contents)
(differing-files, report-differing-files): New procedures.
(summarize-report): Add #:report-differences and call it.
(show-help, %options): Add "--diff".
(%default-options): Add 'difference-report' key.
(report-differing-files): Parameterize CURRENT-TERMINAL-COLUMNS and pass
 #:report-differences to 'summarize-report'.
* guix/tests/http.scm (%local-url): Add optional argument.
(call-with-http-server): Fix docstring typo.
* tests/challenge.scm (query-path-size, make-narinfo): New procedures.
("differing-files"): New test.
* doc/guix.texi (Invoking guix challenge): Document "--diff".

4 files changed, 242 insertions, 11 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index cb51878004..80d67a44fa 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10321,14 +10321,23 @@ updating list of substitutes from 'https://guix.example.org'... 100.0%
   local hash: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
   https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-openssl-1.0.2d: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
   https://guix.example.org/nar/@dots{}-openssl-1.0.2d: 1zy4fmaaqcnjrzzajkdn3f5gmjk754b43qkq47llbyak9z0qjyim
+  differing files:
+    /lib/libcrypto.so.1.1
+    /lib/libssl.so.1.1
+
 /gnu/store/@dots{}-git-2.5.0 contents differ:
   local hash: 00p3bmryhjxrhpn2gxs2fy0a15lnip05l97205pgbk5ra395hyha
   https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0: 069nb85bv4d4a6slrwjdy8v1cn4cwspm3kdbmyb81d6zckj3nq9f
   https://guix.example.org/nar/@dots{}-git-2.5.0: 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73
+  differing file:
+    /libexec/git-core/git-fsck
+
 /gnu/store/@dots{}-pius-2.1.1 contents differ:
   local hash: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
   https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-pius-2.1.1: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
   https://guix.example.org/nar/@dots{}-pius-2.1.1: 1cy25x1a4fzq5rk0pmvc8xhwyffnqz95h2bpvqsz2mpvlbccy0gs
+  differing file:
+    /share/man/man1/pius.1.gz
 
 @dots{}
 
@@ -10414,6 +10423,21 @@ The one option that matters is:
 Consider @var{urls} the whitespace-separated list of substitute source
 URLs to compare to.
 
+@item --diff=@var{mode}
+Upon mismatches, show differences according to @var{mode}, one of:
+
+@table @asis
+@item @code{simple} (the default)
+Show the list of files that differ.
+
+@item @code{none}
+Do not show further details about the differences.
+@end table
+
+Thus, unless @code{--diff=none} is passed, @command{guix challenge}
+downloads the store items from the given substitute servers so that it
+can compare them.
+
 @item --verbose
 @itemx -v
 Show details about matches (identical contents) in addition to
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index aabb2ee549..277eec9a5d 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -25,17 +25,23 @@
   #:use-module (guix monads)
   #:use-module (guix base32)
   #:use-module (guix packages)
+  #:use-module (guix progress)
   #:use-module (guix serialization)
   #:use-module (guix scripts substitute)
   #:use-module (rnrs bytevectors)
+  #:autoload   (guix http-client) (http-fetch)
+  #:use-module ((guix build syscalls) #:select (terminal-columns))
+  #:use-module (gcrypt hash)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
   #:use-module (web uri)
   #:export (compare-contents
 
@@ -49,6 +55,8 @@
             comparison-report-mismatch?
             comparison-report-inconclusive?
 
+            differing-files
+
             guix-challenge))
 
 ;;; Commentary:
@@ -179,13 +187,128 @@ taken since we do not import the archives."
                  items
                  local))))
 
+
+;;;
+;;; Reporting.
+;;;
+
+(define dump-port*                                ;FIXME: deduplicate
+  (@@ (guix serialization) dump))
+
+(define (port-sha256* port size)
+  ;; Like 'port-sha256', but limited to SIZE bytes.
+  (let-values (((out get) (open-sha256-port)))
+    (dump-port* port out size)
+    (close-port out)
+    (get)))
+
+(define (archive-contents port)
+  "Return a list representing the files contained in the nar read from PORT."
+  (fold-archive (lambda (file type contents result)
+                  (match type
+                    ((or 'regular 'executable)
+                     (match contents
+                       ((port . size)
+                        (cons `(,file ,type ,(port-sha256* port size))
+                              result))))
+                    ('directory result)
+                    ('symlink
+                     (cons `(,file ,type ,contents) result))))
+                '()
+                port
+                ""))
+
+(define (store-item-contents item)
+  "Return a list of files and contents for ITEM in the same format as
+'archive-contents'."
+  (file-system-fold (const #t)                    ;enter?
+                    (lambda (file stat result)    ;leaf
+                      (define short
+                        (string-drop file (string-length item)))
+
+                      (match (stat:type stat)
+                        ('regular
+                         (let ((size (stat:size stat))
+                               (type (if (zero? (logand (stat:mode stat)
+                                                        #o100))
+                                         'regular
+                                         'executable)))
+                           (cons `(,short ,type
+                                          ,(call-with-input-file file
+                                             (cut port-sha256* <> size)))
+                                 result)))
+                        ('symlink
+                         (cons `(,short symlink ,(readlink file))
+                               result))))
+                    (lambda (directory stat result) result)  ;down
+                    (lambda (directory stat result) result)  ;up
+                    (lambda (file stat result) result)       ;skip
+                    (lambda (file stat errno result) result) ;error
+                    '()
+                    item
+                    lstat))
+
+(define (narinfo-contents narinfo)
+  "Fetch the nar described by NARINFO and return a list representing the file
+it contains."
+  (let*-values (((uri compression size)
+                 (narinfo-best-uri narinfo))
+                ((port response)
+                 (http-fetch uri)))
+    (define reporter
+      (progress-reporter/file (narinfo-path narinfo) size
+                              #:abbreviation (const (uri-host uri))))
+
+    (define result
+      (call-with-decompressed-port (string->symbol compression)
+          (progress-report-port reporter port)
+        archive-contents))
+
+    (close-port port)
+    (erase-current-line (current-output-port))
+    result))
+
+(define (differing-files comparison-report)
+  "Return a list of files that differ among the nars and possibly the local
+store item specified in COMPARISON-REPORT."
+  (define contents
+    (map narinfo-contents
+         (comparison-report-narinfos comparison-report)))
+
+  (define local-contents
+    (and (comparison-report-local-sha256 comparison-report)
+         (store-item-contents (comparison-report-item comparison-report))))
+
+  (match (apply lset-difference equal?
+                (take (delete-duplicates
+                       (if local-contents
+                           (cons local-contents contents)
+                           contents))
+                      2))
+    (((files _ ...) ...)
+     files)))
+
+(define (report-differing-files comparison-report)
+  "Report differences among the nars and possibly the local store item
+specified in COMPARISON-REPORT."
+  (match (differing-files comparison-report)
+    (()
+     #t)
+    ((files ...)
+     (format #t (N_ "  differing file:~%"
+                    "  differing files:~%"
+                    (length files)))
+     (format #t     "~{    ~a~%~}" files))))
+
 (define* (summarize-report comparison-report
                            #:key
+                           (report-differences (const #f))
                            (hash->string bytevector->nix-base32-string)
                            verbose?)
-  "Write to the current error port a summary of REPORT, a <comparison-report>
-object.  When VERBOSE?, display matches in addition to mismatches and
-inconclusive reports."
+  "Write to the current error port a summary of COMPARISON-REPORT, a
+<comparison-report> object.  When VERBOSE?, display matches in addition to
+mismatches and inconclusive reports.  Upon mismatch, call REPORT-DIFFERENCES
+with COMPARISON-REPORT."
   (define (report-hashes item local narinfos)
     (if local
         (report (G_ "  local hash: ~a~%") (hash->string local))
@@ -200,7 +323,8 @@ inconclusive reports."
   (match comparison-report
     (($ <comparison-report> item 'mismatch local (narinfos ...))
      (report (G_ "~a contents differ:~%") item)
-     (report-hashes item local narinfos))
+     (report-hashes item local narinfos)
+     (report-differences comparison-report))
     (($ <comparison-report> item 'inconclusive #f narinfos)
      (warning (G_ "could not challenge '~a': no local build~%") item))
     (($ <comparison-report> item 'inconclusive locals ())
@@ -237,6 +361,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                          compare build results with those at URLS"))
   (display (G_ "
       -v, --verbose      show details about successful comparisons"))
+  (display (G_ "
+          --diff=MODE    show differences according to MODE"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -254,6 +380,18 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                  (lambda args
                    (show-version-and-exit "guix challenge")))
 
+         (option '("diff") #t #f
+                 (lambda (opt name arg result . rest)
+                   (define mode
+                     (match arg
+                       ("none" (const #t))
+                       ("simple" report-differing-files)
+                       (_ (leave (G_ "~a: unknown diff mode~%") arg))))
+
+                   (apply values
+                          (alist-cons 'difference-report mode result)
+                          rest)))
+
          (option '("substitute-urls") #t #f
                  (lambda (opt name arg result . rest)
                    (apply values
@@ -269,7 +407,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
 
 (define %default-options
   `((system . ,(%current-system))
-    (substitute-urls . ,%default-substitute-urls)))
+    (substitute-urls . ,%default-substitute-urls)
+    (difference-report . ,report-differing-files)))
 
 
 ;;;
@@ -286,12 +425,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                                  opts))
            (system   (assoc-ref opts 'system))
            (urls     (assoc-ref opts 'substitute-urls))
+           (diff     (assoc-ref opts 'difference-report))
            (verbose? (assoc-ref opts 'verbose?)))
       (leave-on-EPIPE
        (with-store store
          ;; Disable grafts since substitute servers normally provide only
          ;; ungrafted stuff.
-         (parameterize ((%graft? #f))
+         (parameterize ((%graft? #f)
+                        (current-terminal-columns (terminal-columns)))
            (let ((files (match files
                           (()
                            (filter (cut locally-built? store <>)
@@ -305,7 +446,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                (mlet* %store-monad ((items   (mapm %store-monad
                                                    ensure-store-item files))
                                     (reports (compare-contents items urls)))
-                 (for-each (cut summarize-report <> #:verbose? verbose?)
+                 (for-each (cut summarize-report <> #:verbose? verbose?
+                                #:report-differences diff)
                            reports)
                  (report "\n")
                  (summarize-report-list reports)
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 05ce39bca2..4119e9ce01 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -65,14 +65,14 @@ needed."
            (close-port socket)
            #t)))
 
-(define (%local-url)
+(define* (%local-url #:optional (port (%http-server-port)))
   ;; URL to use for 'home-page' tests.
-  (string-append "http://localhost:" (number->string (%http-server-port))
+  (string-append "http://localhost:" (number->string port)
                  "/foo/bar"))
 
 (define* (call-with-http-server responses+data thunk)
   "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
-requests.  Each elements of RESPONSES+DATA must be a tuple containing a
+requests.  Each element of RESPONSES+DATA must be a tuple containing a
 response and a string, or an HTTP response code and a string."
   (define responses
     (map (match-lambda
diff --git a/tests/challenge.scm b/tests/challenge.scm
index c962800f3f..a2782abcbd 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,22 +18,32 @@
 
 (define-module (test-challenge)
   #:use-module (guix tests)
+  #:use-module (guix tests http)
   #:use-module (gcrypt hash)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix derivations)
+  #:use-module (guix serialization)
+  #:use-module (guix packages)
   #:use-module (guix gexp)
+  #:use-module (guix base32)
   #:use-module (guix scripts challenge)
   #:use-module (guix scripts substitute)
+  #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
   #:use-module (ice-9 match))
 
 (define query-path-hash*
   (store-lift query-path-hash))
 
+(define (query-path-size item)
+  (mlet %store-monad ((info (query-path-info* item)))
+    (return (path-info-nar-size info))))
+
 (define* (call-with-derivation-narinfo* drv thunk hash)
   (lambda (store)
     (with-derivation-narinfo drv (sha256 => hash)
@@ -138,7 +148,62 @@
                          (bytevector=? (narinfo-hash->sha256
                                         (narinfo-hash narinfo))
                                        hash))))))))))))
+(define (make-narinfo item size hash)
+  (format #f "StorePath: ~a
+Compression: none
+URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
+NarSize: ~d
+NarHash: sha256:~a
+References: ~%" item size (bytevector->nix-base32-string hash)))
 
+(test-assertm "differing-files"
+  ;; Pretend we have two different results for the same store item, ITEM,
+  ;; with "/bin/guile" differing between the two nars, and make sure
+  ;; 'differing-files' returns it.
+  (mlet* %store-monad
+      ((drv1 (package->derivation %bootstrap-guile))
+       (drv2 (gexp->derivation
+              "broken-guile"
+              (with-imported-modules '((guix build utils))
+                #~(begin
+                    (use-modules (guix build utils))
+                    (copy-recursively #$drv1 #$output)
+                    (chmod (string-append #$output "/bin/guile")
+                           #o755)
+                    (call-with-output-file (string-append
+                                            #$output
+                                            "/bin/guile")
+                      (lambda (port)
+                        (display "corrupt!" port)))))))
+       (out1 -> (derivation->output-path drv1))
+       (out2 -> (derivation->output-path drv2))
+       (item -> (string-append (%store-prefix) "/"
+                               (make-string 32 #\a) "-foo")))
+    (mbegin %store-monad
+      (built-derivations (list drv1 drv2))
+      (mlet* %store-monad ((size1 (query-path-size out1))
+                           (size2 (query-path-size out2))
+                           (hash1 (query-path-hash* out1))
+                           (hash2 (query-path-hash* out2))
+                           (nar1 -> (call-with-bytevector-output-port
+                                      (lambda (port)
+                                        (write-file out1 port))))
+                           (nar2 -> (call-with-bytevector-output-port
+                                      (lambda (port)
+                                        (write-file out2 port)))))
+        (parameterize ((%http-server-port 9000))
+          (with-http-server `((200 ,(make-narinfo item size1 hash1))
+                              (200 ,nar1))
+            (parameterize ((%http-server-port 9001))
+              (with-http-server `((200 ,(make-narinfo item size2 hash2))
+                                  (200 ,nar2))
+                (mlet* %store-monad ((urls -> (list (%local-url 9000)
+                                                    (%local-url 9001)))
+                                     (reports (compare-contents (list item)
+                                                                urls)))
+                  (pk 'report reports)
+                  (return (equal? (differing-files (car reports))
+                                  '("/bin/guile"))))))))))))
 
 (test-end)