nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2017-01-13 23:30:43 +01:00
parent 7988af9919
commit 4d8e95097e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 151 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

159
guix/scripts/challenge.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -37,12 +37,17 @@
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (web uri) #:use-module (web uri)
#:export (discrepancies #:export (compare-contents
discrepancy? comparison-report?
discrepancy-item comparison-report-item
discrepancy-local-sha256 comparison-report-result
discrepancy-narinfos comparison-report-local-sha256
comparison-report-narinfos
comparison-report-match?
comparison-report-mismatch?
comparison-report-inconclusive?
guix-challenge)) guix-challenge))
@ -61,13 +66,38 @@
(define ensure-store-item ;XXX: move to (guix ui)? (define ensure-store-item ;XXX: move to (guix ui)?
(@@ (guix scripts size) ensure-store-item)) (@@ (guix scripts size) ensure-store-item))
;; Representation of a hash mismatch for ITEM. ;; Representation of a comparison report for ITEM.
(define-record-type <discrepancy> (define-record-type <comparison-report>
(discrepancy item local-sha256 narinfos) (%comparison-report item result local-sha256 narinfos)
discrepancy? comparison-report?
(item discrepancy-item) ;string, /gnu/store/… item (item comparison-report-item) ;string, /gnu/store/… item
(local-sha256 discrepancy-local-sha256) ;bytevector | #f (result comparison-report-result) ;'match | 'mismatch | 'inconclusive
(narinfos discrepancy-narinfos)) ;list of <narinfo> (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) (define (locally-built? store item)
"Return true if ITEM was built locally." "Return true if ITEM was built locally."
@ -88,10 +118,10 @@ Otherwise return #f."
(define-syntax-rule (report args ...) (define-syntax-rule (report args ...)
(format (current-error-port) 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 "Challenge the substitute servers whose URLs are listed in SERVERS by
comparing the hash of the substitutes of ITEMS that they serve. Return the 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 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 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) (define (compare item reference)
;; Return a procedure to compare the hash of ITEM with REFERENCE. ;; Return a procedure to compare the hash of ITEM with REFERENCE.
(lambda (narinfo url) (lambda (narinfo url)
(if (not narinfo) (or (not narinfo)
(begin
(warning (_ "~a: no substitute at '~a'~%")
item url)
#t)
(let ((value (narinfo-hash->sha256 (narinfo-hash narinfo)))) (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
(bytevector=? reference value))))) (bytevector=? reference value)))))
@ -116,9 +142,7 @@ taken since we do not import the archives."
((url urls ...) ((url urls ...)
(if (not first) (if (not first)
(select-reference item narinfos urls) (select-reference item narinfos urls)
(narinfo-hash->sha256 (narinfo-hash first)))))) (narinfo-hash->sha256 (narinfo-hash first))))))))
(()
(warning (_ "no substitutes for '~a'; cannot conclude~%") item))))
(mlet* %store-monad ((local (mapm %store-monad (mlet* %store-monad ((local (mapm %store-monad
query-locally-built-hash items)) query-locally-built-hash items))
@ -130,42 +154,54 @@ taken since we do not import the archives."
vhash)) vhash))
vlist-null vlist-null
remote))) remote)))
(return (filter-map (lambda (item local) (return (map (lambda (item local)
(let ((narinfos (vhash-fold* cons '() item narinfos))) (match (vhash-fold* cons '() item narinfos)
(define reference (() ;no substitutes
(or local (comparison-report item 'inconclusive local '()))
(begin ((narinfo)
(warning (_ "no local build for '~a'~%") item) (if local
(select-reference item narinfos servers)))) (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))))
(if (every (compare item reference) (define* (summarize-report comparison-report
narinfos servers) #:key (hash->string
#f bytevector->nix-base32-string))
(discrepancy item local narinfos)))) "Write to the current error port a summary of REPORT, a <comparison-report>
items object."
local)))) (match comparison-report
(($ <comparison-report> item 'mismatch local (narinfos ...))
(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 ...))
(report (_ "~a contents differ:~%") item) (report (_ "~a contents differ:~%") item)
(if local (if local
(report (_ " local hash: ~a~%") (hash->string 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) (for-each (lambda (narinfo)
(if narinfo (report (_ " ~50a: ~a~%")
(report (_ " ~50a: ~a~%") (uri->string (narinfo-uri narinfo))
(uri->string (narinfo-uri narinfo)) (hash->string
(hash->string (narinfo-hash->sha256 (narinfo-hash narinfo)))))
(narinfo-hash->sha256 (narinfo-hash narinfo)))) narinfos))
(report (_ " ~50a: unavailable~%") (($ <comparison-report> item 'inconclusive #f narinfos)
(uri->string (narinfo-uri narinfo))))) (warning (_ "could not challenge '~a': no local build~%") item))
narinfos)))) (($ <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) #:use-substitutes? #f)
(run-with-store store (run-with-store store
(mlet* %store-monad ((items (mapm %store-monad (mlet* %store-monad ((items (mapm %store-monad
ensure-store-item files)) ensure-store-item files))
(issues (discrepancies items urls))) (reports (compare-contents items urls)))
(for-each summarize-discrepancy issues) (for-each summarize-report reports)
(unless (null? issues)
(exit 2)) (exit (cond ((any comparison-report-mismatch? reports) 2)
(return (null? issues))) ((every comparison-report-match? reports) 0)
(else 1))))
#:system system)))))))) #:system system))))))))
;;; challenge.scm ends here ;;; challenge.scm ends here

62
tests/challenge.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -69,8 +69,15 @@
(built-derivations (list drv)) (built-derivations (list drv))
(mlet %store-monad ((hash (query-path-hash* out))) (mlet %store-monad ((hash (query-path-hash* out)))
(with-derivation-narinfo* drv (sha256 => hash) (with-derivation-narinfo* drv (sha256 => hash)
(>>= (discrepancies (list out) (%test-substitute-urls)) (>>= (compare-contents (list out) (%test-substitute-urls))
(lift1 null? %store-monad)))))))) (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" (test-assertm "one discrepancy"
(let ((text (random-text))) (let ((text (random-text)))
@ -90,20 +97,57 @@
(modulo (+ b 1) 128)) (modulo (+ b 1) 128))
w))) w)))
(with-derivation-narinfo* drv (sha256 => wrong-hash) (with-derivation-narinfo* drv (sha256 => wrong-hash)
(>>= (discrepancies (list out) (%test-substitute-urls)) (>>= (compare-contents (list out) (%test-substitute-urls))
(match-lambda (match-lambda
((discrepancy) ((report)
(return (return
(and (string=? out (discrepancy-item discrepancy)) (and (string=? out (comparison-report-item (pk report)))
(eq? 'mismatch (comparison-report-result report))
(bytevector=? hash (bytevector=? hash
(discrepancy-local-sha256 (comparison-report-local-sha256
discrepancy)) report))
(match (discrepancy-narinfos discrepancy) (match (comparison-report-narinfos report)
((bad) ((bad)
(bytevector=? wrong-hash (bytevector=? wrong-hash
(narinfo-hash->sha256 (narinfo-hash->sha256
(narinfo-hash bad)))))))))))))))) (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) (test-end)
;;; Local Variables: ;;; Local Variables: