Use 'signature-case' in (guix nar) and 'substitute-binary'.

* guix/nar.scm (restore-file-set)[assert-valid-signature]: Rewrite in
  terms of 'signature-case'.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
  Call 'leave' instead of 'raise' when SIGNATURE is invalid.
  (&nar-signature-error, &nar-invalid-hash-error): Remove.
  (assert-valid-signature): Add 'narinfo' parameter; remove 'port'.
  Rewrite in terms of 'signature-case' and 'leave'.  Mention NARINFO's
  URI in error messages.  Adjust caller.
  (narinfo-sha256): New procedure.
  (assert-valid-narinfo): Use it.
  (valid-narinfo?): Rewrite using 'narinfo-sha256' and
  'signature-case'.
* tests/substitute-binary.scm (assert-valid-signature,
  test-error-condition): Remove.
  ("corrupt signature data", "unauthorized public key", "invalid
  signature"): Remove.

3 files changed, 75 insertions, 131 deletions

diff --git a/guix/nar.scm b/guix/nar.scm
index dfee309d04..b6421434e9 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -372,40 +372,41 @@ while the locks are held."
     ;; Bail out if SIGNATURE, which must be a string as produced by
     ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
     ;; the expected hash for FILE.
-    (let* ((signature (catch 'gcry-error
-                        (lambda ()
-                          (string->canonical-sexp signature))
-                        (lambda (err . _)
-                          (raise (condition
-                                  (&message
-                                   (message "signature is not a valid \
+    (let ((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)
-          (if (authorized-key? subject)
-              (if (equal? (hash-data->bytevector data) hash)
-                  (unless (valid-signature? signature)
-                    (raise (condition
-                            (&message (message "invalid signature"))
-                            (&nar-signature-error
-                             (file file) (signature signature) (port port)))))
-                  (raise (condition (&message (message "invalid hash"))
-                                    (&nar-invalid-hash-error
-                                     (port port) (file file)
-                                     (signature signature)
-                                     (expected (hash-data->bytevector data))
-                                     (actual hash)))))
-              (raise (condition (&message (message "unauthorized public key"))
-                                (&nar-signature-error
-                                 (signature signature) (file file) (port port)))))
-          (raise (condition
-                  (&message (message "corrupt signature data"))
-                  (&nar-signature-error
-                   (signature signature) (file file) (port port)))))))
+                                 (&nar-signature-error
+                                  (file file)
+                                  (signature signature) (port port))))))))
+      (signature-case (signature hash (current-acl))
+        (valid-signature #t)
+        (invalid-signature
+         (raise (condition
+                 (&message (message "invalid signature"))
+                 (&nar-signature-error
+                  (file file) (signature signature) (port port)))))
+        (hash-mismatch
+         (raise (condition (&message (message "invalid hash"))
+                           (&nar-invalid-hash-error
+                            (port port) (file file)
+                            (signature signature)
+                            (expected (hash-data->bytevector
+                                       (signature-signed-data signature)))
+                            (actual hash)))))
+        (unauthorized-key
+         (raise (condition (&message (message "unauthorized public key"))
+                           (&nar-signature-error
+                            (signature signature) (file file) (port port)))))
+        (corrupt-signature
+         (raise (condition
+                 (&message (message "corrupt signature data"))
+                 (&nar-signature-error
+                  (signature signature) (file file) (port port))))))))
 
   (let loop ((n     (read-long-long port))
              (files '()))
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 7b8555ba36..8e08bf1172 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -252,14 +252,10 @@ failure."
                 (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)))))))))))
+                  (lambda (err . rest)
+                    (leave (_ "signature is not a valid \
+s-expression: ~s~%")
+                           signature))))))))
     (x
      (leave (_ "invalid format of the signature field: ~a~%") x))))
 
@@ -288,43 +284,21 @@ must contain the original contents of a narinfo file."
                     (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
+(define* (assert-valid-signature narinfo signature hash
                                  #:optional (acl (current-acl)))
-  "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)
-         (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)
-                (unless (valid-signature? signature)
-                  (raise (condition
-                          (&message (message "invalid signature"))
-                          (&nar-signature-error
-                           (file file) (signature signature) (port port)))))
-                (raise (condition (&message (message "invalid hash"))
-                                  (&nar-invalid-hash-error
-                                   (port port) (file file)
-                                   (signature signature)
-                                   (expected (hash-data->bytevector data))
-                                   (actual hash)))))
-            (raise (condition (&message (message "unauthorized public key"))
-                              (&nar-signature-error
-                               (signature signature) (file file) (port port)))))
-        (raise (condition
-                (&message (message "corrupt signature data"))
-                (&nar-signature-error
-                 (signature signature) (file file) (port port)))))))
+  "Bail out if SIGNATURE, a canonical sexp representing the signature of
+NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
+  (let ((uri (uri->string (narinfo-uri narinfo))))
+    (signature-case (signature hash acl)
+      (valid-signature #t)
+      (invalid-signature
+       (leave (_ "invalid signature for '~a'~%") uri))
+      (hash-mismatch
+       (leave (_ "hash mismatch for '~a'~%") uri))
+      (unauthorized-key
+       (leave (_ "'~a' is signed with an unauthorized key~%") uri))
+      (corrupt-signature
+       (leave (_ "signature on '~a' is corrupt~%") uri)))))
 
 (define* (read-narinfo port #:optional url)
   "Read a narinfo from PORT.  If URL is true, it must be a string used to
@@ -343,22 +317,29 @@ No authentication and authorization checks are performed here!"
   ;; Regexp matching a signature line in a narinfo.
   (make-regexp "(.+)^[[:blank:]]*Signature:[[:blank:]].+$"))
 
+(define (narinfo-sha256 narinfo)
+  "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
+'Signature' field."
+  (let ((contents (narinfo-contents narinfo)))
+    (match (regexp-exec %signature-line-rx contents)
+      (#f #f)
+      ((= (cut match:substring <> 1) above-signature)
+       (sha256 (string->utf8 above-signature))))))
+
 (define* (assert-valid-narinfo narinfo
                                #:optional (acl (current-acl))
                                #:key (verbose? #t))
   "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)
+  (let ((hash (narinfo-sha256 narinfo)))
+    (if (not hash)
         (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)))
+            (leave (_ "narinfo for '~a' lacks a signature~%")
+                   (uri->string (narinfo-uri narinfo))))
+        (let ((signature (narinfo-signature narinfo)))
           (unless %allow-unauthenticated-substitutes?
-            (assert-valid-signature signature hash #f acl)
+            (assert-valid-signature narinfo signature hash acl)
             (when verbose?
               (format (current-error-port)
                       "found valid signature for '~a', from '~a'~%"
@@ -366,12 +347,15 @@ or is signed by an unauthorized key."
                       (uri->string (narinfo-uri narinfo)))))
           narinfo))))
 
-(define (valid-narinfo? narinfo)
+(define* (valid-narinfo? narinfo #:optional (acl (current-acl)))
   "Return #t if NARINFO's signature is not valid."
-  (false-if-exception
-   (begin
-     (assert-valid-narinfo narinfo #:verbose? #f)
-     #t)))
+  (or %allow-unauthenticated-substitutes?
+      (let ((hash      (narinfo-sha256 narinfo))
+            (signature (narinfo-signature narinfo)))
+        (and hash signature
+             (signature-case (signature hash acl)
+               (valid-signature #t)
+               (else #f))))))
 
 (define (write-narinfo narinfo port)
   "Write NARINFO to PORT."
diff --git a/tests/substitute-binary.scm b/tests/substitute-binary.scm
index 917a0cd55c..8bde7f6aaf 100644
--- a/tests/substitute-binary.scm
+++ b/tests/substitute-binary.scm
@@ -38,13 +38,6 @@
   #:use-module (srfi srfi-35)
   #:use-module ((srfi srfi-64) #:hide (test-error)))
 
-(define assert-valid-signature
-  ;; (guix scripts substitute-binary) does not export this function in order to
-  ;; avoid misuse.
-  (@@ (guix scripts substitute-binary) assert-valid-signature))
-
-;;; XXX: Replace with 'test-error' from SRFI-64 as soon as it allow us to
-;;; catch specific exceptions.
 (define-syntax-rule (test-quit name error-rx exp)
   "Emit a test that passes when EXP throws to 'quit' with value 1, and when
 it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
@@ -117,39 +110,6 @@ version identifier.."
 (test-assert "valid narinfo-signature->canonical-sexp"
   (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
 
-(define-syntax-rule (test-error-condition name pred message-rx exp)
-  (test-assert name
-    (guard (condition ((pred condition)
-                       (and (string-match message-rx
-                                          (condition-message condition))
-                            #t))
-                      (else #f))
-      exp
-      #f)))
-
-(test-error-condition "corrupt signature data"
-    nar-signature-error? "corrupt"
-  (assert-valid-signature (string->canonical-sexp "(foo bar baz)") "irrelevant"
-                          (open-input-string "irrelevant")
-                          (public-keys->acl (list %public-key))))
-
-(test-error-condition "unauthorized public key"
-    nar-signature-error? "unauthorized"
-  (assert-valid-signature (narinfo-signature->canonical-sexp
-                           (signature-field "foo"))
-                          "irrelevant"
-                          (open-input-string "irrelevant")
-                          (public-keys->acl '())))
-
-(test-error-condition "invalid signature"
-    nar-signature-error? "invalid signature"
-  (let ((message "this is the message that we sign"))
-    (assert-valid-signature (narinfo-signature->canonical-sexp
-                             (signature-field message
-                                              #:public-key %wrong-public-key))
-                            (sha256 (string->utf8 message))
-                            (open-input-string "irrelevant")
-                            (public-keys->acl (list %wrong-public-key)))))
 
 
 (define %narinfo
@@ -317,6 +277,5 @@ a file for NARINFO."
 
 ;;; Local Variables:
 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
-;;; eval: (put 'test-error-condition 'scheme-indent-function 3)
 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 ;;; End: