Commit | Line | Data |
---|---|---|
d23c20f1 | 1 | ;;; GNU Guix --- Functional package management for GNU |
0aa6b386 | 2 | ;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
d23c20f1 LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
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. | |
10 | ;;; | |
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. | |
15 | ;;; | |
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/>. | |
18 | ||
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) | |
db8f6b34 | 24 | #:use-module (guix grafts) |
d23c20f1 LC |
25 | #:use-module (guix monads) |
26 | #:use-module (guix base32) | |
27 | #:use-module (guix packages) | |
0aa6b386 | 28 | #:use-module ((guix progress) #:hide (dump-port*)) |
d23c20f1 LC |
29 | #:use-module (guix serialization) |
30 | #:use-module (guix scripts substitute) | |
31 | #:use-module (rnrs bytevectors) | |
5208db3a LC |
32 | #:autoload (guix http-client) (http-fetch) |
33 | #:use-module ((guix build syscalls) #:select (terminal-columns)) | |
34 | #:use-module (gcrypt hash) | |
d23c20f1 LC |
35 | #:use-module (srfi srfi-1) |
36 | #:use-module (srfi srfi-9) | |
5208db3a | 37 | #:use-module (srfi srfi-11) |
d23c20f1 LC |
38 | #:use-module (srfi srfi-26) |
39 | #:use-module (srfi srfi-34) | |
40 | #:use-module (srfi srfi-37) | |
41 | #:use-module (ice-9 match) | |
42 | #:use-module (ice-9 vlist) | |
43 | #:use-module (ice-9 format) | |
5208db3a | 44 | #:use-module (ice-9 ftw) |
d23c20f1 | 45 | #:use-module (web uri) |
4d8e9509 | 46 | #:export (compare-contents |
d23c20f1 | 47 | |
4d8e9509 LC |
48 | comparison-report? |
49 | comparison-report-item | |
50 | comparison-report-result | |
51 | comparison-report-local-sha256 | |
52 | comparison-report-narinfos | |
53 | ||
54 | comparison-report-match? | |
55 | comparison-report-mismatch? | |
56 | comparison-report-inconclusive? | |
d23c20f1 | 57 | |
5208db3a | 58 | differing-files |
828a39da | 59 | call-with-mismatches |
5208db3a | 60 | |
d23c20f1 LC |
61 | guix-challenge)) |
62 | ||
63 | ;;; Commentary: | |
64 | ;;; | |
65 | ;;; Challenge substitute servers, checking whether they provide the same | |
66 | ;;; binaries as those built locally. | |
67 | ;;; | |
68 | ;;; Here we completely bypass the daemon to access substitutes. This is | |
69 | ;;; because we want to be able to report fine-grain information about | |
70 | ;;; discrepancies: We need to show the URL of the offending nar, its hash, and | |
71 | ;;; so on. | |
72 | ;;; | |
73 | ;;; Code: | |
74 | ||
75 | (define ensure-store-item ;XXX: move to (guix ui)? | |
76 | (@@ (guix scripts size) ensure-store-item)) | |
77 | ||
4d8e9509 LC |
78 | ;; Representation of a comparison report for ITEM. |
79 | (define-record-type <comparison-report> | |
80 | (%comparison-report item result local-sha256 narinfos) | |
81 | comparison-report? | |
82 | (item comparison-report-item) ;string, /gnu/store/… item | |
83 | (result comparison-report-result) ;'match | 'mismatch | 'inconclusive | |
84 | (local-sha256 comparison-report-local-sha256) ;bytevector | #f | |
85 | (narinfos comparison-report-narinfos)) ;list of <narinfo> | |
86 | ||
87 | (define-syntax comparison-report | |
88 | ;; Some sort of a an enum to make sure 'result' is correct. | |
89 | (syntax-rules (match mismatch inconclusive) | |
90 | ((_ item 'match rest ...) | |
91 | (%comparison-report item 'match rest ...)) | |
92 | ((_ item 'mismatch rest ...) | |
93 | (%comparison-report item 'mismatch rest ...)) | |
94 | ((_ item 'inconclusive rest ...) | |
95 | (%comparison-report item 'inconclusive rest ...)))) | |
96 | ||
97 | (define (comparison-report-predicate result) | |
98 | "Return a predicate that returns true when pass a REPORT that has RESULT." | |
99 | (lambda (report) | |
100 | (eq? (comparison-report-result report) result))) | |
101 | ||
102 | (define comparison-report-mismatch? | |
103 | (comparison-report-predicate 'mismatch)) | |
104 | ||
105 | (define comparison-report-match? | |
106 | (comparison-report-predicate 'match)) | |
107 | ||
108 | (define comparison-report-inconclusive? | |
109 | (comparison-report-predicate 'inconclusive)) | |
d23c20f1 LC |
110 | |
111 | (define (locally-built? store item) | |
112 | "Return true if ITEM was built locally." | |
113 | ;; XXX: For now approximate it by checking whether there's a build log for | |
114 | ;; ITEM. There could be false negatives, if logs have been removed. | |
115 | (->bool (log-file store item))) | |
116 | ||
117 | (define (query-locally-built-hash item) | |
118 | "Return the hash of ITEM, a store item, if ITEM was built locally. | |
119 | Otherwise return #f." | |
120 | (lambda (store) | |
f9e8a123 | 121 | (guard (c ((store-protocol-error? c) |
d23c20f1 LC |
122 | (values #f store))) |
123 | (if (locally-built? store item) | |
124 | (values (query-path-hash store item) store) | |
125 | (values #f store))))) | |
126 | ||
127 | (define-syntax-rule (report args ...) | |
128 | (format (current-error-port) args ...)) | |
129 | ||
4d8e9509 | 130 | (define (compare-contents items servers) |
d23c20f1 LC |
131 | "Challenge the substitute servers whose URLs are listed in SERVERS by |
132 | comparing the hash of the substitutes of ITEMS that they serve. Return the | |
4d8e9509 | 133 | list of <comparison-report> objects. |
d23c20f1 LC |
134 | |
135 | This procedure does not authenticate narinfos from SERVERS, nor does it verify | |
136 | that they are signed by an authorized public keys. The reason is that, by | |
137 | definition, we may want to target unknown servers. Furthermore, no risk is | |
138 | taken since we do not import the archives." | |
139 | (define (compare item reference) | |
140 | ;; Return a procedure to compare the hash of ITEM with REFERENCE. | |
141 | (lambda (narinfo url) | |
4d8e9509 | 142 | (or (not narinfo) |
d23c20f1 LC |
143 | (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo)))) |
144 | (bytevector=? reference value))))) | |
145 | ||
146 | (define (select-reference item narinfos urls) | |
147 | ;; Return a "reference" narinfo among NARINFOS. | |
148 | (match narinfos | |
149 | ((first narinfos ...) | |
150 | (match servers | |
151 | ((url urls ...) | |
152 | (if (not first) | |
153 | (select-reference item narinfos urls) | |
4d8e9509 | 154 | (narinfo-hash->sha256 (narinfo-hash first)))))))) |
d23c20f1 LC |
155 | |
156 | (mlet* %store-monad ((local (mapm %store-monad | |
157 | query-locally-built-hash items)) | |
158 | (remote -> (append-map (cut lookup-narinfos <> items) | |
159 | servers)) | |
160 | ;; No 'assert-valid-narinfo' on purpose. | |
161 | (narinfos -> (fold (lambda (narinfo vhash) | |
a89dde1e LC |
162 | (vhash-cons (narinfo-path narinfo) narinfo |
163 | vhash)) | |
d23c20f1 LC |
164 | vlist-null |
165 | remote))) | |
4d8e9509 LC |
166 | (return (map (lambda (item local) |
167 | (match (vhash-fold* cons '() item narinfos) | |
168 | (() ;no substitutes | |
169 | (comparison-report item 'inconclusive local '())) | |
170 | ((narinfo) | |
171 | (if local | |
172 | (if ((compare item local) narinfo (first servers)) | |
173 | (comparison-report item 'match | |
174 | local (list narinfo)) | |
175 | (comparison-report item 'mismatch | |
176 | local (list narinfo))) | |
177 | (comparison-report item 'inconclusive | |
178 | local (list narinfo)))) | |
179 | ((narinfos ...) | |
180 | (let ((reference | |
181 | (or local (select-reference item narinfos | |
182 | servers)))) | |
183 | (if (every (compare item reference) narinfos servers) | |
184 | (comparison-report item 'match | |
185 | local narinfos) | |
186 | (comparison-report item 'mismatch | |
187 | local narinfos)))))) | |
188 | items | |
189 | local)))) | |
190 | ||
5208db3a LC |
191 | \f |
192 | ;;; | |
193 | ;;; Reporting. | |
194 | ;;; | |
195 | ||
5208db3a LC |
196 | (define (port-sha256* port size) |
197 | ;; Like 'port-sha256', but limited to SIZE bytes. | |
198 | (let-values (((out get) (open-sha256-port))) | |
199 | (dump-port* port out size) | |
200 | (close-port out) | |
201 | (get))) | |
202 | ||
203 | (define (archive-contents port) | |
204 | "Return a list representing the files contained in the nar read from PORT." | |
205 | (fold-archive (lambda (file type contents result) | |
206 | (match type | |
207 | ((or 'regular 'executable) | |
208 | (match contents | |
209 | ((port . size) | |
210 | (cons `(,file ,type ,(port-sha256* port size)) | |
211 | result)))) | |
212 | ('directory result) | |
213 | ('symlink | |
214 | (cons `(,file ,type ,contents) result)))) | |
215 | '() | |
216 | port | |
217 | "")) | |
218 | ||
219 | (define (store-item-contents item) | |
220 | "Return a list of files and contents for ITEM in the same format as | |
221 | 'archive-contents'." | |
222 | (file-system-fold (const #t) ;enter? | |
223 | (lambda (file stat result) ;leaf | |
224 | (define short | |
225 | (string-drop file (string-length item))) | |
226 | ||
227 | (match (stat:type stat) | |
228 | ('regular | |
229 | (let ((size (stat:size stat)) | |
230 | (type (if (zero? (logand (stat:mode stat) | |
231 | #o100)) | |
232 | 'regular | |
233 | 'executable))) | |
234 | (cons `(,short ,type | |
235 | ,(call-with-input-file file | |
236 | (cut port-sha256* <> size))) | |
237 | result))) | |
238 | ('symlink | |
239 | (cons `(,short symlink ,(readlink file)) | |
240 | result)))) | |
241 | (lambda (directory stat result) result) ;down | |
242 | (lambda (directory stat result) result) ;up | |
243 | (lambda (file stat result) result) ;skip | |
244 | (lambda (file stat errno result) result) ;error | |
245 | '() | |
246 | item | |
247 | lstat)) | |
248 | ||
828a39da LC |
249 | (define (call-with-nar narinfo proc) |
250 | "Call PROC with an input port from which it can read the nar pointed to by | |
251 | NARINFO." | |
5208db3a LC |
252 | (let*-values (((uri compression size) |
253 | (narinfo-best-uri narinfo)) | |
254 | ((port response) | |
255 | (http-fetch uri))) | |
256 | (define reporter | |
257 | (progress-reporter/file (narinfo-path narinfo) size | |
258 | #:abbreviation (const (uri-host uri)))) | |
259 | ||
260 | (define result | |
261 | (call-with-decompressed-port (string->symbol compression) | |
262 | (progress-report-port reporter port) | |
828a39da | 263 | proc)) |
5208db3a LC |
264 | |
265 | (close-port port) | |
266 | (erase-current-line (current-output-port)) | |
267 | result)) | |
268 | ||
828a39da LC |
269 | (define (narinfo-contents narinfo) |
270 | "Fetch the nar described by NARINFO and return a list representing the file | |
271 | it contains." | |
272 | (call-with-nar narinfo archive-contents)) | |
273 | ||
5208db3a LC |
274 | (define (differing-files comparison-report) |
275 | "Return a list of files that differ among the nars and possibly the local | |
276 | store item specified in COMPARISON-REPORT." | |
277 | (define contents | |
278 | (map narinfo-contents | |
279 | (comparison-report-narinfos comparison-report))) | |
280 | ||
281 | (define local-contents | |
282 | (and (comparison-report-local-sha256 comparison-report) | |
283 | (store-item-contents (comparison-report-item comparison-report)))) | |
284 | ||
285 | (match (apply lset-difference equal? | |
286 | (take (delete-duplicates | |
287 | (if local-contents | |
288 | (cons local-contents contents) | |
289 | contents)) | |
290 | 2)) | |
291 | (((files _ ...) ...) | |
292 | files))) | |
293 | ||
294 | (define (report-differing-files comparison-report) | |
295 | "Report differences among the nars and possibly the local store item | |
296 | specified in COMPARISON-REPORT." | |
297 | (match (differing-files comparison-report) | |
298 | (() | |
299 | #t) | |
300 | ((files ...) | |
301 | (format #t (N_ " differing file:~%" | |
302 | " differing files:~%" | |
303 | (length files))) | |
304 | (format #t "~{ ~a~%~}" files)))) | |
305 | ||
828a39da LC |
306 | (define (call-with-mismatches comparison-report proc) |
307 | "Call PROC with two directories containing the mismatching store items." | |
308 | (define local-hash | |
309 | (comparison-report-local-sha256 comparison-report)) | |
310 | ||
311 | (define narinfos | |
312 | (comparison-report-narinfos comparison-report)) | |
313 | ||
314 | (call-with-temporary-directory | |
315 | (lambda (directory1) | |
316 | (call-with-temporary-directory | |
317 | (lambda (directory2) | |
318 | (define narinfo1 | |
319 | (if local-hash | |
320 | (find (lambda (narinfo) | |
428561aa LC |
321 | (not (bytevector=? (narinfo-hash->sha256 |
322 | (narinfo-hash narinfo)) | |
323 | local-hash))) | |
828a39da LC |
324 | narinfos) |
325 | (first (comparison-report-narinfos comparison-report)))) | |
326 | ||
327 | (define narinfo2 | |
328 | (and (not local-hash) | |
329 | (find (lambda (narinfo) | |
330 | (not (eq? narinfo narinfo1))) | |
331 | narinfos))) | |
332 | ||
333 | (rmdir directory1) | |
334 | (call-with-nar narinfo1 (cut restore-file <> directory1)) | |
335 | (when narinfo2 | |
336 | (rmdir directory2) | |
337 | (call-with-nar narinfo2 (cut restore-file <> directory2))) | |
338 | (proc directory1 | |
339 | (if local-hash | |
340 | (comparison-report-item comparison-report) | |
341 | directory2))))))) | |
342 | ||
343 | (define %diffoscope-command | |
344 | ;; Default external diff command. Pass "--exclude-directory-metadata" so | |
345 | ;; that the mtime/ctime differences are ignored. | |
346 | '("diffoscope" "--exclude-directory-metadata=yes")) | |
347 | ||
348 | (define* (report-differing-files/external comparison-report | |
349 | #:optional | |
350 | (command %diffoscope-command)) | |
351 | "Run COMMAND to show the file-level differences for the mismatches in | |
352 | COMPARISON-REPORT." | |
353 | (call-with-mismatches comparison-report | |
354 | (lambda (directory1 directory2) | |
355 | (apply system* | |
356 | (append command | |
357 | (list directory1 directory2)))))) | |
358 | ||
4d8e9509 | 359 | (define* (summarize-report comparison-report |
153b6295 | 360 | #:key |
5208db3a | 361 | (report-differences (const #f)) |
153b6295 LC |
362 | (hash->string bytevector->nix-base32-string) |
363 | verbose?) | |
5208db3a LC |
364 | "Write to the current error port a summary of COMPARISON-REPORT, a |
365 | <comparison-report> object. When VERBOSE?, display matches in addition to | |
366 | mismatches and inconclusive reports. Upon mismatch, call REPORT-DIFFERENCES | |
367 | with COMPARISON-REPORT." | |
153b6295 LC |
368 | (define (report-hashes item local narinfos) |
369 | (if local | |
69daee23 LC |
370 | (report (G_ " local hash: ~a~%") (hash->string local)) |
371 | (report (G_ " no local build for '~a'~%") item)) | |
153b6295 | 372 | (for-each (lambda (narinfo) |
69daee23 | 373 | (report (G_ " ~50a: ~a~%") |
4736d06f | 374 | (uri->string (narinfo-best-uri narinfo)) |
153b6295 LC |
375 | (hash->string |
376 | (narinfo-hash->sha256 (narinfo-hash narinfo))))) | |
377 | narinfos)) | |
378 | ||
4d8e9509 LC |
379 | (match comparison-report |
380 | (($ <comparison-report> item 'mismatch local (narinfos ...)) | |
69daee23 | 381 | (report (G_ "~a contents differ:~%") item) |
5208db3a LC |
382 | (report-hashes item local narinfos) |
383 | (report-differences comparison-report)) | |
4d8e9509 | 384 | (($ <comparison-report> item 'inconclusive #f narinfos) |
69daee23 | 385 | (warning (G_ "could not challenge '~a': no local build~%") item)) |
4d8e9509 | 386 | (($ <comparison-report> item 'inconclusive locals ()) |
69daee23 | 387 | (warning (G_ "could not challenge '~a': no substitutes~%") item)) |
153b6295 LC |
388 | (($ <comparison-report> item 'match local (narinfos ...)) |
389 | (when verbose? | |
69daee23 | 390 | (report (G_ "~a contents match:~%") item) |
153b6295 | 391 | (report-hashes item local narinfos))))) |
d23c20f1 | 392 | |
bf7dfb1f LC |
393 | (define (summarize-report-list reports) |
394 | "Display the overall summary of REPORTS." | |
395 | (let ((total (length reports)) | |
396 | (inconclusive (count comparison-report-inconclusive? reports)) | |
397 | (matches (count comparison-report-match? reports)) | |
398 | (discrepancies (count comparison-report-mismatch? reports))) | |
399 | (report (G_ "~h store items were analyzed:~%") total) | |
400 | (report (G_ " - ~h (~,1f%) were identical~%") | |
401 | matches (* 100. (/ matches total))) | |
402 | (report (G_ " - ~h (~,1f%) differed~%") | |
403 | discrepancies (* 100. (/ discrepancies total))) | |
404 | (report (G_ " - ~h (~,1f%) were inconclusive~%") | |
405 | inconclusive (* 100. (/ inconclusive total))))) | |
406 | ||
d23c20f1 LC |
407 | \f |
408 | ;;; | |
409 | ;;; Command-line options. | |
410 | ;;; | |
411 | ||
412 | (define (show-help) | |
69daee23 | 413 | (display (G_ "Usage: guix challenge [PACKAGE...] |
d23c20f1 | 414 | Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) |
69daee23 | 415 | (display (G_ " |
d23c20f1 LC |
416 | --substitute-urls=URLS |
417 | compare build results with those at URLS")) | |
69daee23 | 418 | (display (G_ " |
6b2e91b1 | 419 | -v, --verbose show details about successful comparisons")) |
5208db3a | 420 | (display (G_ " |
6b2e91b1 | 421 | --diff=MODE show differences according to MODE")) |
d23c20f1 | 422 | (newline) |
69daee23 | 423 | (display (G_ " |
d23c20f1 | 424 | -h, --help display this help and exit")) |
69daee23 | 425 | (display (G_ " |
d23c20f1 LC |
426 | -V, --version display version information and exit")) |
427 | (newline) | |
428 | (show-bug-report-information)) | |
429 | ||
430 | (define %options | |
431 | (list (option '(#\h "help") #f #f | |
432 | (lambda args | |
433 | (show-help) | |
434 | (exit 0))) | |
435 | (option '(#\V "version") #f #f | |
436 | (lambda args | |
437 | (show-version-and-exit "guix challenge"))) | |
438 | ||
5208db3a LC |
439 | (option '("diff") #t #f |
440 | (lambda (opt name arg result . rest) | |
441 | (define mode | |
442 | (match arg | |
443 | ("none" (const #t)) | |
444 | ("simple" report-differing-files) | |
828a39da LC |
445 | ("diffoscope" report-differing-files/external) |
446 | ((and (? (cut string-prefix? "/" <>)) command) | |
447 | (cute report-differing-files/external <> | |
448 | (string-tokenize command))) | |
5208db3a LC |
449 | (_ (leave (G_ "~a: unknown diff mode~%") arg)))) |
450 | ||
451 | (apply values | |
452 | (alist-cons 'difference-report mode result) | |
453 | rest))) | |
454 | ||
d23c20f1 LC |
455 | (option '("substitute-urls") #t #f |
456 | (lambda (opt name arg result . rest) | |
457 | (apply values | |
458 | (alist-cons 'substitute-urls | |
459 | (string-tokenize arg) | |
460 | (alist-delete 'substitute-urls result)) | |
153b6295 LC |
461 | rest))) |
462 | (option '("verbose" #\v) #f #f | |
463 | (lambda (opt name arg result . rest) | |
464 | (apply values | |
465 | (alist-cons 'verbose? #t result) | |
d23c20f1 LC |
466 | rest))))) |
467 | ||
468 | (define %default-options | |
469 | `((system . ,(%current-system)) | |
5208db3a LC |
470 | (substitute-urls . ,%default-substitute-urls) |
471 | (difference-report . ,report-differing-files))) | |
d23c20f1 LC |
472 | |
473 | \f | |
474 | ;;; | |
475 | ;;; Entry point. | |
476 | ;;; | |
477 | ||
3794ce93 LC |
478 | (define-command (guix-challenge . args) |
479 | (category packaging) | |
480 | (synopsis "challenge substitute servers, comparing their binaries") | |
481 | ||
d23c20f1 | 482 | (with-error-handling |
a1ff7e1d LC |
483 | (let* ((opts (parse-command-line args %options (list %default-options) |
484 | #:build-options? #f)) | |
d23c20f1 LC |
485 | (files (filter-map (match-lambda |
486 | (('argument . file) file) | |
487 | (_ #f)) | |
488 | opts)) | |
489 | (system (assoc-ref opts 'system)) | |
153b6295 | 490 | (urls (assoc-ref opts 'substitute-urls)) |
5208db3a | 491 | (diff (assoc-ref opts 'difference-report)) |
153b6295 | 492 | (verbose? (assoc-ref opts 'verbose?))) |
d23c20f1 LC |
493 | (leave-on-EPIPE |
494 | (with-store store | |
db8f6b34 LC |
495 | ;; Disable grafts since substitute servers normally provide only |
496 | ;; ungrafted stuff. | |
5208db3a LC |
497 | (parameterize ((%graft? #f) |
498 | (current-terminal-columns (terminal-columns))) | |
db8f6b34 LC |
499 | (let ((files (match files |
500 | (() | |
501 | (filter (cut locally-built? store <>) | |
502 | (live-paths store))) | |
503 | (x | |
504 | files)))) | |
505 | (set-build-options store | |
506 | #:use-substitutes? #f) | |
507 | ||
508 | (run-with-store store | |
4d8e9509 LC |
509 | (mlet* %store-monad ((items (mapm %store-monad |
510 | ensure-store-item files)) | |
511 | (reports (compare-contents items urls))) | |
5208db3a LC |
512 | (for-each (cut summarize-report <> #:verbose? verbose? |
513 | #:report-differences diff) | |
153b6295 | 514 | reports) |
bf7dfb1f LC |
515 | (report "\n") |
516 | (summarize-report-list reports) | |
4d8e9509 LC |
517 | |
518 | (exit (cond ((any comparison-report-mismatch? reports) 2) | |
519 | ((every comparison-report-match? reports) 0) | |
520 | (else 1)))) | |
db8f6b34 | 521 | #:system system)))))))) |
d23c20f1 LC |
522 | |
523 | ;;; challenge.scm ends here |