aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--guix/scripts/challenge.scm161
-rw-r--r--tests/challenge.scm62
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:
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-06 04:49:35 +0000