diff options
Diffstat (limited to 'guix/scripts/substitute.scm')
| -rwxr-xr-x | guix/scripts/substitute.scm | 141 |
1 files changed, 85 insertions, 56 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ba2b2d2d4e..0de0215807 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -352,41 +352,34 @@ No authentication and authorization checks are performed here!" (and (every (cut member <> signed-fields) %mandatory-fields) (sha256 (string->utf8 above-signature)))))))) -(define* (valid-narinfo? narinfo #:optional (acl (current-acl)) - #:key verbose?) - "Return #t if NARINFO's signature is not valid." +(define* (compute-valid-narinfo-set narinfos #:optional (acl (current-acl)) + #:key verbose?) + "Return a list of narinfos from NARINFO's, if they together meet the ACL. +If the ACL permits narinfos from a single source, then the return value could +be a list of a single narinfo, if the ACL requires multiple public keys to be +matched, then in the case where the ACL is matched, the return value will be +the list containing all the narinfos that together meet the ACL, the order +will be consistent with the order of the narinfos in NARINFOS." (or (%allow-unauthenticated-substitutes?) - (let ((hash (narinfo-sha256 narinfo)) - (signature (narinfo-signature narinfo)) - (uri (uri->string (first (narinfo-uris narinfo))))) - (and hash signature - (signature-case (signature hash acl) - (valid-signature #t) - (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)))))) + (let ((narinfos-by-hash + (fold (lambda (narinfo result) + (let ((hash (narinfo-hash narinfo))) + (alist-cons hash + (cons narinfo + (or (assoc-ref result hash) + '())) + (assoc-delete hash result)))) + '() + ;; reverse narinfos, so that the ordering on the alist + ;; values is consistent with the ordering of narinfos + (reverse narinfos)))) + (any (match-lambda + ((hash . narinfos) + (let ((signatures (map narinfo-signature narinfos))) + (signature-case (signatures hash acl) + (matching-acl-entry narinfos) + (else #f))))) + narinfos-by-hash)))) (define (write-narinfo narinfo port) "Write NARINFO to PORT." @@ -729,7 +722,7 @@ the same store item. This ignores unnecessary metadata such as the Nar URL." (= (narinfo-size narinfo1) (narinfo-size narinfo2)))) -(define (lookup-narinfos/diverse caches paths authorized?) +(define (lookup-narinfos/diverse caches paths acl) "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next cache, and so on. @@ -749,27 +742,63 @@ AUTHORIZED? narinfo." several))))))) (let loop ((caches caches) - (paths paths) - (result vlist-null) ;path->narinfo vhash - (hits '())) ;paths - (match paths - (() ;we're done - ;; 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)) - (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 - (filter-map (select-hit result) hits))))))) + ;; the narinfos for each path, each narinfo will be for a + ;; specific cache. The ordering of the values for + ;; paths-to-narinfos will be the reverse of the ordering of the + ;; caches, so this needs to be taken in to account when using it. + (paths-to-narinfos (fold (lambda (path result) + (vhash-cons path + '() + result)) + vlist-null + paths)) + ;; list of selected narinfos for the subset of paths for which a + ;; narinfo that is sutitable to use could be found. These + ;; narinfo's should correspond to the first cache from which it + ;; was available. While the ACL might not trust this cache alone, + ;; these narinfos should be suitable based on querying multiple + ;; cache servers for narinfos. + (result '())) + (match caches + (() result) + ((cache remaining-caches ...) + (let* ((paths-to-fetch (vhash-fold (lambda (path narinfos result) + (cons path result)) + '() + paths-to-narinfos)) + (narinfos-by-path (fold (lambda (narinfo result) + (vhash-cons (narinfo-path narinfo) + narinfo + result)) + vlist-null + (lookup-narinfos cache paths-to-fetch))) + (updated-paths-to-narinfos + (fold (lambda (path result) + ))) + (selected-narinfos + (vhash-fold (lambda (path narinfos result) + (let ((valid-narinfo-set + (compute-valid-narinfo-set + ;; reverse narinfos, so that the order + ;; matches that of the caches + (reverse narinfos) + acl))) + (if valid-narinfo-set + (cons (first valid-narinfo-set) + result) + result))) + '() + updated-paths-to-narinfos)) + (paths-to-narinfos-for-remaining-paths + (fold (lambda (path result) + (vhash-delete path result)) + updated-paths-to-narinfos + (map narinfo-path selected-narinfos)))) + + (loop remaining-caches + paths-to-narinfos-for-remaining-paths + (append selected-narinfos + result))))))) (define (lookup-narinfo caches path authorized?) "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH |