1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 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 substitutes)
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)
260 (max size (or actual-size 0)) ;defensive
261 #:abbreviation (const (uri-host uri))))
264 (call-with-decompressed-port (string->symbol compression)
265 (progress-report-port reporter port)
269 (erase-current-line (current-output-port))
272 (define (narinfo-contents narinfo)
273 "Fetch the nar described by NARINFO and return a list representing the file
275 (call-with-nar narinfo archive-contents))
277 (define (differing-files comparison-report)
278 "Return a list of files that differ among the nars and possibly the local
279 store item specified in COMPARISON-REPORT."
281 (map narinfo-contents
282 (comparison-report-narinfos comparison-report)))
284 (define local-contents
285 (and (comparison-report-local-sha256 comparison-report)
286 (store-item-contents (comparison-report-item comparison-report))))
288 (match (apply lset-difference equal?
289 (take (delete-duplicates
291 (cons local-contents contents)
297 (define (report-differing-files comparison-report)
298 "Report differences among the nars and possibly the local store item
299 specified in COMPARISON-REPORT."
300 (match (differing-files comparison-report)
304 (format #t (N_ " differing file:~%"
305 " differing files:~%"
307 (format #t "~{ ~a~%~}" files))))
309 (define (call-with-mismatches comparison-report proc)
310 "Call PROC with two directories containing the mismatching store items."
312 (comparison-report-local-sha256 comparison-report))
315 (comparison-report-narinfos comparison-report))
317 (call-with-temporary-directory
319 (call-with-temporary-directory
323 (find (lambda (narinfo)
324 (not (bytevector=? (narinfo-hash->sha256
325 (narinfo-hash narinfo))
328 (first (comparison-report-narinfos comparison-report))))
331 (and (not local-hash)
332 (find (lambda (narinfo)
333 (not (eq? narinfo narinfo1)))
337 (call-with-nar narinfo1 (cut restore-file <> directory1))
340 (call-with-nar narinfo2 (cut restore-file <> directory2)))
343 (comparison-report-item comparison-report)
346 (define %diffoscope-command
347 ;; Default external diff command. Pass "--exclude-directory-metadata" so
348 ;; that the mtime/ctime differences are ignored.
349 '("diffoscope" "--exclude-directory-metadata=yes"))
351 (define* (report-differing-files/external comparison-report
353 (command %diffoscope-command))
354 "Run COMMAND to show the file-level differences for the mismatches in
356 (call-with-mismatches comparison-report
357 (lambda (directory1 directory2)
360 (list directory1 directory2))))))
362 (define* (summarize-report comparison-report
364 (report-differences (const #f))
365 (hash->string bytevector->nix-base32-string)
367 "Write to the current error port a summary of COMPARISON-REPORT, a
368 <comparison-report> object. When VERBOSE?, display matches in addition to
369 mismatches and inconclusive reports. Upon mismatch, call REPORT-DIFFERENCES
370 with COMPARISON-REPORT."
371 (define (report-hashes item local narinfos)
373 (report (G_ " local hash: ~a~%") (hash->string local))
374 (report (G_ " no local build for '~a'~%") item))
375 (for-each (lambda (narinfo)
376 (report (G_ " ~50a: ~a~%")
377 (uri->string (narinfo-best-uri narinfo))
379 (narinfo-hash->sha256 (narinfo-hash narinfo)))))
382 (match comparison-report
383 (($ <comparison-report> item 'mismatch local (narinfos ...))
384 (report (G_ "~a contents differ:~%") item)
385 (report-hashes item local narinfos)
386 (report-differences comparison-report))
387 (($ <comparison-report> item 'inconclusive #f narinfos)
388 (warning (G_ "could not challenge '~a': no local build~%") item))
389 (($ <comparison-report> item 'inconclusive locals ())
390 (warning (G_ "could not challenge '~a': no substitutes~%") item))
391 (($ <comparison-report> item 'match local (narinfos ...))
393 (report (G_ "~a contents match:~%") item)
394 (report-hashes item local narinfos)))))
396 (define (summarize-report-list reports)
397 "Display the overall summary of REPORTS."
398 (let ((total (length reports))
399 (inconclusive (count comparison-report-inconclusive? reports))
400 (matches (count comparison-report-match? reports))
401 (discrepancies (count comparison-report-mismatch? reports)))
402 (report (G_ "~h store items were analyzed:~%") total)
403 (report (G_ " - ~h (~,1f%) were identical~%")
404 matches (* 100. (/ matches total)))
405 (report (G_ " - ~h (~,1f%) differed~%")
406 discrepancies (* 100. (/ discrepancies total)))
407 (report (G_ " - ~h (~,1f%) were inconclusive~%")
408 inconclusive (* 100. (/ inconclusive total)))))
412 ;;; Command-line options.
416 (display (G_ "Usage: guix challenge [PACKAGE...]
417 Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
419 --substitute-urls=URLS
420 compare build results with those at URLS"))
422 -v, --verbose show details about successful comparisons"))
424 --diff=MODE show differences according to MODE"))
427 -h, --help display this help and exit"))
429 -V, --version display version information and exit"))
431 (show-bug-report-information))
434 (list (option '(#\h "help") #f #f
438 (option '(#\V "version") #f #f
440 (show-version-and-exit "guix challenge")))
442 (option '("diff") #t #f
443 (lambda (opt name arg result . rest)
447 ("simple" report-differing-files)
448 ("diffoscope" report-differing-files/external)
449 ((and (? (cut string-prefix? "/" <>)) command)
450 (cute report-differing-files/external <>
451 (string-tokenize command)))
452 (_ (leave (G_ "~a: unknown diff mode~%") arg))))
455 (alist-cons 'difference-report mode result)
458 (option '("substitute-urls") #t #f
459 (lambda (opt name arg result . rest)
461 (alist-cons 'substitute-urls
462 (string-tokenize arg)
463 (alist-delete 'substitute-urls result))
465 (option '("verbose" #\v) #f #f
466 (lambda (opt name arg result . rest)
468 (alist-cons 'verbose? #t result)
471 (define %default-options
472 `((system . ,(%current-system))
473 (substitute-urls . ,%default-substitute-urls)
474 (difference-report . ,report-differing-files)))
481 (define-command (guix-challenge . args)
483 (synopsis "challenge substitute servers, comparing their binaries")
486 (let* ((opts (parse-command-line args %options (list %default-options)
487 #:build-options? #f))
488 (files (filter-map (match-lambda
489 (('argument . file) file)
492 (system (assoc-ref opts 'system))
493 (urls (assoc-ref opts 'substitute-urls))
494 (diff (assoc-ref opts 'difference-report))
495 (verbose? (assoc-ref opts 'verbose?)))
498 ;; Disable grafts since substitute servers normally provide only
500 (parameterize ((%graft? #f)
501 (current-terminal-columns (terminal-columns)))
502 (let ((files (match files
504 (filter (cut locally-built? store <>)
508 (set-build-options store
509 #:use-substitutes? #f)
511 (run-with-store store
512 (mlet* %store-monad ((items (mapm %store-monad
513 ensure-store-item files))
514 (reports (compare-contents items urls)))
515 (for-each (cut summarize-report <> #:verbose? verbose?
516 #:report-differences diff)
519 (summarize-report-list reports)
521 (exit (cond ((any comparison-report-mismatch? reports) 2)
522 ((every comparison-report-match? reports) 0)
524 #:system system))))))))
526 ;;; challenge.scm ends here