1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
4 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
6 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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 (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
54 narinfo-hash-algorithm+value
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
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))
92 (define (narinfo-hash-algorithm+value narinfo)
93 "Return two values: the hash algorithm used by NARINFO and its value as a
95 (match (string-tokenize (narinfo-hash narinfo)
96 (char-set-complement (char-set #\:)))
98 (values (lookup-hash-algorithm (string->symbol algorithm))
99 (nix-base32-string->bytevector base32)))
101 (raise (formatted-message
102 (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
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))))
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~%")
118 ;; Currently, there are no other versions.
119 ((not (= 1 maybe-number))
120 (leave (G_ "unsupported signature version: ~a~%")
123 (let ((signature (utf8->string (base64-decode sig))))
126 (string->canonical-sexp signature))
127 (lambda (key proc err)
128 (leave (G_ "signature is not a valid \
132 (leave (G_ "invalid format of the signature field: ~a~%") x))))
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
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.
145 (or (string->uri url)
147 (string-append cache-url "/" url))))
151 (() (make-list len #f))
152 ((lst ...) (map string->number lst)))
154 (() (make-list len #f))
155 ((lst ...) (map string->number lst)))
157 (and=> nar-size string->number)
158 (string-tokenize references)
164 (and=> signature narinfo-signature->canonical-sexp))
167 (define fields->alist
168 ;; The narinfo format is really just like recutils.
171 (define* (read-narinfo port #:optional url
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.
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"
187 '("URL" "Compression" "FileSize" "FileHash"))))
189 (define (narinfo-sha256 narinfo)
190 "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
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"))
197 (let ((contents (narinfo-contents narinfo)))
198 (match (string-contains contents "Signature:")
201 (let* ((above-signature (string-take contents index))
202 (signed-fields (match (call-with-input-string above-signature
204 (((fields . values) ...) fields))))
205 (and (every (cut member <> signed-fields) %mandatory-fields)
206 (sha256 (string->utf8 above-signature))))))))
208 (define* (valid-narinfo? narinfo #:optional (acl (current-acl))
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)))))
215 (signature-case (signature hash acl)
219 (format (current-error-port)
220 "invalid signature for substitute at '~a'~%"
225 (format (current-error-port)
226 "hash mismatch for substitute at '~a'~%"
231 (format (current-error-port)
232 "substitute at '~a' is signed by an \
233 unauthorized party~%"
238 (format (current-error-port)
239 "corrupt signature for substitute at '~a'~%"
243 (define (write-narinfo narinfo port)
244 "Write NARINFO to PORT."
245 (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
247 (define (narinfo->string narinfo)
248 "Return the external representation of NARINFO."
249 (call-with-output-string (cut write-narinfo narinfo <>)))
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)))
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))
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))
269 (= (narinfo-size narinfo1)
270 (narinfo-size narinfo2))))
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)))
280 ("bzip2" . ,(const #t))
281 ("none" . ,(const #t))))
283 (define (supported-compression? compression)
284 "Return true if COMPRESSION, a string, denotes a supported compression
286 (match (assoc-ref %compression-methods compression)
288 (supported? (supported?))))
290 (define (compresses-better? compression1 compression2)
291 "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
292 this is a rough approximation."
295 ("gzip" (string=? compression2 "none"))
297 (_ (or (string=? compression2 "none")
298 (string=? compression2 "gzip")))))
300 (define (decompresses-faster? compression1 compression2)
301 "Return true if COMPRESSION1 generally has a higher decompression throughput
306 ("gzip" (string=? compression2 "lzip"))
309 (define* (narinfo-best-uri narinfo #:key fast-decompression?)
310 "Select the \"best\" URI to download NARINFO's nar, and return three values:
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)."
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))))
323 (define (file-size<? c1 c2)
325 ((uri1 compression1 (? integer? file-size1))
327 ((uri2 compression2 (? integer? file-size2))
328 (< file-size1 file-size2))
330 ((uri compression1 #f)
332 ((uri2 compression2 _)
333 (compresses-better? compression1 compression2))))
334 (_ #f))) ;we can't tell
336 (define (speed<? c1 c2)
338 ((uri1 compression1 . _)
340 ((uri2 compression2 . _)
341 (decompresses-faster? compression2 compression1))))))
343 (match (sort choices (if fast-decompression? (negate speed<?) file-size<?))
344 (((uri compression file-size) _ ...)
345 (values uri compression file-size))))