summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-01-13 23:30:43 +0100
committerLudovic Courtès <ludo@gnu.org>2017-01-14 00:57:51 +0100
commit4d8e95097e5c40da9dd57d358bd189dcf82ff9bf (patch)
tree7b7961bd62ee8e64e0c7d35a7e5bb715266ab294 /guix
parent7988af99197c3d2f537608a46cab740a32d54e10 (diff)
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.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/challenge.scm161
1 files changed, 99 insertions, 62 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