challenge: Return comparison reports instead of just discrepancies.

This makes it easier to distinguish between matches, mismatches, and the
various cases of inconclusive reports.

* guix/scripts/challenge.scm (<discrepancy>): Rename to...
(<comparison-report>): ... this.  Add 'result' field.
(comparison-report): New macro.
(comparison-report-predicate, comparison-report-mismatch?)
(comparison-report-match?)
(comparison-report-inconclusive?): New procedures.
(discrepancies): Rename to...
(compare-contents): ... this.  Change to return a list of
<comparison-report>.  Remove calls to 'warning'.
(summarize-discrepancy): Rename to...
(summarize-report): ... this.  Adjust to <comparison-report>.
(guix-challenge): Likewise.
* tests/challenge.scm ("no discrepancies")
("one discrepancy"): Adjust to new API.
("inconclusive: no substitutes")
("inconclusive: no local build"): New tests.

2 files changed, 152 insertions, 71 deletions

diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 9ab4fbe2a9..f14e931d74 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,12 +37,17 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
   #:use-module (web uri)
-  #:export (discrepancies
+  #:export (compare-contents
 
-            discrepancy?
-            discrepancy-item
-            discrepancy-local-sha256
-            discrepancy-narinfos
+            comparison-report?
+            comparison-report-item
+            comparison-report-result
+            comparison-report-local-sha256
+            comparison-report-narinfos
+
+            comparison-report-match?
+            comparison-report-mismatch?
+            comparison-report-inconclusive?
 
             guix-challenge))
 
@@ -61,13 +66,38 @@
 (define ensure-store-item                         ;XXX: move to (guix ui)?
   (@@ (guix scripts size) ensure-store-item))
 
-;; Representation of a hash mismatch for ITEM.
-(define-record-type <discrepancy>
-  (discrepancy item local-sha256 narinfos)
-  discrepancy?
-  (item         discrepancy-item)                   ;string, /gnu/store/… item
-  (local-sha256 discrepancy-local-sha256)           ;bytevector | #f
-  (narinfos     discrepancy-narinfos))              ;list of <narinfo>
+;; Representation of a comparison report for ITEM.
+(define-record-type <comparison-report>
+  (%comparison-report item result local-sha256 narinfos)
+  comparison-report?
+  (item         comparison-report-item)    ;string, /gnu/store/… item
+  (result       comparison-report-result)  ;'match | 'mismatch | 'inconclusive
+  (local-sha256 comparison-report-local-sha256)   ;bytevector | #f
+  (narinfos     comparison-report-narinfos))      ;list of <narinfo>
+
+(define-syntax comparison-report
+  ;; Some sort of a an enum to make sure 'result' is correct.
+  (syntax-rules (match mismatch inconclusive)
+    ((_ item 'match rest ...)
+     (%comparison-report item 'match rest ...))
+    ((_ item 'mismatch rest ...)
+     (%comparison-report item 'mismatch rest ...))
+    ((_ item 'inconclusive rest ...)
+     (%comparison-report item 'inconclusive rest ...))))
+
+(define (comparison-report-predicate result)
+  "Return a predicate that returns true when pass a REPORT that has RESULT."
+  (lambda (report)
+    (eq? (comparison-report-result report) result)))
+
+(define comparison-report-mismatch?
+  (comparison-report-predicate 'mismatch))
+
+(define comparison-report-match?
+  (comparison-report-predicate 'match))
+
+(define comparison-report-inconclusive?
+  (comparison-report-predicate 'inconclusive))
 
 (define (locally-built? store item)
   "Return true if ITEM was built locally."
@@ -88,10 +118,10 @@ Otherwise return #f."
 (define-syntax-rule (report args ...)
   (format (current-error-port) args ...))
 
-(define (discrepancies items servers)
+(define (compare-contents items servers)
   "Challenge the substitute servers whose URLs are listed in SERVERS by
 comparing the hash of the substitutes of ITEMS that they serve.  Return the
-list of discrepancies.
+list of <comparison-report> objects.
 
 This procedure does not authenticate narinfos from SERVERS, nor does it verify
 that they are signed by an authorized public keys.  The reason is that, by
@@ -100,11 +130,7 @@ taken since we do not import the archives."
   (define (compare item reference)
     ;; Return a procedure to compare the hash of ITEM with REFERENCE.
     (lambda (narinfo url)
-      (if (not narinfo)
-          (begin
-            (warning (_ "~a: no substitute at '~a'~%")
-                     item url)
-            #t)
+      (or (not narinfo)
           (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
             (bytevector=? reference value)))))
 
@@ -116,9 +142,7 @@ taken since we do not import the archives."
          ((url urls ...)
           (if (not first)
               (select-reference item narinfos urls)
-              (narinfo-hash->sha256 (narinfo-hash first))))))
-      (()
-       (warning (_ "no substitutes for '~a'; cannot conclude~%") item))))
+              (narinfo-hash->sha256 (narinfo-hash first))))))))
 
   (mlet* %store-monad ((local     (mapm %store-monad
                                         query-locally-built-hash items))
@@ -130,42 +154,54 @@ taken since we do not import the archives."
                                                         vhash))
                                           vlist-null
                                           remote)))
-    (return (filter-map (lambda (item local)
-                          (let ((narinfos (vhash-fold* cons '() item narinfos)))
-                            (define reference
-                              (or local
-                                  (begin
-                                    (warning (_ "no local build for '~a'~%") item)
-                                    (select-reference item narinfos servers))))
-
-                            (if (every (compare item reference)
-                                       narinfos servers)
-                                #f
-                                (discrepancy item local narinfos))))
-                        items
-                        local))))
-
-(define* (summarize-discrepancy discrepancy
-                                #:key (hash->string
-                                       bytevector->nix-base32-string))
-  "Write to the current error port a summary of DISCREPANCY, a <discrepancy>
-object that denotes a hash mismatch."
-  (match discrepancy
-    (($ <discrepancy> item local (narinfos ...))
+    (return (map (lambda (item local)
+                   (match (vhash-fold* cons '() item narinfos)
+                     (()                          ;no substitutes
+                      (comparison-report item 'inconclusive local '()))
+                     ((narinfo)
+                      (if local
+                          (if ((compare item local) narinfo (first servers))
+                              (comparison-report item 'match
+                                                 local (list narinfo))
+                              (comparison-report item 'mismatch
+                                                 local (list narinfo)))
+                          (comparison-report item 'inconclusive
+                                             local (list narinfo))))
+                     ((narinfos ...)
+                      (let ((reference
+                             (or local (select-reference item narinfos
+                                                         servers))))
+                        (if (every (compare item reference) narinfos servers)
+                            (comparison-report item 'match
+                                               local narinfos)
+                            (comparison-report item 'mismatch
+                                               local narinfos))))))
+                 items
+                 local))))
+
+(define* (summarize-report comparison-report
+                           #:key (hash->string
+                                  bytevector->nix-base32-string))
+  "Write to the current error port a summary of REPORT, a <comparison-report>
+object."
+  (match comparison-report
+    (($ <comparison-report> item 'mismatch local (narinfos ...))
      (report (_ "~a contents differ:~%") item)
      (if local
          (report (_ "  local hash: ~a~%") (hash->string local))
-         (warning (_ "no local build for '~a'~%") item))
-
+         (report (_ "  no local build for '~a'~%") item))
      (for-each (lambda (narinfo)
-                 (if narinfo
-                     (report (_ "  ~50a: ~a~%")
-                             (uri->string (narinfo-uri narinfo))
-                             (hash->string
-                              (narinfo-hash->sha256 (narinfo-hash narinfo))))
-                     (report (_ "  ~50a: unavailable~%")
-                             (uri->string (narinfo-uri narinfo)))))
-               narinfos))))
+                 (report (_ "  ~50a: ~a~%")
+                         (uri->string (narinfo-uri narinfo))
+                         (hash->string
+                          (narinfo-hash->sha256 (narinfo-hash narinfo)))))
+               narinfos))
+    (($ <comparison-report> item 'inconclusive #f narinfos)
+     (warning (_ "could not challenge '~a': no local build~%") item))
+    (($ <comparison-report> item 'inconclusive locals ())
+     (warning (_ "could not challenge '~a': no substitutes~%") item))
+    (($ <comparison-report> item 'match)
+     #t)))
 
 
 ;;;
@@ -236,13 +272,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                                 #:use-substitutes? #f)
 
              (run-with-store store
-               (mlet* %store-monad ((items  (mapm %store-monad
-                                                  ensure-store-item files))
-                                    (issues (discrepancies items urls)))
-                 (for-each summarize-discrepancy issues)
-                 (unless (null? issues)
-                   (exit 2))
-                 (return (null? issues)))
+               (mlet* %store-monad ((items   (mapm %store-monad
+                                                   ensure-store-item files))
+                                    (reports (compare-contents items urls)))
+                 (for-each summarize-report reports)
+
+                 (exit (cond ((any comparison-report-mismatch? reports) 2)
+                             ((every comparison-report-match? reports) 0)
+                             (else 1))))
                #:system system))))))))
 
 ;;; challenge.scm ends here
diff --git a/tests/challenge.scm b/tests/challenge.scm
index 9505042a45..387d205a64 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -69,8 +69,15 @@
         (built-derivations (list drv))
         (mlet %store-monad ((hash (query-path-hash* out)))
           (with-derivation-narinfo* drv (sha256 => hash)
-            (>>= (discrepancies (list out) (%test-substitute-urls))
-                 (lift1 null? %store-monad))))))))
+            (>>= (compare-contents (list out) (%test-substitute-urls))
+                 (match-lambda
+                   ((report)
+                    (return
+                     (and (string=? out (comparison-report-item report))
+                          (bytevector=?
+                           (comparison-report-local-sha256 report)
+                           hash)
+                          (comparison-report-match? report))))))))))))
 
 (test-assertm "one discrepancy"
   (let ((text (random-text)))
@@ -90,20 +97,57 @@
                                                        (modulo (+ b 1) 128))
                                    w)))
           (with-derivation-narinfo* drv (sha256 => wrong-hash)
-            (>>= (discrepancies (list out) (%test-substitute-urls))
+            (>>= (compare-contents (list out) (%test-substitute-urls))
                  (match-lambda
-                   ((discrepancy)
+                   ((report)
                     (return
-                     (and (string=? out (discrepancy-item discrepancy))
+                     (and (string=? out (comparison-report-item (pk report)))
+                          (eq? 'mismatch (comparison-report-result report))
                           (bytevector=? hash
-                                        (discrepancy-local-sha256
-                                         discrepancy))
-                          (match (discrepancy-narinfos discrepancy)
+                                        (comparison-report-local-sha256
+                                         report))
+                          (match (comparison-report-narinfos report)
                             ((bad)
                              (bytevector=? wrong-hash
                                            (narinfo-hash->sha256
                                             (narinfo-hash bad))))))))))))))))
 
+(test-assertm "inconclusive: no substitutes"
+  (mlet* %store-monad ((drv  (gexp->derivation "foo" #~(mkdir #$output)))
+                       (out -> (derivation->output-path drv))
+                       (_    (built-derivations (list drv)))
+                       (hash (query-path-hash* out)))
+    (>>= (compare-contents (list out) (%test-substitute-urls))
+         (match-lambda
+           ((report)
+            (return
+             (and (string=? out (comparison-report-item report))
+                  (comparison-report-inconclusive? report)
+                  (null? (comparison-report-narinfos report))
+                  (bytevector=? (comparison-report-local-sha256 report)
+                                hash))))))))
+
+(test-assertm "inconclusive: no local build"
+  (let ((text (random-text)))
+    (mlet* %store-monad ((drv (gexp->derivation "something"
+                                                #~(list #$output #$text)))
+                         (out -> (derivation->output-path drv))
+                         (hash -> (sha256 #vu8())))
+      (with-derivation-narinfo* drv (sha256 => hash)
+        (>>= (compare-contents (list out) (%test-substitute-urls))
+             (match-lambda
+               ((report)
+                (return
+                 (and (string=? out (comparison-report-item report))
+                      (comparison-report-inconclusive? report)
+                      (not (comparison-report-local-sha256 report))
+                      (match (comparison-report-narinfos report)
+                        ((narinfo)
+                         (bytevector=? (narinfo-hash->sha256
+                                        (narinfo-hash narinfo))
+                                       hash))))))))))))
+
+
 (test-end)
 
 ;;; Local Variables: