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
;;; 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 @@ (define-module (guix scripts challenge)
#: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-module (guix scripts challenge)
(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 @@ (define (query-locally-built-hash item)
(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 @@ (define (discrepancies items servers)
(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 @@ (define (select-reference item narinfos urls)
((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 @@ (define (select-reference item narinfos urls)
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))))
(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-discrepancy discrepancy
(define* (summarize-report comparison-report
#: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 ...))
"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))))
(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)))
;;;
@ -238,11 +274,12 @@ (define (guix-challenge . args)
(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)))
(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

62
tests/challenge.scm
View file

@ -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 @@ (define-syntax with-derivation-narinfo*
(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 @@ (define-syntax with-derivation-narinfo*
(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: