substitute-binary: Defer narinfo authentication and authorization checks.

* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
  Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
  as a SRFI-35 &message and &nar-signature-error.
  (narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
  sexp.
  (&nar-signature-error, &nar-invalid-hash-error): New variables.
  (assert-valid-signature): Use them.  Expect 'signature' to be a
  canonical sexp.
  (read-narinfo): Remove authentication and authorization checks.
  (%signature-line-rx): New variable.
  (assert-valid-narinfo, valid-narinfo?): New procedures.
  (guix-substitute-binary): Wrap body in 'with-error-handling'.
  [valid?]: New procedure.
  <--query>: Show only store items of narinfos that match
  'valid-narinfo?'.
  <--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
  (%keypair): Remove.
  (%public-key, %private-key): Load from signing-key.{pub,sec}.
  (signature-body): Add #:public-key parameter.
  (call-with-narinfo): New procedure.
  (with-narinfo): New macro.
  ("corrupt signature data", "unauthorized public key", "invalid
  signature"): Make the first argument to 'assert-valid-signature' a
  canonical sexp.
  ("invalid hash", "valid read-narinfo", "valid write-narinfo"):
  Remove.
  ("query narinfo with invalid hash", "query narinfo signed with
  authorized key", "query narinfo signed with unauthorized key",
  "substitute, invalid hash", "substitute, unauthorized key"): New
  tests.

2 files changed, 307 insertions, 190 deletions

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 8903add90b..d97aeaaee7 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -247,8 +247,19 @@ failure."
              ((not (= 1 maybe-number))
               (leave (_ "unsupported signature version: ~a~%")
                      maybe-number))
-             (else (string->canonical-sexp
-                    (utf8->string (base64-decode sig)))))))
+             (else
+              (let ((signature (utf8->string (base64-decode sig))))
+                (catch 'gcry-error
+                  (lambda ()
+                    (string->canonical-sexp signature))
+                  (lambda (err . _)
+                    (raise (condition
+                            (&message
+                             (message "signature is not a valid \
+s-expression"))
+                            (&nar-signature-error
+                             (file #f)
+                             (signature signature) (port #f)))))))))))
     (x
      (leave (_ "invalid format of the signature field: ~a~%") x))))
 
@@ -273,33 +284,24 @@ must contain the original contents of a narinfo file."
                      ((or #f "") #f)
                      (_ deriver))
                    system
-                   (narinfo-signature->canonical-sexp signature)
+                   (false-if-exception
+                    (and=> signature narinfo-signature->canonical-sexp))
                    str)))
 
+(define &nar-signature-error    (@@ (guix nar) &nar-signature-error))
+(define &nar-invalid-hash-error (@@ (guix nar) &nar-invalid-hash-error))
+
 ;;; XXX: The following function is nearly an exact copy of the one from
 ;;; 'guix/nar.scm'.  Factorize as soon as we know how to make the latter
 ;;; public (see <https://lists.gnu.org/archive/html/guix-devel/2014-03/msg00097.html>).
 ;;; Keep this one private to avoid confusion.
 (define* (assert-valid-signature signature hash port
                                  #:optional (acl (current-acl)))
-  "Bail out if SIGNATURE, a string (as produced by 'canonical-sexp->string'),
-doesn't match HASH, a bytevector containing the expected hash for FILE."
-  (let* ((&nar-signature-error    (@@ (guix nar) &nar-signature-error))
-         (&nar-invalid-hash-error (@@ (guix nar) &nar-invalid-hash-error))
-         ;; XXX: This is just to keep the errors happy; get a sensible
-         ;; filename.
+  "Bail out if SIGNATURE, a canonical sexp, doesn't match HASH, a bytevector
+containing the expected hash for FILE."
+  (let* (;; XXX: This is just to keep the errors happy; get a sensible
+         ;; file name.
          (file      #f)
-         (signature (catch 'gcry-error
-                      (lambda ()
-                        (string->canonical-sexp signature))
-                      (lambda (err . _)
-                        (raise (condition
-                                (&message
-                                 (message "signature is not a valid \
-s-expression"))
-                                (&nar-signature-error
-                                 (file file)
-                                 (signature signature) (port port)))))))
          (subject   (signature-subject signature))
          (data      (signature-signed-data signature)))
     (if (and data subject)
@@ -324,25 +326,42 @@ s-expression"))
                 (&nar-signature-error
                  (signature signature) (file file) (port port)))))))
 
-(define* (read-narinfo port #:optional url (acl (current-acl)))
+(define* (read-narinfo port #:optional url)
   "Read a narinfo from PORT.  If URL is true, it must be a string used to
-build full URIs from relative URIs found while reading PORT."
-  (let* ((str       (utf8->string (get-bytevector-all port)))
-         (rx        (make-regexp "(.+)^[[:blank:]]*Signature:[[:blank:]].+$"))
-         (res       (or (regexp-exec rx str)
-                        (leave (_ "cannot find the Signature line: ~a~%")
-                               str)))
-         (hash      (sha256 (string->utf8 (match:substring res 1))))
-         (narinfo   (alist->record (fields->alist (open-input-string str))
-                                   (narinfo-maker str url)
-                                   '("StorePath" "URL" "Compression"
-                                     "FileHash" "FileSize" "NarHash" "NarSize"
-                                     "References" "Deriver" "System"
-                                     "Signature")))
-         (signature (canonical-sexp->string (narinfo-signature narinfo))))
-    (unless %allow-unauthenticated-substitutes?
-      (assert-valid-signature signature hash port acl))
-    narinfo))
+build full URIs from relative URIs found while reading PORT.
+
+No authentication and authorization checks are performed here!"
+  (let ((str (utf8->string (get-bytevector-all port))))
+    (alist->record (call-with-input-string str fields->alist)
+                   (narinfo-maker str url)
+                   '("StorePath" "URL" "Compression"
+                     "FileHash" "FileSize" "NarHash" "NarSize"
+                     "References" "Deriver" "System"
+                     "Signature"))))
+
+(define %signature-line-rx
+  ;; Regexp matching a signature line in a narinfo.
+  (make-regexp "(.+)^[[:blank:]]*Signature:[[:blank:]].+$"))
+
+(define* (assert-valid-narinfo narinfo #:optional (acl (current-acl)))
+  "Raise an exception if NARINFO lacks a signature, has an invalid signature,
+or is signed by an unauthorized key."
+  (let* ((contents  (narinfo-contents narinfo))
+         (res       (regexp-exec %signature-line-rx contents)))
+    (if (not res)
+        (if %allow-unauthenticated-substitutes?
+            narinfo
+            (leave (_ "narinfo lacks a signature: ~s~%")
+                   contents))
+        (let ((hash      (sha256 (string->utf8 (match:substring res 1))))
+              (signature (narinfo-signature narinfo)))
+          (unless %allow-unauthenticated-substitutes?
+            (assert-valid-signature signature hash #f acl))
+          narinfo))))
+
+(define (valid-narinfo? narinfo)
+  "Return #t if NARINFO's signature is not valid."
+  (false-if-exception (begin (assert-valid-narinfo narinfo) #t)))
 
 (define (write-narinfo narinfo port)
   "Write NARINFO to PORT."
@@ -353,7 +372,8 @@ build full URIs from relative URIs found while reading PORT."
   (call-with-output-string (cut write-narinfo narinfo <>)))
 
 (define (string->narinfo str cache-uri)
-  "Return the narinfo represented by STR."
+  "Return the narinfo represented by STR.  Assume CACHE-URI as the base URI of
+the cache STR originates form."
   (call-with-input-string str (cut read-narinfo <> cache-uri)))
 
 (define (fetch-narinfo cache path)
@@ -391,9 +411,9 @@ check what it has."
     (string-append %narinfo-cache-directory "/"
                    (store-path-hash-part path)))
 
-  (define (cache-entry narinfo)
+  (define (cache-entry cache-uri narinfo)
     `(narinfo (version 1)
-              (cache-uri ,(narinfo-uri-base narinfo))
+              (cache-uri ,cache-uri)
               (date ,(time-second now))
               (value ,(and=> narinfo narinfo->string))))
 
@@ -432,7 +452,7 @@ check what it has."
           (when cache
             (with-atomic-file-output cache-file
               (lambda (out)
-                (write (cache-entry narinfo) out))))
+                (write (cache-entry (cache-url cache) narinfo) out))))
           narinfo))))
 
 (define (remove-expired-cached-narinfos)
@@ -570,6 +590,21 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
       (lambda (n proc lst)
         (par-map proc lst))))
 
+(define (check-acl-initialized)
+  "Warn if the ACL is uninitialized."
+  (define (singleton? acl)
+    ;; True if ACL contains just the user's public key.
+    (and (file-exists? %public-key-file)
+         (let ((key (call-with-input-file %public-key-file
+                      (compose string->canonical-sexp
+                               get-string-all))))
+           (equal? (acl->public-keys acl) (list key)))))
+
+  (let ((acl (current-acl)))
+    (when (or (null? acl) (singleton? acl))
+      (warning (_ "ACL for archive imports seems to be uninitialized, \
+substitutes may be unavailable\n")))))
+
 (define (guix-substitute-binary . args)
   "Implement the build daemon's substituter protocol."
   (mkdir-p %narinfo-cache-directory)
@@ -598,96 +633,102 @@ substituter disabled~%")
   (force-output (current-output-port))
 
   (with-networking
-   (match args
-     (("--query")
-      (let ((cache (delay (open-cache %cache-url))))
-        (let loop ((command (read-line)))
-          (or (eof-object? command)
-              (begin
-                (match (string-tokenize command)
-                  (("have" paths ..1)
-                   ;; Return the subset of PATHS available in CACHE.
-                   (let ((substitutable
-                          (if cache
-                              (n-par-map* %lookup-threads
-                                          (cut lookup-narinfo cache <>)
-                                          paths)
-                              '())))
-                     (for-each (lambda (narinfo)
-                                 (when narinfo
-                                   (format #t "~a~%" (narinfo-path narinfo))))
-                               (filter narinfo? substitutable))
-                     (newline)))
-                  (("info" paths ..1)
-                   ;; Reply info about PATHS if it's in CACHE.
-                   (let ((substitutable
-                          (if cache
-                              (n-par-map* %lookup-threads
-                                          (cut lookup-narinfo cache <>)
-                                          paths)
-                              '())))
-                     (for-each (lambda (narinfo)
-                                 (format #t "~a\n~a\n~a\n"
-                                         (narinfo-path narinfo)
-                                         (or (and=> (narinfo-deriver narinfo)
-                                                    (cute string-append
-                                                          (%store-prefix) "/"
-                                                          <>))
-                                             "")
-                                         (length (narinfo-references narinfo)))
-                                 (for-each (cute format #t "~a/~a~%"
-                                                 (%store-prefix) <>)
-                                           (narinfo-references narinfo))
-                                 (format #t "~a\n~a\n"
-                                         (or (narinfo-file-size narinfo) 0)
-                                         (or (narinfo-size narinfo) 0)))
-                               (filter narinfo? substitutable))
-                     (newline)))
-                  (wtf
-                   (error "unknown `--query' command" wtf)))
-                (loop (read-line)))))))
-     (("--substitute" store-path destination)
-      ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
-      (let* ((cache   (delay (open-cache %cache-url)))
-             (narinfo (lookup-narinfo cache store-path))
-             (uri     (narinfo-uri narinfo)))
-        ;; Tell the daemon what the expected hash of the Nar itself is.
-        (format #t "~a~%" (narinfo-hash narinfo))
-
-        (format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%"
-                store-path (uri->string uri)
-
-                ;; Use the Nar size as an estimate of the installed size.
-                (narinfo-size narinfo)
-                (and=> (narinfo-size narinfo)
-                       (cute / <> (expt 2. 20))))
-        (let*-values (((raw download-size)
-                       ;; Note that Hydra currently generates Nars on the fly
-                       ;; and doesn't specify a Content-Length, so
-                       ;; DOWNLOAD-SIZE is #f in practice.
-                       (fetch uri #:buffered? #f #:timeout? #f))
-                      ((progress)
-                       (let* ((comp     (narinfo-compression narinfo))
-                              (dl-size  (or download-size
-                                            (and (equal? comp "none")
-                                                 (narinfo-size narinfo))))
-                              (progress (progress-proc (uri-abbreviation uri)
-                                                       dl-size
-                                                       (current-error-port))))
-                         (progress-report-port progress raw)))
-                      ((input pids)
-                       (decompressed-port (and=> (narinfo-compression narinfo)
-                                                 string->symbol)
-                                          progress)))
-          ;; Unpack the Nar at INPUT into DESTINATION.
-          (restore-file input destination)
-          (every (compose zero? cdr waitpid) pids))))
-     (("--version")
-      (show-version-and-exit "guix substitute-binary"))
-     (("--help")
-      (show-help))
-     (opts
-      (leave (_ "~a: unrecognized options~%") opts)))))
+   (with-error-handling                           ; for signature errors
+     (match args
+       (("--query")
+        (let ((cache (delay (open-cache %cache-url))))
+          (define (valid? obj)
+            (and (narinfo? obj) (valid-narinfo? obj)))
+
+          (let loop ((command (read-line)))
+            (or (eof-object? command)
+                (begin
+                  (match (string-tokenize command)
+                    (("have" paths ..1)
+                     ;; Return the subset of PATHS available in CACHE.
+                     (let ((substitutable
+                            (if cache
+                                (n-par-map* %lookup-threads
+                                            (cut lookup-narinfo cache <>)
+                                            paths)
+                                '())))
+                       (for-each (lambda (narinfo)
+                                   (format #t "~a~%" (narinfo-path narinfo)))
+                                 (filter valid? substitutable))
+                       (newline)))
+                    (("info" paths ..1)
+                     ;; Reply info about PATHS if it's in CACHE.
+                     (let ((substitutable
+                            (if cache
+                                (n-par-map* %lookup-threads
+                                            (cut lookup-narinfo cache <>)
+                                            paths)
+                                '())))
+                       (for-each (lambda (narinfo)
+                                   (format #t "~a\n~a\n~a\n"
+                                           (narinfo-path narinfo)
+                                           (or (and=> (narinfo-deriver narinfo)
+                                                      (cute string-append
+                                                            (%store-prefix) "/"
+                                                            <>))
+                                               "")
+                                           (length (narinfo-references narinfo)))
+                                   (for-each (cute format #t "~a/~a~%"
+                                                   (%store-prefix) <>)
+                                             (narinfo-references narinfo))
+                                   (format #t "~a\n~a\n"
+                                           (or (narinfo-file-size narinfo) 0)
+                                           (or (narinfo-size narinfo) 0)))
+                                 (filter valid? substitutable))
+                       (newline)))
+                    (wtf
+                     (error "unknown `--query' command" wtf)))
+                  (loop (read-line)))))))
+       (("--substitute" store-path destination)
+        ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
+        (let* ((cache   (delay (open-cache %cache-url)))
+               (narinfo (lookup-narinfo cache store-path))
+               (uri     (narinfo-uri narinfo)))
+          ;; Make sure it is signed and everything.
+          (assert-valid-narinfo narinfo)
+
+          ;; Tell the daemon what the expected hash of the Nar itself is.
+          (format #t "~a~%" (narinfo-hash narinfo))
+
+          (format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%"
+                  store-path (uri->string uri)
+
+                  ;; Use the Nar size as an estimate of the installed size.
+                  (narinfo-size narinfo)
+                  (and=> (narinfo-size narinfo)
+                         (cute / <> (expt 2. 20))))
+          (let*-values (((raw download-size)
+                         ;; Note that Hydra currently generates Nars on the fly
+                         ;; and doesn't specify a Content-Length, so
+                         ;; DOWNLOAD-SIZE is #f in practice.
+                         (fetch uri #:buffered? #f #:timeout? #f))
+                        ((progress)
+                         (let* ((comp     (narinfo-compression narinfo))
+                                (dl-size  (or download-size
+                                              (and (equal? comp "none")
+                                                   (narinfo-size narinfo))))
+                                (progress (progress-proc (uri-abbreviation uri)
+                                                         dl-size
+                                                         (current-error-port))))
+                           (progress-report-port progress raw)))
+                        ((input pids)
+                         (decompressed-port (and=> (narinfo-compression narinfo)
+                                                   string->symbol)
+                                            progress)))
+            ;; Unpack the Nar at INPUT into DESTINATION.
+            (restore-file input destination)
+            (every (compose zero? cdr waitpid) pids))))
+       (("--version")
+        (show-version-and-exit "guix substitute-binary"))
+       (("--help")
+        (show-help))
+       (opts
+        (leave (_ "~a: unrecognized options~%") opts))))))
 
 
 ;;; Local Variables:
diff --git a/tests/substitute-binary.scm b/tests/substitute-binary.scm
index 0903b202f2..eecc34bb71 100644
--- a/tests/substitute-binary.scm
+++ b/tests/substitute-binary.scm
@@ -24,7 +24,13 @@
   #:use-module (guix nar)
   #:use-module (guix pk-crypto)
   #:use-module (guix pki)
+  #:use-module (guix config)
+  #:use-module ((guix store) #:select (%store-prefix))
+  #:use-module ((guix build utils) #:select (delete-file-recursively))
   #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module ((srfi srfi-64) #:hide (test-error)))
 
@@ -36,52 +42,37 @@
 ;;; XXX: Replace with 'test-error' from SRFI-64 as soon as it allow us to
 ;;; catch specific exceptions.
 (define-syntax-rule (test-error* name exp)
-  (test-assert name
+  (test-equal name
+    1
     (catch 'quit
       (lambda ()
         exp
         #f)
-      (const #t))))
-
-(define %keypair
-  ;; (display (canonical-sexp->string
-  ;;           (generate-key "(genkey (rsa (nbits 4:1024)))")))
-  (string->canonical-sexp
-   "(key-data
- (public-key
-  (rsa
-   (n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#)
-   (e #010001#)
-   )
-  )
- (private-key
-  (rsa
-   (n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#)
-   (e #010001#)
-   (d #40E6D963EF143E9241BC10DE7A785C988C89EB1EC33253A5796AFB38FCC804D015500EC8CBCA0F5E318EE9D660DC19E7774E2E89BFD38379297EA87EFBDAC24BA32EE5339215382B2C89F5A817FD9131CA8E8A0A70D58E26E847AD0C447053671A6B2D7746087DE058A02B17701752B8A36EB414435921615AE7CAA8AC48E451#)
-   (p #00EA88C0C19FE83C09285EF49FF88A1159357FD870031C20F15EF5103FBEB10925299BCA197F7143D6792A1BA7044EDA572EC94FA6B00889F9857216CF5B984403#)
-   (q #00EAFE541EE9E0531255A85CADBEF64D5F679766D7209F521ADD131CF4B7DA9DF5414901342A146EE84FAA1E35EE0D0F6CE3F5F25989C0D1E9FA5B678D78C113C9#)
-   (u #59C80FA2C48181F6855691C9D443619BA46C7648056E081697C370D8096E8EF165122D5E55F8FD6A2DCC404FA8BDCDC1FD20B4D76A433F25E8FD6901EC2DBDAD#)
-   )
-  )
- )"))
+      (lambda (key value)
+        value))))
 
 (define %public-key
-  (find-sexp-token %keypair 'public-key))
+  ;; This key is known to be in the ACL by default.
+  (call-with-input-file (string-append %config-directory "/signing-key.pub")
+    (compose string->canonical-sexp get-string-all)))
 
 (define %private-key
-  (find-sexp-token %keypair 'private-key))
+  (call-with-input-file (string-append %config-directory "/signing-key.sec")
+    (compose string->canonical-sexp get-string-all)))
 
-(define (signature-body str)
+(define* (signature-body str #:key (public-key %public-key))
+  "Return the signature of STR as the base64-encoded body of a narinfo's
+'Signature' field."
   (base64-encode
    (string->utf8
     (canonical-sexp->string
      (signature-sexp (bytevector->hash-data (sha256 (string->utf8 str))
                                             #:key-type 'rsa)
                      %private-key
-                     %public-key)))))
+                     public-key)))))
 
 (define %signature-body
+  ;; Body of the signature of the word "secret".
   (signature-body "secret"))
 
 (define %wrong-public-key
@@ -93,9 +84,11 @@
  )"))
 
 (define %wrong-signature
-  (let* ((body (string->canonical-sexp
-                (utf8->string
-                 (base64-decode %signature-body))))
+  ;; 'Signature' field where the public key doesn't match the private key used
+  ;; to make the signature.
+  (let* ((body       (string->canonical-sexp
+                      (utf8->string
+                       (base64-decode %signature-body))))
          (data       (canonical-sexp->string (find-sexp-token body 'data)))
          (sig-val    (canonical-sexp->string (find-sexp-token body 'sig-val)))
          (public-key (canonical-sexp->string %wrong-public-key))
@@ -106,14 +99,18 @@
     (string-append "1;irrelevant;" body*)))
 
 (define* (signature str #:optional (body %signature-body))
+  "Return the 'Signature' field value with STR as the version part and BODY as
+the actual base64-encoded signature part."
   (string-append str ";irrelevant;" body))
 
 (define %signature
+  ;; Signature computed over the word "secret".
   (signature "1" %signature-body))
 
 (define %acl
   (public-keys->acl (list %public-key)))
 
+
 (test-begin "substitute-binary")
 
 (test-error* "not a number"
@@ -127,7 +124,7 @@
 
 (define-syntax-rule (test-error-condition name pred exp)
   (test-assert name
-    (guard (condition ((pred condition) (pk 'true condition #t))
+    (guard (condition ((pred condition) #t)
                       (else #f))
       exp
       #f)))
@@ -135,63 +132,142 @@
 ;;; XXX: Do we need a better predicate hierarchy for these tests?
 (test-error-condition "corrupt signature data"
   nar-signature-error?
-  (assert-valid-signature "invalid sexp" "irrelevant"
+  (assert-valid-signature (string->canonical-sexp "(foo bar baz)") "irrelevant"
                           (open-input-string "irrelevant")
                           %acl))
 
 (test-error-condition "unauthorized public key"
   nar-signature-error?
-  (assert-valid-signature (canonical-sexp->string
-                           (narinfo-signature->canonical-sexp %signature))
+  (assert-valid-signature (narinfo-signature->canonical-sexp %signature)
                           "irrelevant"
                           (open-input-string "irrelevant")
                           (public-keys->acl '())))
 
 (test-error-condition "invalid signature"
   nar-signature-error?
-  (assert-valid-signature (canonical-sexp->string
-                           (narinfo-signature->canonical-sexp
-                            %wrong-signature))
+  (assert-valid-signature (narinfo-signature->canonical-sexp
+                           %wrong-signature)
                           (sha256 (string->utf8 "secret"))
                           (open-input-string "irrelevant")
                           (public-keys->acl (list %wrong-public-key))))
 
+
 (define %narinfo
-  "StorePath: /nix/store/foo
+  (string-append "StorePath: " (%store-prefix)
+                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
 URL: nar/foo
 Compression: bzip2
 NarHash: sha256:7
 NarSize: 42
 References: bar baz
-Deriver: foo.drv
-System: mips64el-linux\n")
+Deriver: " (%store-prefix) "/foo.drv
+System: mips64el-linux\n"))
 
 (define (narinfo sig)
+  "Return a narinfo with SIG as its 'Signature' field."
   (format #f "~aSignature: ~a~%" %narinfo sig))
 
 (define %signed-narinfo
+  ;; Narinfo with a valid signature.
   (narinfo (signature "1" (signature-body %narinfo))))
 
-(test-error-condition "invalid hash"
+(define (call-with-narinfo narinfo thunk)
+  "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_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-binary/")))
+    (dynamic-wind
+      (lambda ()
+        (when (file-exists? cache-directory)
+          (delete-file-recursively cache-directory))
+        (call-with-output-file (string-append narinfo-directory
+                                              "/nix-cache-info")
+          (lambda (port)
+            (format port "StoreDir: ~a\nWantMassQuery: 0\n"
+                    (%store-prefix))))
+        (call-with-output-file (string-append narinfo-directory "/"
+                                              "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+                                              ".narinfo")
+          (cut display narinfo <>))
+
+        (set! (@@ (guix scripts substitute-binary)
+                  %allow-unauthenticated-substitutes?)
+              #f))
+      thunk
+      (lambda ()
+        (delete-file-recursively cache-directory)))))
+
+(define-syntax-rule (with-narinfo narinfo body ...)
+  (call-with-narinfo narinfo (lambda () body ...)))
+
+
+(test-equal "query narinfo with invalid hash"
   ;; The hash of '%signature' is computed over the word "secret", not
   ;; '%narinfo'.
-  nar-invalid-hash-error?
-  (read-narinfo (open-input-string (narinfo %signature))
-                "https://example.com" %acl))
-
-(test-assert "valid read-narinfo"
-  (read-narinfo (open-input-string %signed-narinfo)
-                "https://example.com" %acl))
-
-(test-equal "valid write-narinfo"
-  %signed-narinfo
-  (call-with-output-string
-   (lambda (port)
-     (write-narinfo (read-narinfo (open-input-string %signed-narinfo)
-                                  "https://example.com" %acl)
-                    port))))
+  ""
+
+  (with-narinfo (narinfo %signature)
+    (string-trim-both
+     (with-output-to-string
+       (lambda ()
+         (with-input-from-string (string-append "have " (%store-prefix)
+                                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+           (lambda ()
+             (guix-substitute-binary "--query"))))))))
+
+(test-equal "query narinfo signed with authorized key"
+  (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+
+  (with-narinfo %signed-narinfo
+    (string-trim-both
+     (with-output-to-string
+       (lambda ()
+         (with-input-from-string (string-append "have " (%store-prefix)
+                                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+           (lambda ()
+             (guix-substitute-binary "--query"))))))))
+
+(test-equal "query narinfo signed with unauthorized key"
+  ""                                              ; not substitutable
+
+  (with-narinfo (narinfo (signature "1"
+                                    (signature-body %narinfo
+                                                    #:public-key %wrong-public-key)))
+    (string-trim-both
+     (with-output-to-string
+       (lambda ()
+         (with-input-from-string (string-append "have " (%store-prefix)
+                                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+           (lambda ()
+             (guix-substitute-binary "--query"))))))))
+
+(test-error* "substitute, invalid hash"
+  ;; The hash of '%signature' is computed over the word "secret", not
+  ;; '%narinfo'.
+  (with-narinfo (narinfo %signature)
+    (guix-substitute-binary "--substitute"
+                            (string-append (%store-prefix)
+                                           "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                            "foo")))
+
+(test-error* "substitute, unauthorized key"
+  (with-narinfo (narinfo (signature "1"
+                                    (signature-body %narinfo
+                                                    #:public-key %wrong-public-key)))
+    (guix-substitute-binary "--substitute"
+                            (string-append (%store-prefix)
+                                           "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                            "foo")))
 
 (test-end "substitute-binary")
 
 
 (exit (= (test-runner-fail-count (test-runner-current)) 0))
+
+;;; Local Variables:
+;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
+;;; eval: (put 'test-error* 'scheme-indent-function 1)
+;;; End: