ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

challenge: Return comparison reports instead of just discrepancies.

Browse source 
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

141
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 @@ (define-module (guix scripts challenge)
#: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-module (guix scripts challenge)
(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 @@ (define (query-locally-built-hash item)
(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 @@ (define (discrepancies items servers)
(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 @@ (define (select-reference item narinfos urls)
((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 @@ (define (select-reference item narinfos urls)
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
(if (every (compare item reference) local (list narinfo))
narinfos servers) (comparison-report item 'mismatch
#f local (list narinfo)))
(discrepancy item local narinfos)))) (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 items
local)))) local))))
(define* (summarize-discrepancy discrepancy (define* (summarize-report comparison-report
#:key (hash->string #:key (hash->string
bytevector->nix-base32-string)) bytevector->nix-base32-string))
"Write to the current error port a summary of DISCREPANCY, a <discrepancy> "Write to the current error port a summary of REPORT, a <comparison-report>
object that denotes a hash mismatch." object."
(match discrepancy (match comparison-report
(($ <discrepancy> item local (narinfos ...)) (($ <comparison-report> item 'mismatch 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)))))
(report (_ " ~50a: unavailable~%") narinfos))
(uri->string (narinfo-uri narinfo))))) (($ <comparison-report> item 'inconclusive #f narinfos)
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)))
;;; ;;;
@ -238,11 +274,12 @@ (define (guix-challenge . args)
(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 @@ (define-syntax with-derivation-narinfo*
(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 @@ (define-syntax with-derivation-narinfo*
(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: