1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix scripts challenge)
20 #:use-module (guix ui)
21 #:use-module (guix scripts)
22 #:use-module (guix store)
23 #:use-module (guix utils)
24 #:use-module (guix grafts)
25 #:use-module (guix monads)
26 #:use-module (guix base32)
27 #:use-module (guix packages)
28 #:use-module ((guix progress) #:hide (dump-port*))
29 #:use-module (guix serialization)
30 #:use-module (guix scripts substitute)
31 #:use-module (guix narinfo)
32 #:use-module (rnrs bytevectors)
33 #:autoload (guix http-client) (http-fetch)
34 #:use-module ((guix build syscalls) #:select (terminal-columns))
35 #:use-module (gcrypt hash)
36 #:use-module (srfi srfi-1)
37 #:use-module (srfi srfi-9)
38 #:use-module (srfi srfi-11)
39 #:use-module (srfi srfi-26)
40 #:use-module (srfi srfi-34)
41 #:use-module (srfi srfi-37)
42 #:use-module (ice-9 match)
43 #:use-module (ice-9 vlist)
44 #:use-module (ice-9 format)
45 #:use-module (ice-9 ftw)
46 #:use-module (web uri)
47 #:export (compare-contents
50 comparison-report-item
51 comparison-report-result
52 comparison-report-local-sha256
53 comparison-report-narinfos
55 comparison-report-match?
56 comparison-report-mismatch?
57 comparison-report-inconclusive?
66 ;;; Challenge substitute servers, checking whether they provide the same
67 ;;; binaries as those built locally.
69 ;;; Here we completely bypass the daemon to access substitutes. This is
70 ;;; because we want to be able to report fine-grain information about
71 ;;; discrepancies: We need to show the URL of the offending nar, its hash, and
76 (define ensure-store-item ;XXX: move to (guix ui)?
77 (@@ (guix scripts size) ensure-store-item))
79 ;; Representation of a comparison report for ITEM.
80 (define-record-type <comparison-report>
81 (%comparison-report item result local-sha256 narinfos)
83 (item comparison-report-item) ;string, /gnu/store/… item
84 (result comparison-report-result) ;'match | 'mismatch | 'inconclusive
85 (local-sha256 comparison-report-local-sha256) ;bytevector | #f
86 (narinfos comparison-report-narinfos)) ;list of <narinfo>
88 (define-syntax comparison-report
89 ;; Some sort of a an enum to make sure 'result' is correct.
90 (syntax-rules (match mismatch inconclusive)
91 ((_ item 'match rest ...)
92 (%comparison-report item 'match rest ...))
93 ((_ item 'mismatch rest ...)
94 (%comparison-report item 'mismatch rest ...))
95 ((_ item 'inconclusive rest ...)
96 (%comparison-report item 'inconclusive rest ...))))
98 (define (comparison-report-predicate result)
99 "Return a predicate that returns true when pass a REPORT that has RESULT."
101 (eq? (comparison-report-result report) result)))
103 (define comparison-report-mismatch?
104 (comparison-report-predicate 'mismatch))
106 (define comparison-report-match?
107 (comparison-report-predicate 'match))
109 (define comparison-report-inconclusive?
110 (comparison-report-predicate 'inconclusive))
112 (define (locally-built? store item)
113 "Return true if ITEM was built locally."
114 ;; XXX: For now approximate it by checking whether there's a build log for
115 ;; ITEM. There could be false negatives, if logs have been removed.
116 (->bool (log-file store item)))
118 (define (query-locally-built-hash item)
119 "Return the hash of ITEM, a store item, if ITEM was built locally.
120 Otherwise return #f."
122 (guard (c ((store-protocol-error? c)
124 (if (locally-built? store item)
125 (values (query-path-hash store item) store)
126 (values #f store)))))
128 (define-syntax-rule (report args ...)
129 (format (current-error-port) args ...))
131 (define (compare-contents items servers)
132 "Challenge the substitute servers whose URLs are listed in SERVERS by
133 comparing the hash of the substitutes of ITEMS that they serve. Return the
134 list of <comparison-report> objects.
136 This procedure does not authenticate narinfos from SERVERS, nor does it verify
137 that they are signed by an authorized public keys. The reason is that, by
138 definition, we may want to target unknown servers. Furthermore, no risk is
139 taken since we do not import the archives."
140 (define (compare item reference)
141 ;; Return a procedure to compare the hash of ITEM with REFERENCE.
142 (lambda (narinfo url)
144 (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
145 (bytevector=? reference value)))))
147 (define (select-reference item narinfos urls)
148 ;; Return a "reference" narinfo among NARINFOS.
150 ((first narinfos ...)
154 (select-reference item narinfos urls)
155 (narinfo-hash->sha256 (narinfo-hash first))))))))
157 (mlet* %store-monad ((local (mapm %store-monad
158 query-locally-built-hash items))
159 (remote -> (append-map (cut lookup-narinfos <> items)
161 ;; No 'assert-valid-narinfo' on purpose.
162 (narinfos -> (fold (lambda (narinfo vhash)
163 (vhash-cons (narinfo-path narinfo) narinfo
167 (return (map (lambda (item local)
168 (match (vhash-fold* cons '() item narinfos)
170 (comparison-report item 'inconclusive local '()))
173 (if ((compare item local) narinfo (first servers))
174 (comparison-report item 'match
175 local (list narinfo))
176 (comparison-report item 'mismatch
177 local (list narinfo)))
178 (comparison-report item 'inconclusive
179 local (list narinfo))))
182 (or local (select-reference item narinfos
184 (if (every (compare item reference) narinfos servers)
185 (comparison-report item 'match
187 (comparison-report item 'mismatch
197 (define (port-sha256* port size)
198 ;; Like 'port-sha256', but limited to SIZE bytes.
199 (let-values (((out get) (open-sha256-port)))
200 (dump-port* port out size)
204 (define (archive-contents port)
205 "Return a list representing the files contained in the nar read from PORT."
206 (fold-archive (lambda (file type contents result)
208 ((or 'regular 'executable)
211 (cons `(,file ,type ,(port-sha256* port size))
214 ('directory-complete result)
216 (cons `(,file ,type ,contents) result))))
221 (define (store-item-contents item)
222 "Return a list of files and contents for ITEM in the same format as
224 (file-system-fold (const #t) ;enter?
225 (lambda (file stat result) ;leaf
227 (string-drop file (string-length item)))
229 (match (stat:type stat)
231 (let ((size (stat:size stat))
232 (type (if (zero? (logand (stat:mode stat)
237 ,(call-with-input-file file
238 (cut port-sha256* <> size)))
241 (cons `(,short symlink ,(readlink file))
243 (lambda (directory stat result) result) ;down
244 (lambda (directory stat result) result) ;up
245 (lambda (file stat result) result) ;skip
246 (lambda (file stat errno result) result) ;error
251 (define (call-with-nar narinfo proc)
252 "Call PROC with an input port from which it can read the nar pointed to by
254 (let*-values (((uri compression size)
255 (narinfo-best-uri narinfo))
259 (progress-reporter/file (narinfo-path narinfo) size
260 #:abbreviation (const (uri-host uri))))
263 (call-with-decompressed-port (string->symbol compression)
264 (progress-report-port reporter port)
268 (erase-current-line (current-output-port))
271 (define (narinfo-contents narinfo)
272 "Fetch the nar described by NARINFO and return a list representing the file
274 (call-with-nar narinfo archive-contents))
276 (define (differing-files comparison-report)
277 "Return a list of files that differ among the nars and possibly the local
278 store item specified in COMPARISON-REPORT."
280 (map narinfo-contents
281 (comparison-report-narinfos comparison-report)))
283 (define local-contents
284 (and (comparison-report-local-sha256 comparison-report)
285 (store-item-contents (comparison-report-item comparison-report))))
287 (match (apply lset-difference equal?
288 (take (delete-duplicates
290 (cons local-contents contents)
296 (define (report-differing-files comparison-report)
297 "Report differences among the nars and possibly the local store item
298 specified in COMPARISON-REPORT."
299 (match (differing-files comparison-report)
303 (format #t (N_ " differing file:~%"
304 " differing files:~%"
306 (format #t "~{ ~a~%~}" files))))
308 (define (call-with-mismatches comparison-report proc)
309 "Call PROC with two directories containing the mismatching store items."
311 (comparison-report-local-sha256 comparison-report))
314 (comparison-report-narinfos comparison-report))
316 (call-with-temporary-directory
318 (call-with-temporary-directory
322 (find (lambda (narinfo)
323 (not (bytevector=? (narinfo-hash->sha256
324 (narinfo-hash narinfo))
327 (first (comparison-report-narinfos comparison-report))))
330 (and (not local-hash)
331 (find (lambda (narinfo)
332 (not (eq? narinfo narinfo1)))
336 (call-with-nar narinfo1 (cut restore-file <> directory1))
339 (call-with-nar narinfo2 (cut restore-file <> directory2)))
342 (comparison-report-item comparison-report)
345 (define %diffoscope-command
346 ;; Default external diff command. Pass "--exclude-directory-metadata" so
347 ;; that the mtime/ctime differences are ignored.
348 '("diffoscope" "--exclude-directory-metadata=yes"))
350 (define* (report-differing-files/external comparison-report
352 (command %diffoscope-command))
353 "Run COMMAND to show the file-level differences for the mismatches in
355 (call-with-mismatches comparison-report
356 (lambda (directory1 directory2)
359 (list directory1 directory2))))))
361 (define* (summarize-report comparison-report
363 (report-differences (const #f))
364 (hash->string bytevector->nix-base32-string)
366 "Write to the current error port a summary of COMPARISON-REPORT, a
367 <comparison-report> object. When VERBOSE?, display matches in addition to
368 mismatches and inconclusive reports. Upon mismatch, call REPORT-DIFFERENCES
369 with COMPARISON-REPORT."
370 (define (report-hashes item local narinfos)
372 (report (G_ " local hash: ~a~%") (hash->string local))
373 (report (G_ " no local build for '~a'~%") item))
374 (for-each (lambda (narinfo)
375 (report (G_ " ~50a: ~a~%")
376 (uri->string (narinfo-best-uri narinfo))
378 (narinfo-hash->sha256 (narinfo-hash narinfo)))))
381 (match comparison-report
382 (($ <comparison-report> item 'mismatch local (narinfos ...))
383 (report (G_ "~a contents differ:~%") item)
384 (report-hashes item local narinfos)
385 (report-differences comparison-report))
386 (($ <comparison-report> item 'inconclusive #f narinfos)
387 (warning (G_ "could not challenge '~a': no local build~%") item))
388 (($ <comparison-report> item 'inconclusive locals ())
389 (warning (G_ "could not challenge '~a': no substitutes~%") item))
390 (($ <comparison-report> item 'match local (narinfos ...))
392 (report (G_ "~a contents match:~%") item)
393 (report-hashes item local narinfos)))))
395 (define (summarize-report-list reports)
396 "Display the overall summary of REPORTS."
397 (let ((total (length reports))
398 (inconclusive (count comparison-report-inconclusive? reports))
399 (matches (count comparison-report-match? reports))
400 (discrepancies (count comparison-report-mismatch? reports)))
401 (report (G_ "~h store items were analyzed:~%") total)
402 (report (G_ " - ~h (~,1f%) were identical~%")
403 matches (* 100. (/ matches total)))
404 (report (G_ " - ~h (~,1f%) differed~%")
405 discrepancies (* 100. (/ discrepancies total)))
406 (report (G_ " - ~h (~,1f%) were inconclusive~%")
407 inconclusive (* 100. (/ inconclusive total)))))
411 ;;; Command-line options.
415 (display (G_ "Usage: guix challenge [PACKAGE...]
416 Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
418 --substitute-urls=URLS
419 compare build results with those at URLS"))
421 -v, --verbose show details about successful comparisons"))
423 --diff=MODE show differences according to MODE"))
426 -h, --help display this help and exit"))
428 -V, --version display version information and exit"))
430 (show-bug-report-information))
433 (list (option '(#\h "help") #f #f
437 (option '(#\V "version") #f #f
439 (show-version-and-exit "guix challenge")))
441 (option '("diff") #t #f
442 (lambda (opt name arg result . rest)
446 ("simple" report-differing-files)
447 ("diffoscope" report-differing-files/external)
448 ((and (? (cut string-prefix? "/" <>)) command)
449 (cute report-differing-files/external <>
450 (string-tokenize command)))
451 (_ (leave (G_ "~a: unknown diff mode~%") arg))))
454 (alist-cons 'difference-report mode result)
457 (option '("substitute-urls") #t #f
458 (lambda (opt name arg result . rest)
460 (alist-cons 'substitute-urls
461 (string-tokenize arg)
462 (alist-delete 'substitute-urls result))
464 (option '("verbose" #\v) #f #f
465 (lambda (opt name arg result . rest)
467 (alist-cons 'verbose? #t result)
470 (define %default-options
471 `((system . ,(%current-system))
472 (substitute-urls . ,%default-substitute-urls)
473 (difference-report . ,report-differing-files)))
480 (define-command (guix-challenge . args)
482 (synopsis "challenge substitute servers, comparing their binaries")
485 (let* ((opts (parse-command-line args %options (list %default-options)
486 #:build-options? #f))
487 (files (filter-map (match-lambda
488 (('argument . file) file)
491 (system (assoc-ref opts 'system))
492 (urls (assoc-ref opts 'substitute-urls))
493 (diff (assoc-ref opts 'difference-report))
494 (verbose? (assoc-ref opts 'verbose?)))
497 ;; Disable grafts since substitute servers normally provide only
499 (parameterize ((%graft? #f)
500 (current-terminal-columns (terminal-columns)))
501 (let ((files (match files
503 (filter (cut locally-built? store <>)
507 (set-build-options store
508 #:use-substitutes? #f)
510 (run-with-store store
511 (mlet* %store-monad ((items (mapm %store-monad
512 ensure-store-item files))
513 (reports (compare-contents items urls)))
514 (for-each (cut summarize-report <> #:verbose? verbose?
515 #:report-differences diff)
518 (summarize-report-list reports)
520 (exit (cond ((any comparison-report-mismatch? reports) 2)
521 ((every comparison-report-match? reports) 0)
523 #:system system))))))))
525 ;;; challenge.scm ends here