Start modifying trust in narinfos to work with a set of narinfosk-of-n-substitute-trust

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.

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 <http://theworld.com/~cme/spki.txt> 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