diff options
| -rw-r--r-- | guix/scripts/challenge.scm | 86 |
1 files changed, 56 insertions, 30 deletions
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index cc706d6e37..143d856e47 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -25,6 +25,7 @@ #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) + #:use-module (guix progress) #:use-module (guix serialization) #:use-module (guix scripts substitute) #:use-module (gnu packages) @@ -66,7 +67,10 @@ ;;; Code: (define ensure-store-item ;XXX: move to (guix ui)? - (@@ (guix scripts size) ensure-store-item)) + (lambda args + (display ".") + (force-output) + (apply (@@ (guix scripts size) ensure-store-item) args))) ;; Representation of a comparison report for ITEM. (define-record-type <comparison-report> @@ -148,7 +152,14 @@ taken since we do not import the archives." (mlet* %store-monad ((local (mapm %store-monad query-locally-built-hash items)) - (remote -> (append-map (cut lookup-narinfos <> items) + (remote -> (append-map (lambda args + (let ((foo + (apply + (cut lookup-narinfos <> items) + args))) + (peek args) + (simple-format #t "\nfoo: ~A \n\n" (length foo)) + foo)) servers)) ;; No 'assert-valid-narinfo' on purpose. (narinfos -> (fold (lambda (narinfo vhash) @@ -156,30 +167,41 @@ taken since we do not import the archives." vhash)) vlist-null remote))) - (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)))) + (return ;;(call-with-progress-reporter (progress-reporter/bar (length items)) + ;;(lambda (report) + (map (lambda (item local) + ;;(report) + (display (length (vhash-fold* cons '() item narinfos))) + (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)))) + (when (= (length narinfos) 3) + (for-each + (lambda (narinfo) + (simple-format #t "\nnarinfos: ~A\n" + (narinfo-path narinfo))) + narinfos)) + + (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 @@ -201,10 +223,12 @@ inconclusive reports." (match comparison-report (($ <comparison-report> item 'mismatch local (narinfos ...)) - (report (G_ "~a contents differ:~%") item) - (report-hashes item local narinfos)) + ;;(report (G_ "~a contents differ:~%") item) + ;;(report-hashes item local narinfos) + #f) (($ <comparison-report> item 'inconclusive #f narinfos) - (warning (G_ "could not challenge '~a': no local build~%") item)) + ;;(warning (G_ "could not challenge '~a': no local build~%") item) + #f) (($ <comparison-report> item 'inconclusive locals ()) (warning (G_ "could not challenge '~a': no substitutes~%") item)) (($ <comparison-report> item 'match local (narinfos ...)) @@ -338,7 +362,9 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (run-with-store store (mlet* %store-monad ((items (mapm %store-monad ensure-store-item files)) - (reports (compare-contents items urls))) + (reports (compare-contents + (delete-duplicates items string=?) + urls))) (if export? (begin (report (scm->json-string |