Commit | Line | Data |
---|---|---|
681af174 | 1 | ;;; GNU Guix --- Functional package management for GNU |
9da5ec70 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
681af174 CB |
3 | ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> |
4 | ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> | |
5 | ;;; | |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (guix narinfo) | |
22 | #:use-module (guix pki) | |
23 | #:use-module (guix i18n) | |
24 | #:use-module (guix base32) | |
25 | #:use-module (guix base64) | |
26 | #:use-module (guix records) | |
27 | #:use-module (guix diagnostics) | |
681af174 CB |
28 | #:use-module (gcrypt hash) |
29 | #:use-module (gcrypt pk-crypto) | |
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 (ice-9 match) | |
35 | #:use-module (ice-9 binary-ports) | |
36 | #:use-module (web uri) | |
37 | #:export (narinfo-signature->canonical-sexp | |
38 | ||
39 | narinfo? | |
40 | narinfo-path | |
41 | narinfo-uris | |
42 | narinfo-uri-base | |
43 | narinfo-compressions | |
44 | narinfo-file-hashes | |
45 | narinfo-file-sizes | |
46 | narinfo-hash | |
47 | narinfo-size | |
48 | narinfo-references | |
49 | narinfo-deriver | |
50 | narinfo-system | |
51 | narinfo-signature | |
2d518f7e | 52 | narinfo-contents |
681af174 CB |
53 | |
54 | narinfo-hash-algorithm+value | |
55 | ||
56 | narinfo-hash->sha256 | |
57 | narinfo-best-uri | |
58 | ||
59 | valid-narinfo? | |
60 | ||
61 | read-narinfo | |
62 | write-narinfo | |
63 | ||
64 | string->narinfo | |
65 | narinfo->string | |
66 | ||
67 | equivalent-narinfo?)) | |
68 | ||
69 | (define-record-type <narinfo> | |
70 | (%make-narinfo path uri-base uris compressions file-sizes file-hashes | |
71 | nar-hash nar-size references deriver system | |
72 | signature contents) | |
73 | narinfo? | |
74 | (path narinfo-path) | |
75 | (uri-base narinfo-uri-base) ;URI of the cache it originates from | |
76 | (uris narinfo-uris) ;list of strings | |
77 | (compressions narinfo-compressions) ;list of strings | |
78 | (file-sizes narinfo-file-sizes) ;list of (integers | #f) | |
79 | (file-hashes narinfo-file-hashes) | |
80 | (nar-hash narinfo-hash) | |
81 | (nar-size narinfo-size) | |
82 | (references narinfo-references) | |
83 | (deriver narinfo-deriver) | |
84 | (system narinfo-system) | |
85 | (signature narinfo-signature) ; canonical sexp | |
86 | ;; The original contents of a narinfo file. This field is needed because we | |
87 | ;; want to preserve the exact textual representation for verification purposes. | |
88 | ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html> | |
89 | ;; for more information. | |
90 | (contents narinfo-contents)) | |
91 | ||
92 | (define (narinfo-hash-algorithm+value narinfo) | |
93 | "Return two values: the hash algorithm used by NARINFO and its value as a | |
94 | bytevector." | |
95 | (match (string-tokenize (narinfo-hash narinfo) | |
96 | (char-set-complement (char-set #\:))) | |
97 | ((algorithm base32) | |
98 | (values (lookup-hash-algorithm (string->symbol algorithm)) | |
99 | (nix-base32-string->bytevector base32))) | |
100 | (_ | |
101 | (raise (formatted-message | |
102 | (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo)))))) | |
103 | ||
104 | (define (narinfo-hash->sha256 hash) | |
105 | "If the string HASH denotes a sha256 hash, return it as a bytevector. | |
106 | Otherwise return #f." | |
107 | (and (string-prefix? "sha256:" hash) | |
108 | (nix-base32-string->bytevector (string-drop hash 7)))) | |
109 | ||
110 | (define (narinfo-signature->canonical-sexp str) | |
111 | "Return the value of a narinfo's 'Signature' field as a canonical sexp." | |
112 | (match (string-split str #\;) | |
113 | ((version host-name sig) | |
114 | (let ((maybe-number (string->number version))) | |
115 | (cond ((not (number? maybe-number)) | |
116 | (leave (G_ "signature version must be a number: ~s~%") | |
117 | version)) | |
118 | ;; Currently, there are no other versions. | |
119 | ((not (= 1 maybe-number)) | |
120 | (leave (G_ "unsupported signature version: ~a~%") | |
121 | maybe-number)) | |
122 | (else | |
123 | (let ((signature (utf8->string (base64-decode sig)))) | |
124 | (catch 'gcry-error | |
125 | (lambda () | |
126 | (string->canonical-sexp signature)) | |
127 | (lambda (key proc err) | |
128 | (leave (G_ "signature is not a valid \ | |
129 | s-expression: ~s~%") | |
130 | signature)))))))) | |
131 | (x | |
132 | (leave (G_ "invalid format of the signature field: ~a~%") x)))) | |
133 | ||
134 | (define (narinfo-maker str cache-url) | |
135 | "Return a narinfo constructor for narinfos originating from CACHE-URL. STR | |
136 | must contain the original contents of a narinfo file." | |
137 | (lambda (path urls compressions file-hashes file-sizes | |
138 | nar-hash nar-size references deriver system | |
139 | signature) | |
140 | "Return a new <narinfo> object." | |
141 | (define len (length urls)) | |
142 | (%make-narinfo path cache-url | |
143 | ;; Handle the case where URL is a relative URL. | |
144 | (map (lambda (url) | |
145 | (or (string->uri url) | |
146 | (string->uri | |
147 | (string-append cache-url "/" url)))) | |
148 | urls) | |
149 | compressions | |
150 | (match file-sizes | |
151 | (() (make-list len #f)) | |
152 | ((lst ...) (map string->number lst))) | |
153 | (match file-hashes | |
154 | (() (make-list len #f)) | |
155 | ((lst ...) (map string->number lst))) | |
156 | nar-hash | |
157 | (and=> nar-size string->number) | |
158 | (string-tokenize references) | |
159 | (match deriver | |
160 | ((or #f "") #f) | |
161 | (_ deriver)) | |
162 | system | |
163 | (false-if-exception | |
164 | (and=> signature narinfo-signature->canonical-sexp)) | |
165 | str))) | |
166 | ||
167 | (define fields->alist | |
168 | ;; The narinfo format is really just like recutils. | |
169 | recutils->alist) | |
170 | ||
171 | (define* (read-narinfo port #:optional url | |
172 | #:key size) | |
173 | "Read a narinfo from PORT. If URL is true, it must be a string used to | |
174 | build full URIs from relative URIs found while reading PORT. When SIZE is | |
175 | true, read at most SIZE bytes from PORT; otherwise, read as much as possible. | |
176 | ||
177 | No authentication and authorization checks are performed here!" | |
178 | (let ((str (utf8->string (if size | |
179 | (get-bytevector-n port size) | |
180 | (get-bytevector-all port))))) | |
181 | (alist->record (call-with-input-string str fields->alist) | |
182 | (narinfo-maker str url) | |
183 | '("StorePath" "URL" "Compression" | |
184 | "FileHash" "FileSize" "NarHash" "NarSize" | |
185 | "References" "Deriver" "System" | |
186 | "Signature") | |
187 | '("URL" "Compression" "FileSize" "FileHash")))) | |
188 | ||
189 | (define (narinfo-sha256 narinfo) | |
190 | "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a | |
191 | 'Signature' field." | |
192 | (define %mandatory-fields | |
193 | ;; List of fields that must be signed. If they are not signed, the | |
194 | ;; narinfo is considered unsigned. | |
195 | '("StorePath" "NarHash" "References")) | |
196 | ||
197 | (let ((contents (narinfo-contents narinfo))) | |
198 | (match (string-contains contents "Signature:") | |
199 | (#f #f) | |
200 | (index | |
201 | (let* ((above-signature (string-take contents index)) | |
202 | (signed-fields (match (call-with-input-string above-signature | |
203 | fields->alist) | |
204 | (((fields . values) ...) fields)))) | |
205 | (and (every (cut member <> signed-fields) %mandatory-fields) | |
206 | (sha256 (string->utf8 above-signature)))))))) | |
207 | ||
208 | (define* (valid-narinfo? narinfo #:optional (acl (current-acl)) | |
209 | #:key verbose?) | |
210 | "Return #t if NARINFO's signature is not valid." | |
211 | (let ((hash (narinfo-sha256 narinfo)) | |
212 | (signature (narinfo-signature narinfo)) | |
213 | (uri (uri->string (first (narinfo-uris narinfo))))) | |
214 | (and hash signature | |
215 | (signature-case (signature hash acl) | |
216 | (valid-signature #t) | |
217 | (invalid-signature | |
218 | (when verbose? | |
219 | (format (current-error-port) | |
220 | "invalid signature for substitute at '~a'~%" | |
221 | uri)) | |
222 | #f) | |
223 | (hash-mismatch | |
224 | (when verbose? | |
225 | (format (current-error-port) | |
226 | "hash mismatch for substitute at '~a'~%" | |
227 | uri)) | |
228 | #f) | |
229 | (unauthorized-key | |
230 | (when verbose? | |
231 | (format (current-error-port) | |
232 | "substitute at '~a' is signed by an \ | |
233 | unauthorized party~%" | |
234 | uri)) | |
235 | #f) | |
236 | (corrupt-signature | |
237 | (when verbose? | |
238 | (format (current-error-port) | |
239 | "corrupt signature for substitute at '~a'~%" | |
240 | uri)) | |
241 | #f))))) | |
242 | ||
243 | (define (write-narinfo narinfo port) | |
244 | "Write NARINFO to PORT." | |
245 | (put-bytevector port (string->utf8 (narinfo-contents narinfo)))) | |
246 | ||
247 | (define (narinfo->string narinfo) | |
248 | "Return the external representation of NARINFO." | |
249 | (call-with-output-string (cut write-narinfo narinfo <>))) | |
250 | ||
251 | (define (string->narinfo str cache-uri) | |
252 | "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of | |
253 | the cache STR originates form." | |
254 | (call-with-input-string str (cut read-narinfo <> cache-uri))) | |
255 | ||
256 | (define (equivalent-narinfo? narinfo1 narinfo2) | |
257 | "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe | |
258 | the same store item. This ignores unnecessary metadata such as the Nar URL." | |
259 | (and (string=? (narinfo-hash narinfo1) | |
260 | (narinfo-hash narinfo2)) | |
261 | ||
262 | ;; The following is not needed if all we want is to download a valid | |
263 | ;; nar, but it's necessary if we want valid narinfo. | |
264 | (string=? (narinfo-path narinfo1) | |
265 | (narinfo-path narinfo2)) | |
266 | (equal? (narinfo-references narinfo1) | |
267 | (narinfo-references narinfo2)) | |
268 | ||
269 | (= (narinfo-size narinfo1) | |
270 | (narinfo-size narinfo2)))) | |
271 | ||
272 | (define %compression-methods | |
273 | ;; Known compression methods and a thunk to determine whether they're | |
274 | ;; supported. See 'decompressed-port' in (guix utils). | |
275 | `(("gzip" . ,(const #t)) | |
276 | ("lzip" . ,(const #t)) | |
277 | ("zstd" . ,(lambda () | |
278 | (resolve-module '(zstd) #t #f #:ensure #f))) | |
279 | ("xz" . ,(const #t)) | |
280 | ("bzip2" . ,(const #t)) | |
281 | ("none" . ,(const #t)))) | |
282 | ||
283 | (define (supported-compression? compression) | |
284 | "Return true if COMPRESSION, a string, denotes a supported compression | |
285 | method." | |
286 | (match (assoc-ref %compression-methods compression) | |
287 | (#f #f) | |
288 | (supported? (supported?)))) | |
289 | ||
290 | (define (compresses-better? compression1 compression2) | |
291 | "Return true if COMPRESSION1 generally compresses better than COMPRESSION2; | |
292 | this is a rough approximation." | |
293 | (match compression1 | |
294 | ("none" #f) | |
295 | ("gzip" (string=? compression2 "none")) | |
296 | ("lzip" #t) | |
297 | (_ (or (string=? compression2 "none") | |
298 | (string=? compression2 "gzip"))))) | |
299 | ||
9da5ec70 LC |
300 | (define (decompresses-faster? compression1 compression2) |
301 | "Return true if COMPRESSION1 generally has a higher decompression throughput | |
302 | than COMPRESSION2." | |
303 | (match compression1 | |
304 | ("none" #t) | |
305 | ("zstd" #t) | |
306 | ("gzip" (string=? compression2 "lzip")) | |
307 | (_ #f))) | |
308 | ||
309 | (define* (narinfo-best-uri narinfo #:key fast-decompression?) | |
681af174 | 310 | "Select the \"best\" URI to download NARINFO's nar, and return three values: |
9da5ec70 LC |
311 | the URI, its compression method (a string), and the compressed file size. |
312 | When FAST-DECOMPRESSION? is true, prefer substitutes with faster | |
313 | decompression (typically zstd) rather than substitutes with a higher | |
314 | compression ratio (typically lzip)." | |
681af174 CB |
315 | (define choices |
316 | (filter (match-lambda | |
317 | ((uri compression file-size) | |
318 | (supported-compression? compression))) | |
319 | (zip (narinfo-uris narinfo) | |
320 | (narinfo-compressions narinfo) | |
321 | (narinfo-file-sizes narinfo)))) | |
322 | ||
323 | (define (file-size<? c1 c2) | |
324 | (match c1 | |
325 | ((uri1 compression1 (? integer? file-size1)) | |
326 | (match c2 | |
327 | ((uri2 compression2 (? integer? file-size2)) | |
328 | (< file-size1 file-size2)) | |
329 | (_ #t))) | |
330 | ((uri compression1 #f) | |
331 | (match c2 | |
332 | ((uri2 compression2 _) | |
333 | (compresses-better? compression1 compression2)))) | |
334 | (_ #f))) ;we can't tell | |
335 | ||
9da5ec70 LC |
336 | (define (speed<? c1 c2) |
337 | (match c1 | |
338 | ((uri1 compression1 . _) | |
339 | (match c2 | |
340 | ((uri2 compression2 . _) | |
341 | (decompresses-faster? compression2 compression1)))))) | |
342 | ||
343 | (match (sort choices (if fast-decompression? (negate speed<?) file-size<?)) | |
681af174 CB |
344 | (((uri compression file-size) _ ...) |
345 | (values uri compression file-size)))) |