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.

doc/guix.texi

@@ -2143,6 +2143,8 @@ your system has unpatched security vulnerabilities.
 @cindex security
 @cindex digital signatures
 @cindex substitutes, authorization thereof
+@cindex access control list (ACL), for substitutes
+@cindex ACL (access control list), for substitutes
 To allow Guix to download substitutes from @code{hydra.gnu.org} or a
 mirror thereof, you
 must add its public key to the access control list (ACL) of archive
@@ -2191,9 +2193,29 @@ The following files would be downloaded:
 This indicates that substitutes from @code{hydra.gnu.org} are usable and
 will be downloaded, when possible, for future builds.
 
-Guix ignores substitutes that are not signed, or that are not signed by
-one of the keys listed in the ACL.  It also detects and raises an error
-when attempting to use a substitute that has been tampered with.
+Guix detects and raises an error when attempting to use a substitute
+that has been tampered with.  Likewise, it ignores substitutes that are
+not signed, or that are not signed by one of the keys listed in the ACL.
+
+There is one exception though: if an unauthorized server provides
+substitutes that are @emph{bit-for-bit identical} to those provided by
+an authorized server, then the unauthorized server becomes eligible for
+downloads.  For example, assume we have chosen two substitute servers
+with this option:
+
+@example
+--substitute-urls="https://a.example.org https://b.example.org"
+@end example
+
+@noindent
+@cindex reproducible builds
+If the ACL contains only the key for @code{b.example.org}, and if
+@code{a.example.org} happens to serve the @emph{exact same} substitutes,
+then Guix will download substitutes from @code{a.example.org} because it
+comes first in the list and can be considered a mirror of
+@code{b.example.org}.  In practice, independent build machines usually
+produce the same binaries, thanks to bit-reproducible builds (see
+below).
 
 @vindex http_proxy
 Substitutes are downloaded over HTTP or HTTPS.

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

tests/substitute.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,7 +28,9 @@
   #:use-module (guix base32)
   #:use-module ((guix store) #:select (%store-prefix))
   #:use-module ((guix ui) #:select (guix-warning-port))
-  #:use-module ((guix build utils) #:select (delete-file-recursively))
+  #:use-module ((guix build utils)
+                #:select (mkdir-p delete-file-recursively))
+  #:use-module (guix tests http)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (web uri)
@@ -112,6 +114,15 @@ version identifier.."
 
 
 
+(define %main-substitute-directory
+  ;; The place where 'call-with-narinfo' stores its data by default.
+  (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
+
+(define %alternate-substitute-directory
+  ;; Another place.
+  (string-append (dirname %main-substitute-directory)
+                 "/substituter-alt-data"))
+
 (define %narinfo
   ;; Skeleton of the narinfo used below.
   (string-append "StorePath: " (%store-prefix)
@@ -125,14 +136,14 @@ References: bar baz
 Deriver: " (%store-prefix) "/foo.drv
 System: mips64el-linux\n"))
 
-(define (call-with-narinfo narinfo thunk)
-  "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
+(define* (call-with-narinfo narinfo thunk
+                            #:optional
+                            (narinfo-directory %main-substitute-directory))
+  "Call THUNK in a context where the directory at URL is populated with
 a file for NARINFO."
-  (let ((narinfo-directory (and=> (string->uri (getenv
-                                                "GUIX_BINARY_SUBSTITUTE_URL"))
-                                  uri-path))
-        (cache-directory   (string-append (getenv "XDG_CACHE_HOME")
-                                          "/guix/substitute/")))
+  (mkdir-p narinfo-directory)
+  (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
+                                        "/guix/substitute/")))
     (dynamic-wind
       (lambda ()
         (when (file-exists? cache-directory)
@@ -161,11 +172,15 @@ a file for NARINFO."
               #f))
       thunk
       (lambda ()
-        (delete-file-recursively cache-directory)))))
+        (when (file-exists? cache-directory)
+          (delete-file-recursively cache-directory))))))
 
 (define-syntax-rule (with-narinfo narinfo body ...)
   (call-with-narinfo narinfo (lambda () body ...)))
 
+(define-syntax-rule (with-narinfo* narinfo directory body ...)
+  (call-with-narinfo narinfo (lambda () body ...) directory))
+
 ;; Transmit these options to 'guix substitute'.
 (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 
@@ -227,7 +242,7 @@ a file for NARINFO."
              (guix-substitute "--query"))))))))
 
 (test-quit "substitute, no signature"
-    "lacks a signature"
+    "no valid substitute"
   (with-narinfo %narinfo
     (guix-substitute "--substitute"
                      (string-append (%store-prefix)
@@ -235,7 +250,7 @@ a file for NARINFO."
                      "foo")))
 
 (test-quit "substitute, invalid hash"
-    "hash"
+    "no valid substitute"
   ;; The hash in the signature differs from the hash of %NARINFO.
   (with-narinfo (string-append %narinfo "Signature: "
                                (signature-field "different body")
@@ -246,7 +261,7 @@ a file for NARINFO."
                      "foo")))
 
 (test-quit "substitute, unauthorized key"
-    "unauthorized"
+    "no valid substitute"
   (with-narinfo (string-append %narinfo "Signature: "
                                (signature-field
                                 %narinfo
@@ -272,9 +287,158 @@ a file for NARINFO."
       (lambda ()
         (false-if-exception (delete-file "substitute-retrieved"))))))
 
+(test-equal "substitute, unauthorized narinfo comes first"
+  "Substitutable data."
+  (with-narinfo*
+      (string-append %narinfo "Signature: "
+                     (signature-field
+                      %narinfo
+                      #:public-key %wrong-public-key))
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; Remove this file so that the substitute can only be retrieved
+          ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %main-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, unsigned narinfo comes first"
+  "Substitutable data."
+  (with-narinfo* %narinfo                         ;not signed!
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; Remove this file so that the substitute can only be retrieved
+          ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %main-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first narinfo is unsigned and has wrong hash"
+  "Substitutable data."
+  (with-narinfo* (regexp-substitute #f
+                                    (string-match "NarHash: [[:graph:]]+"
+                                                  %narinfo)
+                                    'pre
+                                    "NarHash: sha256:"
+                                    (bytevector->nix-base32-string
+                                     (make-bytevector 32))
+                                    'post)
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; This time remove the file so that the substitute can only be
+          ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %alternate-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first narinfo is unsigned and has wrong refs"
+  "Substitutable data."
+  (with-narinfo* (regexp-substitute #f
+                                    (string-match "References: ([^\n]+)\n"
+                                                  %narinfo)
+                                    'pre "References: " 1
+                                    " wrong set of references\n"
+                                    'post)
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; This time remove the file so that the substitute can only be
+          ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %alternate-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-quit "substitute, two invalid narinfos"
+    "no valid substitute"
+  (with-narinfo* %narinfo                         ;not signed
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
+                                  (signature-field
+                                   %narinfo
+                                   #:public-key %wrong-public-key))
+        %main-substitute-directory
+
+      (guix-substitute "--substitute"
+                       (string-append (%store-prefix)
+                                      "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                       "substitute-retrieved"))))
+
 (test-end "substitute")
 
 ;;; Local Variables:
 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
+;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 ;;; End: