diff options
| -rw-r--r-- | guix/nar.scm | 67 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 98 | ||||
| -rw-r--r-- | tests/substitute-binary.scm | 41 |
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: |