challenge: Add '--verbose'.

* guix/scripts/challenge.scm (summarize-report): Add #:verbose?
parameter.
[report-hashes]: New procedure.  Use it.
Honor VERBOSE? in the 'match case.
(show-help, %options): Add '--verbose'.
(guix-challenge): Honor it.
This commit is contained in:
Ludovic Courtès 2017-01-14 00:03:32 +01:00
parent 4d8e95097e
commit 153b62957c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 37 additions and 16 deletions

View File

@ -6412,6 +6412,11 @@ The one option that matters is:
Consider @var{urls} the whitespace-separated list of substitute source Consider @var{urls} the whitespace-separated list of substitute source
URLs to compare to. URLs to compare to.
@item --verbose
@itemx -v
Show details about matches (identical contents) in addition to
information about mismatches.
@end table @end table
@node Invoking guix copy @node Invoking guix copy

View File

@ -180,28 +180,35 @@ taken since we do not import the archives."
local)))) local))))
(define* (summarize-report comparison-report (define* (summarize-report comparison-report
#:key (hash->string #:key
bytevector->nix-base32-string)) (hash->string bytevector->nix-base32-string)
verbose?)
"Write to the current error port a summary of REPORT, a <comparison-report> "Write to the current error port a summary of REPORT, a <comparison-report>
object." object. When VERBOSE?, display matches in addition to mismatches and
inconclusive reports."
(define (report-hashes item local narinfos)
(if local
(report (_ " local hash: ~a~%") (hash->string local))
(report (_ " no local build for '~a'~%") item))
(for-each (lambda (narinfo)
(report (_ " ~50a: ~a~%")
(uri->string (narinfo-uri narinfo))
(hash->string
(narinfo-hash->sha256 (narinfo-hash narinfo)))))
narinfos))
(match comparison-report (match comparison-report
(($ <comparison-report> item 'mismatch local (narinfos ...)) (($ <comparison-report> item 'mismatch local (narinfos ...))
(report (_ "~a contents differ:~%") item) (report (_ "~a contents differ:~%") item)
(if local (report-hashes item local narinfos))
(report (_ " local hash: ~a~%") (hash->string local))
(report (_ " no local build for '~a'~%") item))
(for-each (lambda (narinfo)
(report (_ " ~50a: ~a~%")
(uri->string (narinfo-uri narinfo))
(hash->string
(narinfo-hash->sha256 (narinfo-hash narinfo)))))
narinfos))
(($ <comparison-report> item 'inconclusive #f narinfos) (($ <comparison-report> item 'inconclusive #f narinfos)
(warning (_ "could not challenge '~a': no local build~%") item)) (warning (_ "could not challenge '~a': no local build~%") item))
(($ <comparison-report> item 'inconclusive locals ()) (($ <comparison-report> item 'inconclusive locals ())
(warning (_ "could not challenge '~a': no substitutes~%") item)) (warning (_ "could not challenge '~a': no substitutes~%") item))
(($ <comparison-report> item 'match) (($ <comparison-report> item 'match local (narinfos ...))
#t))) (when verbose?
(report (_ "~a contents match:~%") item)
(report-hashes item local narinfos)))))
;;; ;;;
@ -214,6 +221,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(display (_ " (display (_ "
--substitute-urls=URLS --substitute-urls=URLS
compare build results with those at URLS")) compare build results with those at URLS"))
(display (_ "
-v, --verbose show details about successful comparisons"))
(newline) (newline)
(display (_ " (display (_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
@ -237,6 +246,11 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(alist-cons 'substitute-urls (alist-cons 'substitute-urls
(string-tokenize arg) (string-tokenize arg)
(alist-delete 'substitute-urls result)) (alist-delete 'substitute-urls result))
rest)))
(option '("verbose" #\v) #f #f
(lambda (opt name arg result . rest)
(apply values
(alist-cons 'verbose? #t result)
rest))))) rest)))))
(define %default-options (define %default-options
@ -256,7 +270,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(_ #f)) (_ #f))
opts)) opts))
(system (assoc-ref opts 'system)) (system (assoc-ref opts 'system))
(urls (assoc-ref opts 'substitute-urls))) (urls (assoc-ref opts 'substitute-urls))
(verbose? (assoc-ref opts 'verbose?)))
(leave-on-EPIPE (leave-on-EPIPE
(with-store store (with-store store
;; Disable grafts since substitute servers normally provide only ;; Disable grafts since substitute servers normally provide only
@ -275,7 +290,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(mlet* %store-monad ((items (mapm %store-monad (mlet* %store-monad ((items (mapm %store-monad
ensure-store-item files)) ensure-store-item files))
(reports (compare-contents items urls))) (reports (compare-contents items urls)))
(for-each summarize-report reports) (for-each (cut summarize-report <> #:verbose? verbose?)
reports)
(exit (cond ((any comparison-report-mismatch? reports) 2) (exit (cond ((any comparison-report-mismatch? reports) 2)
((every comparison-report-match? reports) 0) ((every comparison-report-match? reports) 0)