From 9a597670f5c78b7877f94682e617f558a9b17b1d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 13 Jun 2020 22:52:04 +0100 Subject: Start modifying trust in narinfos to work with a set of narinfos To get to the point where you can trust a substitute with a given hash, if k of n of the caches provide that hash, you need to actually consider multiple narinfos all at once for a single path and hash. These changes move towards that. --- guix/pki.scm | 82 +++++++++++--------------- guix/scripts/substitute.scm | 141 ++++++++++++++++++++++++++------------------ 2 files changed, 118 insertions(+), 105 deletions(-) diff --git a/guix/pki.scm b/guix/pki.scm index 6326e065e9..e231518f31 100644 --- a/guix/pki.scm +++ b/guix/pki.scm @@ -30,7 +30,6 @@ current-acl public-keys->acl acl->public-keys - authorized-key? write-acl signature-sexp @@ -115,22 +114,6 @@ import)' tag." (_ (error "invalid access-control list" acl)))) -(define* (authorized-key? key #:optional (acl (current-acl))) - "Return #t if KEY (a canonical sexp) is an authorized public key for archive -imports according to ACL." - ;; Note: ACL is kept in native sexp form to make 'authorized-key?' faster, - ;; by not having to convert it with 'canonical-sexp->sexp' on each call. - ;; TODO: We could use a better data type for ACLs. - (let ((key (canonical-sexp->sexp key))) - (match acl - (('acl - ('entry subject-keys - ('tag ('guix 'import))) - ...) - (not (not (member key subject-keys)))) - (_ - (error "invalid access-control list" acl))))) - (define (signature-sexp data secret-key public-key) "Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that includes DATA, the actual signature value (with a 'sig-val' tag), and @@ -159,23 +142,39 @@ PUBLIC-KEY (see for examples.)" (and data signature (verify signature data public-key)))) -(define* (%signature-status signature hash - #:optional (acl (current-acl))) - "Return a symbol denoting the status of SIGNATURE vs. HASH vs. ACL. +(define* (%signatures-status signatures hash + #:optional (acl (current-acl))) + "Return a symbol denoting the status of SIGNATURES vs. HASH vs. ACL. This procedure must only be used internally, because it would be easy to forget some of the cases." - (let ((subject (signature-subject signature)) - (data (signature-signed-data signature))) - (if (and data subject) - (if (authorized-key? subject acl) - (if (equal? (hash-data->bytevector data) hash) - (if (valid-signature? signature) - 'valid-signature - 'invalid-signature) - 'hash-mismatch) - 'unauthorized-key) - 'corrupt-signature))) + + (define guix-import-acl-entries + (match acl + (('acl entries ...) + (filter + (match-lambda + (('entry parts ...) + (member '(tag (guix import)) parts))) + entries)) + (_ + (error "invalid access-control list" acl)))) + + (let loop ((entries guix-import-acl-entries)) + (match entries + (() 'no-matching-acl-entry) + ((('entry subject-obj entry-rest ...) other-entries ...) + (if (any (lambda (signature) + (let ((subject (signature-subject signature)) + (data (signature-signed-data signature))) + (if (and data subject) + (equal? subject-obj + `(public-key ,(canonical-sexp->sexp subject))) + ;; corrupt signature + #f))) + signatures) + 'matching-acl-entry + (loop other-entries)))))) (define-syntax signature-case (syntax-rules (valid-signature invalid-signature @@ -197,25 +196,10 @@ SIGNATURE, and ACL must be canonical sexps; HASH must be a bytevector." ;; Simple case: we only care about valid signatures. ((_ (signature hash acl) - (valid-signature valid-exp ...) + (matching-acl-entry valid-exp ...) (else else-exp ...)) (case (%signature-status signature hash acl) - ((valid-signature) valid-exp ...) - (else else-exp ...))) - - ;; Full case. - ((_ (signature hash acl) - (valid-signature valid-exp ...) - (invalid-signature invalid-exp ...) - (hash-mismatch mismatch-exp ...) - (unauthorized-key unauthorized-exp ...) - (corrupt-signature corrupt-exp ...)) - (case (%signature-status signature hash acl) - ((valid-signature) valid-exp ...) - ((invalid-signature) invalid-exp ...) - ((hash-mismatch) mismatch-exp ...) - ((unauthorized-key) unauthorized-exp ...) - ((corrupt-signature) corrupt-exp ...) - (else (error "bogus signature status")))))) + ((matching-acl-entry) valid-exp ...) + (else else-exp ...))))) ;;; pki.scm ends here 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 -- cgit v1.2.3