guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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.
wip-git-https
Ludovic Courtès 6 years ago
parent
7988af9919
commit
4d8e95097e
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
2 changed files with 152 additions and 71 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 161
      guix/scripts/challenge.scm
  2. 62
      tests/challenge.scm

161
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 @@
#: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

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 @@
(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:

Write Preview
Loading…
Cancel
Save