mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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
parent
7988af9919
commit
4d8e95097e
2 changed files with 151 additions and 70 deletions
|
|
@ -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))))
|
||||
(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))))
|
||||
|
||||
(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 ...))
|
||||
(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 @@ (define (guix-challenge . args)
|
|||
#: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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
Loading…
Reference in a new issue