substitute: Download from unauthorized sources that provide the right content.

This allows substitutes to be downloaded from unauthorized servers, as
long as they advertise the same hash and references as one of the
authorized servers.

* guix/scripts/substitute.scm (assert-valid-narinfo): Remove.
(valid-narinfo?): Add #:verbose?.  Handle each case of
'signature-case'.
(equivalent-narinfo?): New procedure.
(lookup-narinfos/diverse): Add 'authorized?' parameter and honor it.
[select-hit]: New procedure.
(lookup-narinfo): Add 'authorized?' parameter and pass it.
(process-query): Adjust callers accordingly.
(process-substitution): Remove call to 'assert-valid-narinfo'.  Check
whether 'lookup-narinfo' returns true and call 'leave' if not.
* tests/substitute.scm (%main-substitute-directory)
(%alternate-substitute-directory): New variables.
(call-with-narinfo): Make 'narinfo-directory' a parameter.  Call
'mkdir-p' to create it.  Change unwind handler to check whether
CACHE-DIRECTORY exists before deleting it.
(with-narinfo*): New macro.
("substitute, no signature")
("substitute, invalid hash")
("substitute, unauthorized key"): Change expected error message to "no
valid substitute".
("substitute, unauthorized narinfo comes first")
("substitute, unsigned narinfo comes first")
("substitute, first narinfo is unsigned and has wrong hash")
("substitute, first narinfo is unsigned and has wrong refs")
("substitute, unsigned narinfo comes first")
("substitute, two invalid narinfos"): New tests.
* doc/guix.texi (Substitutes): Explain the new behavior.

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))