diff options
Diffstat (limited to 'guix/scripts')
| -rwxr-xr-x | guix/scripts/substitute.scm | 134 |
1 files changed, 88 insertions, 46 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 592c497322..dd49cf15f3 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -78,7 +78,6 @@ narinfo-signature narinfo-hash->sha256 - assert-valid-narinfo lookup-narinfos lookup-narinfos/diverse @@ -407,38 +406,41 @@ No authentication and authorization checks are performed here!" (let ((above-signature (string-take contents index))) (sha256 (string->utf8 above-signature))))))) -(define* (assert-valid-narinfo narinfo - #:optional (acl (current-acl)) - #:key verbose?) - "Raise an exception if NARINFO lacks a signature, has an invalid signature, -or is signed by an unauthorized key." - (let ((hash (narinfo-sha256 narinfo))) - (if (not hash) - (if %allow-unauthenticated-substitutes? - narinfo - (leave (G_ "substitute at '~a' lacks a signature~%") - (uri->string (narinfo-uri narinfo)))) - (let ((signature (narinfo-signature narinfo))) - (unless %allow-unauthenticated-substitutes? - (assert-valid-signature narinfo signature hash acl) - (when verbose? - (format (current-error-port) - (G_ "Found valid signature for ~a~%") - (narinfo-path narinfo)) - (format (current-error-port) - (G_ "From ~a~%") - (uri->string (narinfo-uri narinfo))))) - narinfo)))) - -(define* (valid-narinfo? narinfo #:optional (acl (current-acl))) +(define* (valid-narinfo? narinfo #:optional (acl (current-acl)) + #:key verbose?) "Return #t if NARINFO's signature is not valid." (or %allow-unauthenticated-substitutes? (let ((hash (narinfo-sha256 narinfo)) - (signature (narinfo-signature narinfo))) + (signature (narinfo-signature narinfo)) + (uri (uri->string (narinfo-uri narinfo)))) (and hash signature (signature-case (signature hash acl) (valid-signature #t) - (else #f)))))) + (invalid-signature + (when verbose? + (format (current-error-port) + "invalid signature for substitute at '~a'~%" + uri)) + #f) + (hash-mismatch + (when verbose? + (format (current-error-port) + "hash mismatch for substitute at '~a'~%" + uri)) + #f) + (unauthorized-key + (when verbose? + (format (current-error-port) + "substitute at '~a' is signed by an \ +unauthorized party~%" + uri)) + #f) + (corrupt-signature + (when verbose? + (format (current-error-port) + "corrupt signature for substitute at '~a'~%" + uri)) + #f)))))) (define (write-narinfo narinfo port) "Write NARINFO to PORT." @@ -708,30 +710,68 @@ information is available locally." (let ((missing (fetch-narinfos cache missing))) (append cached (or missing '())))))) -(define (lookup-narinfos/diverse caches paths) +(define (equivalent-narinfo? narinfo1 narinfo2) + "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe +the same store item. This ignores unnecessary metadata such as the Nar URL." + (and (string=? (narinfo-hash narinfo1) + (narinfo-hash narinfo2)) + + ;; The following is not needed if all we want is to download a valid + ;; nar, but it's necessary if we want valid narinfo. + (string=? (narinfo-path narinfo1) + (narinfo-path narinfo2)) + (equal? (narinfo-references narinfo1) + (narinfo-references narinfo2)) + + (= (narinfo-size narinfo1) + (narinfo-size narinfo2)))) + +(define (lookup-narinfos/diverse caches paths authorized?) "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. -That is, when a cache lacks a narinfo, look it up in the next cache, and so -on. Return a list of narinfos for PATHS or a subset thereof." +That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next +cache, and so on. + +Return a list of narinfos for PATHS or a subset thereof. The returned +narinfos are either AUTHORIZED?, or they claim a hash that matches an +AUTHORIZED? narinfo." + (define (select-hit result) + (lambda (path) + (match (vhash-fold* cons '() path result) + ((one) + one) + ((several ..1) + (let ((authorized (find authorized? (reverse several)))) + (and authorized + (find (cut equivalent-narinfo? <> authorized) + several))))))) + (let loop ((caches caches) (paths paths) - (result '())) + (result vlist-null) ;path->narinfo vhash + (hits '())) ;paths (match paths (() ;we're done - result) + ;; Now iterate on all the HITS, and return exactly one match for each + ;; hit: the first narinfo that is authorized, or that has the same hash + ;; as an authorized narinfo, in the order of CACHES. + (filter-map (select-hit result) hits)) (_ (match caches ((cache rest ...) (let* ((narinfos (lookup-narinfos cache paths)) - (hits (map narinfo-path narinfos)) - (missing (lset-difference string=? paths hits))) ;XXX: perf - (loop rest missing (append narinfos result)))) + (definite (map narinfo-path (filter authorized? narinfos))) + (missing (lset-difference string=? paths definite))) ;XXX: perf + (loop rest missing + (fold vhash-cons result + (map narinfo-path narinfos) narinfos) + (append definite hits)))) (() ;that's it - result)))))) + (filter-map (select-hit result) hits))))))) -(define (lookup-narinfo caches path) +(define (lookup-narinfo caches path authorized?) "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH was found." - (match (lookup-narinfos/diverse caches (list path)) + (match (lookup-narinfos/diverse caches (list path) authorized?) ((answer) answer) (_ #f))) @@ -868,15 +908,15 @@ authorized substitutes." (match (string-tokenize command) (("have" paths ..1) ;; Return the subset of PATHS available in CACHE-URLS. - (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) + (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?))) (for-each (lambda (narinfo) (format #t "~a~%" (narinfo-path narinfo))) - (filter valid? substitutable)) + substitutable) (newline))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE-URLS. - (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) - (for-each display-narinfo-data (filter valid? substitutable)) + (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?))) + (for-each display-narinfo-data substitutable) (newline))) (wtf (error "unknown `--query' command" wtf)))) @@ -885,10 +925,12 @@ authorized substitutes." #:key cache-urls acl) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL." - (let* ((narinfo (lookup-narinfo cache-urls store-item)) - (uri (narinfo-uri narinfo))) - ;; Make sure it is signed and everything. - (assert-valid-narinfo narinfo acl) + (let* ((narinfo (lookup-narinfo cache-urls store-item + (cut valid-narinfo? <> acl))) + (uri (and=> narinfo narinfo-uri))) + (unless uri + (leave (G_ "no valid substitute for '~a'~%") + store-item)) ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) |