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".

1 files changed, 149 insertions, 7 deletions

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)