describe: Provide a hint when origin detection fails.
[jackhill/guix/guix.git] / guix / scripts / challenge.scm
CommitLineData
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.
110Otherwise return #f."
111 (lambda (store)
f9e8a123 112 (guard (c ((store-protocol-error? c)
d23c20f1
LC
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
123comparing the hash of the substitutes of ITEMS that they serve. Return the
4d8e9509 124list of <comparison-report> objects.
d23c20f1
LC
125
126This procedure does not authenticate narinfos from SERVERS, nor does it verify
127that they are signed by an authorized public keys. The reason is that, by
128definition, we may want to target unknown servers. Furthermore, no risk is
129taken 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
187object. When VERBOSE?, display matches in addition to mismatches and
188inconclusive 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 212
bf7dfb1f
LC
213(define (summarize-report-list reports)
214 "Display the overall summary of REPORTS."
215 (let ((total (length reports))
216 (inconclusive (count comparison-report-inconclusive? reports))
217 (matches (count comparison-report-match? reports))
218 (discrepancies (count comparison-report-mismatch? reports)))
219 (report (G_ "~h store items were analyzed:~%") total)
220 (report (G_ " - ~h (~,1f%) were identical~%")
221 matches (* 100. (/ matches total)))
222 (report (G_ " - ~h (~,1f%) differed~%")
223 discrepancies (* 100. (/ discrepancies total)))
224 (report (G_ " - ~h (~,1f%) were inconclusive~%")
225 inconclusive (* 100. (/ inconclusive total)))))
226
d23c20f1
LC
227\f
228;;;
229;;; Command-line options.
230;;;
231
232(define (show-help)
69daee23 233 (display (G_ "Usage: guix challenge [PACKAGE...]
d23c20f1 234Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
69daee23 235 (display (G_ "
d23c20f1
LC
236 --substitute-urls=URLS
237 compare build results with those at URLS"))
69daee23 238 (display (G_ "
153b6295 239 -v, --verbose show details about successful comparisons"))
d23c20f1 240 (newline)
69daee23 241 (display (G_ "
d23c20f1 242 -h, --help display this help and exit"))
69daee23 243 (display (G_ "
d23c20f1
LC
244 -V, --version display version information and exit"))
245 (newline)
246 (show-bug-report-information))
247
248(define %options
249 (list (option '(#\h "help") #f #f
250 (lambda args
251 (show-help)
252 (exit 0)))
253 (option '(#\V "version") #f #f
254 (lambda args
255 (show-version-and-exit "guix challenge")))
256
257 (option '("substitute-urls") #t #f
258 (lambda (opt name arg result . rest)
259 (apply values
260 (alist-cons 'substitute-urls
261 (string-tokenize arg)
262 (alist-delete 'substitute-urls result))
153b6295
LC
263 rest)))
264 (option '("verbose" #\v) #f #f
265 (lambda (opt name arg result . rest)
266 (apply values
267 (alist-cons 'verbose? #t result)
d23c20f1
LC
268 rest)))))
269
270(define %default-options
271 `((system . ,(%current-system))
272 (substitute-urls . ,%default-substitute-urls)))
273
274\f
275;;;
276;;; Entry point.
277;;;
278
279(define (guix-challenge . args)
280 (with-error-handling
a1ff7e1d
LC
281 (let* ((opts (parse-command-line args %options (list %default-options)
282 #:build-options? #f))
d23c20f1
LC
283 (files (filter-map (match-lambda
284 (('argument . file) file)
285 (_ #f))
286 opts))
287 (system (assoc-ref opts 'system))
153b6295
LC
288 (urls (assoc-ref opts 'substitute-urls))
289 (verbose? (assoc-ref opts 'verbose?)))
d23c20f1
LC
290 (leave-on-EPIPE
291 (with-store store
db8f6b34
LC
292 ;; Disable grafts since substitute servers normally provide only
293 ;; ungrafted stuff.
294 (parameterize ((%graft? #f))
295 (let ((files (match files
296 (()
297 (filter (cut locally-built? store <>)
298 (live-paths store)))
299 (x
300 files))))
301 (set-build-options store
302 #:use-substitutes? #f)
303
304 (run-with-store store
4d8e9509
LC
305 (mlet* %store-monad ((items (mapm %store-monad
306 ensure-store-item files))
307 (reports (compare-contents items urls)))
153b6295
LC
308 (for-each (cut summarize-report <> #:verbose? verbose?)
309 reports)
bf7dfb1f
LC
310 (report "\n")
311 (summarize-report-list reports)
4d8e9509
LC
312
313 (exit (cond ((any comparison-report-mismatch? reports) 2)
314 ((every comparison-report-match? reports) 0)
315 (else 1))))
db8f6b34 316 #:system system))))))))
d23c20f1
LC
317
318;;; challenge.scm ends here