Commit | Line | Data |
---|---|---|
d23c20f1 | 1 | ;;; GNU Guix --- Functional package management for GNU |
4d8e9509 | 2 | ;;; Copyright © 2015, 2016, 2017 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) | |
28 | #:use-module (guix serialization) | |
29 | #:use-module (guix scripts substitute) | |
30 | #:use-module (rnrs bytevectors) | |
31 | #:use-module (srfi srfi-1) | |
32 | #:use-module (srfi srfi-9) | |
33 | #:use-module (srfi srfi-26) | |
34 | #:use-module (srfi srfi-34) | |
35 | #:use-module (srfi srfi-37) | |
36 | #:use-module (ice-9 match) | |
37 | #:use-module (ice-9 vlist) | |
38 | #:use-module (ice-9 format) | |
39 | #:use-module (web uri) | |
4d8e9509 | 40 | #:export (compare-contents |
d23c20f1 | 41 | |
4d8e9509 LC |
42 | comparison-report? |
43 | comparison-report-item | |
44 | comparison-report-result | |
45 | comparison-report-local-sha256 | |
46 | comparison-report-narinfos | |
47 | ||
48 | comparison-report-match? | |
49 | comparison-report-mismatch? | |
50 | comparison-report-inconclusive? | |
d23c20f1 LC |
51 | |
52 | guix-challenge)) | |
53 | ||
54 | ;;; Commentary: | |
55 | ;;; | |
56 | ;;; Challenge substitute servers, checking whether they provide the same | |
57 | ;;; binaries as those built locally. | |
58 | ;;; | |
59 | ;;; Here we completely bypass the daemon to access substitutes. This is | |
60 | ;;; because we want to be able to report fine-grain information about | |
61 | ;;; discrepancies: We need to show the URL of the offending nar, its hash, and | |
62 | ;;; so on. | |
63 | ;;; | |
64 | ;;; Code: | |
65 | ||
66 | (define ensure-store-item ;XXX: move to (guix ui)? | |
67 | (@@ (guix scripts size) ensure-store-item)) | |
68 | ||
4d8e9509 LC |
69 | ;; Representation of a comparison report for ITEM. |
70 | (define-record-type <comparison-report> | |
71 | (%comparison-report item result local-sha256 narinfos) | |
72 | comparison-report? | |
73 | (item comparison-report-item) ;string, /gnu/store/… item | |
74 | (result comparison-report-result) ;'match | 'mismatch | 'inconclusive | |
75 | (local-sha256 comparison-report-local-sha256) ;bytevector | #f | |
76 | (narinfos comparison-report-narinfos)) ;list of <narinfo> | |
77 | ||
78 | (define-syntax comparison-report | |
79 | ;; Some sort of a an enum to make sure 'result' is correct. | |
80 | (syntax-rules (match mismatch inconclusive) | |
81 | ((_ item 'match rest ...) | |
82 | (%comparison-report item 'match rest ...)) | |
83 | ((_ item 'mismatch rest ...) | |
84 | (%comparison-report item 'mismatch rest ...)) | |
85 | ((_ item 'inconclusive rest ...) | |
86 | (%comparison-report item 'inconclusive rest ...)))) | |
87 | ||
88 | (define (comparison-report-predicate result) | |
89 | "Return a predicate that returns true when pass a REPORT that has RESULT." | |
90 | (lambda (report) | |
91 | (eq? (comparison-report-result report) result))) | |
92 | ||
93 | (define comparison-report-mismatch? | |
94 | (comparison-report-predicate 'mismatch)) | |
95 | ||
96 | (define comparison-report-match? | |
97 | (comparison-report-predicate 'match)) | |
98 | ||
99 | (define comparison-report-inconclusive? | |
100 | (comparison-report-predicate 'inconclusive)) | |
d23c20f1 LC |
101 | |
102 | (define (locally-built? store item) | |
103 | "Return true if ITEM was built locally." | |
104 | ;; XXX: For now approximate it by checking whether there's a build log for | |
105 | ;; ITEM. There could be false negatives, if logs have been removed. | |
106 | (->bool (log-file store item))) | |
107 | ||
108 | (define (query-locally-built-hash item) | |
109 | "Return the hash of ITEM, a store item, if ITEM was built locally. | |
110 | Otherwise return #f." | |
111 | (lambda (store) | |
112 | (guard (c ((nix-protocol-error? c) | |
113 | (values #f store))) | |
114 | (if (locally-built? store item) | |
115 | (values (query-path-hash store item) store) | |
116 | (values #f store))))) | |
117 | ||
118 | (define-syntax-rule (report args ...) | |
119 | (format (current-error-port) args ...)) | |
120 | ||
4d8e9509 | 121 | (define (compare-contents items servers) |
d23c20f1 LC |
122 | "Challenge the substitute servers whose URLs are listed in SERVERS by |
123 | comparing the hash of the substitutes of ITEMS that they serve. Return the | |
4d8e9509 | 124 | list of <comparison-report> objects. |
d23c20f1 LC |
125 | |
126 | This procedure does not authenticate narinfos from SERVERS, nor does it verify | |
127 | that they are signed by an authorized public keys. The reason is that, by | |
128 | definition, we may want to target unknown servers. Furthermore, no risk is | |
129 | taken since we do not import the archives." | |
130 | (define (compare item reference) | |
131 | ;; Return a procedure to compare the hash of ITEM with REFERENCE. | |
132 | (lambda (narinfo url) | |
4d8e9509 | 133 | (or (not narinfo) |
d23c20f1 LC |
134 | (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo)))) |
135 | (bytevector=? reference value))))) | |
136 | ||
137 | (define (select-reference item narinfos urls) | |
138 | ;; Return a "reference" narinfo among NARINFOS. | |
139 | (match narinfos | |
140 | ((first narinfos ...) | |
141 | (match servers | |
142 | ((url urls ...) | |
143 | (if (not first) | |
144 | (select-reference item narinfos urls) | |
4d8e9509 | 145 | (narinfo-hash->sha256 (narinfo-hash first)))))))) |
d23c20f1 LC |
146 | |
147 | (mlet* %store-monad ((local (mapm %store-monad | |
148 | query-locally-built-hash items)) | |
149 | (remote -> (append-map (cut lookup-narinfos <> items) | |
150 | servers)) | |
151 | ;; No 'assert-valid-narinfo' on purpose. | |
152 | (narinfos -> (fold (lambda (narinfo vhash) | |
a89dde1e LC |
153 | (vhash-cons (narinfo-path narinfo) narinfo |
154 | vhash)) | |
d23c20f1 LC |
155 | vlist-null |
156 | remote))) | |
4d8e9509 LC |
157 | (return (map (lambda (item local) |
158 | (match (vhash-fold* cons '() item narinfos) | |
159 | (() ;no substitutes | |
160 | (comparison-report item 'inconclusive local '())) | |
161 | ((narinfo) | |
162 | (if local | |
163 | (if ((compare item local) narinfo (first servers)) | |
164 | (comparison-report item 'match | |
165 | local (list narinfo)) | |
166 | (comparison-report item 'mismatch | |
167 | local (list narinfo))) | |
168 | (comparison-report item 'inconclusive | |
169 | local (list narinfo)))) | |
170 | ((narinfos ...) | |
171 | (let ((reference | |
172 | (or local (select-reference item narinfos | |
173 | servers)))) | |
174 | (if (every (compare item reference) narinfos servers) | |
175 | (comparison-report item 'match | |
176 | local narinfos) | |
177 | (comparison-report item 'mismatch | |
178 | local narinfos)))))) | |
179 | items | |
180 | local)))) | |
181 | ||
182 | (define* (summarize-report comparison-report | |
153b6295 LC |
183 | #:key |
184 | (hash->string bytevector->nix-base32-string) | |
185 | verbose?) | |
4d8e9509 | 186 | "Write to the current error port a summary of REPORT, a <comparison-report> |
153b6295 LC |
187 | object. When VERBOSE?, display matches in addition to mismatches and |
188 | inconclusive reports." | |
189 | (define (report-hashes item local narinfos) | |
190 | (if local | |
69daee23 LC |
191 | (report (G_ " local hash: ~a~%") (hash->string local)) |
192 | (report (G_ " no local build for '~a'~%") item)) | |
153b6295 | 193 | (for-each (lambda (narinfo) |
69daee23 | 194 | (report (G_ " ~50a: ~a~%") |
153b6295 LC |
195 | (uri->string (narinfo-uri narinfo)) |
196 | (hash->string | |
197 | (narinfo-hash->sha256 (narinfo-hash narinfo))))) | |
198 | narinfos)) | |
199 | ||
4d8e9509 LC |
200 | (match comparison-report |
201 | (($ <comparison-report> item 'mismatch local (narinfos ...)) | |
69daee23 | 202 | (report (G_ "~a contents differ:~%") item) |
153b6295 | 203 | (report-hashes item local narinfos)) |
4d8e9509 | 204 | (($ <comparison-report> item 'inconclusive #f narinfos) |
69daee23 | 205 | (warning (G_ "could not challenge '~a': no local build~%") item)) |
4d8e9509 | 206 | (($ <comparison-report> item 'inconclusive locals ()) |
69daee23 | 207 | (warning (G_ "could not challenge '~a': no substitutes~%") item)) |
153b6295 LC |
208 | (($ <comparison-report> item 'match local (narinfos ...)) |
209 | (when verbose? | |
69daee23 | 210 | (report (G_ "~a contents match:~%") item) |
153b6295 | 211 | (report-hashes item local narinfos))))) |
d23c20f1 LC |
212 | |
213 | \f | |
214 | ;;; | |
215 | ;;; Command-line options. | |
216 | ;;; | |
217 | ||
218 | (define (show-help) | |
69daee23 | 219 | (display (G_ "Usage: guix challenge [PACKAGE...] |
d23c20f1 | 220 | Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) |
69daee23 | 221 | (display (G_ " |
d23c20f1 LC |
222 | --substitute-urls=URLS |
223 | compare build results with those at URLS")) | |
69daee23 | 224 | (display (G_ " |
153b6295 | 225 | -v, --verbose show details about successful comparisons")) |
d23c20f1 | 226 | (newline) |
69daee23 | 227 | (display (G_ " |
d23c20f1 | 228 | -h, --help display this help and exit")) |
69daee23 | 229 | (display (G_ " |
d23c20f1 LC |
230 | -V, --version display version information and exit")) |
231 | (newline) | |
232 | (show-bug-report-information)) | |
233 | ||
234 | (define %options | |
235 | (list (option '(#\h "help") #f #f | |
236 | (lambda args | |
237 | (show-help) | |
238 | (exit 0))) | |
239 | (option '(#\V "version") #f #f | |
240 | (lambda args | |
241 | (show-version-and-exit "guix challenge"))) | |
242 | ||
243 | (option '("substitute-urls") #t #f | |
244 | (lambda (opt name arg result . rest) | |
245 | (apply values | |
246 | (alist-cons 'substitute-urls | |
247 | (string-tokenize arg) | |
248 | (alist-delete 'substitute-urls result)) | |
153b6295 LC |
249 | rest))) |
250 | (option '("verbose" #\v) #f #f | |
251 | (lambda (opt name arg result . rest) | |
252 | (apply values | |
253 | (alist-cons 'verbose? #t result) | |
d23c20f1 LC |
254 | rest))))) |
255 | ||
256 | (define %default-options | |
257 | `((system . ,(%current-system)) | |
258 | (substitute-urls . ,%default-substitute-urls))) | |
259 | ||
260 | \f | |
261 | ;;; | |
262 | ;;; Entry point. | |
263 | ;;; | |
264 | ||
265 | (define (guix-challenge . args) | |
266 | (with-error-handling | |
267 | (let* ((opts (parse-command-line args %options (list %default-options))) | |
268 | (files (filter-map (match-lambda | |
269 | (('argument . file) file) | |
270 | (_ #f)) | |
271 | opts)) | |
272 | (system (assoc-ref opts 'system)) | |
153b6295 LC |
273 | (urls (assoc-ref opts 'substitute-urls)) |
274 | (verbose? (assoc-ref opts 'verbose?))) | |
d23c20f1 LC |
275 | (leave-on-EPIPE |
276 | (with-store store | |
db8f6b34 LC |
277 | ;; Disable grafts since substitute servers normally provide only |
278 | ;; ungrafted stuff. | |
279 | (parameterize ((%graft? #f)) | |
280 | (let ((files (match files | |
281 | (() | |
282 | (filter (cut locally-built? store <>) | |
283 | (live-paths store))) | |
284 | (x | |
285 | files)))) | |
286 | (set-build-options store | |
287 | #:use-substitutes? #f) | |
288 | ||
289 | (run-with-store store | |
4d8e9509 LC |
290 | (mlet* %store-monad ((items (mapm %store-monad |
291 | ensure-store-item files)) | |
292 | (reports (compare-contents items urls))) | |
153b6295 LC |
293 | (for-each (cut summarize-report <> #:verbose? verbose?) |
294 | reports) | |
4d8e9509 LC |
295 | |
296 | (exit (cond ((any comparison-report-mismatch? reports) 2) | |
297 | ((every comparison-report-match? reports) 0) | |
298 | (else 1)))) | |
db8f6b34 | 299 | #:system system)))))))) |
d23c20f1 LC |
300 | |
301 | ;;; challenge.scm ends here |