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