summaryrefslogtreecommitdiff
path: root/guix/scripts/authenticate.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/authenticate.scm')
-rw-r--r--guix/scripts/authenticate.scm100
1 files changed, 65 insertions, 35 deletions
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index dc73981092..0bac13edee 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -25,10 +25,12 @@
#:use-module (guix diagnostics)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (guix-authenticate))
;;; Commentary:
@@ -43,32 +45,40 @@
;; Read a gcrypt sexp from a port and return it.
(compose string->canonical-sexp read-string))
-(define (sign-with-key key-file sha256)
- "Sign the hash SHA256 (a bytevector) with KEY-FILE, and return the signature
-as a canonical sexp that includes both the hash and the actual signature."
- (let* ((secret-key (call-with-input-file key-file read-canonical-sexp))
- (public-key (if (string-suffix? ".sec" key-file)
- (call-with-input-file
+(define (load-key-pair key-file)
+ "Load the key pair whose secret key lives at KEY-FILE. Return a pair of
+canonical sexps representing those keys."
+ (catch 'system-error
+ (lambda ()
+ (let* ((secret-key (call-with-input-file key-file read-canonical-sexp))
+ (public-key (call-with-input-file
(string-append (string-drop-right key-file 4)
".pub")
- read-canonical-sexp)
- (raise
- (formatted-message
- (G_ "cannot find public key for secret key '~a'~%")
- key-file))))
- (data (bytevector->hash-data sha256
- #:key-type (key-type public-key)))
- (signature (signature-sexp data secret-key public-key)))
- signature))
-
-(define (validate-signature signature)
+ read-canonical-sexp)))
+ (cons public-key secret-key)))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (raise
+ (formatted-message
+ (G_ "failed to load key pair at '~a': ~a~%")
+ key-file (strerror errno)))))))
+
+(define (sign-with-key public-key secret-key sha256)
+ "Sign the hash SHA256 (a bytevector) with SECRET-KEY (a canonical sexp), and
+return the signature as a canonical sexp that includes SHA256, PUBLIC-KEY, and
+the actual signature."
+ (let ((data (bytevector->hash-data sha256
+ #:key-type (key-type public-key))))
+ (signature-sexp data secret-key public-key)))
+
+(define (validate-signature signature acl)
"Validate SIGNATURE, a canonical sexp. Check whether its public key is
-authorized, verify the signature, and return the signed data (a bytevector)
-upon success."
+authorized in ACL, verify the signature, and return the signed data (a
+bytevector) upon success."
(let* ((subject (signature-subject signature))
(data (signature-signed-data signature)))
(if (and data subject)
- (if (authorized-key? subject)
+ (if (authorized-key? subject acl)
(if (valid-signature? signature)
(hash-data->bytevector data) ; success
(raise
@@ -145,6 +155,19 @@ by colon, followed by the given number of characters."
(put-bytevector (current-output-port) bv)
(force-output (current-output-port))))
+ (define (call-with-reply thunk)
+ ;; Send a reply for the result of THUNK or for any exception raised during
+ ;; its execution.
+ (guard (c ((formatted-message? c)
+ (send-reply (reply-code command-failed)
+ (apply format #f
+ (G_ (formatted-message-string c))
+ (formatted-message-arguments c)))))
+ (send-reply (reply-code success) (thunk))))
+
+ (define-syntax-rule (with-reply exp ...)
+ (call-with-reply (lambda () exp ...)))
+
;; Signature sexps written to stdout may contain binary data, so force
;; ISO-8859-1 encoding so that things are not mangled. See
;; <http://bugs.gnu.org/17312> for details.
@@ -162,31 +185,38 @@ Sign data or verify signatures. This tool is meant to be used internally by
(("--version")
(show-version-and-exit "guix authenticate"))
(()
- (let loop ()
- (guard (c ((formatted-message? c)
- (send-reply (reply-code command-failed)
- (apply format #f
- (G_ (formatted-message-string c))
- (formatted-message-arguments c)))))
+ (let ((acl (current-acl)))
+ (let loop ((key-pairs vlist-null))
;; Read a request on standard input and reply.
(match (read-command (current-input-port))
(("sign" signing-key (= base16-string->bytevector hash))
- (let ((signature (sign-with-key signing-key hash)))
- (send-reply (reply-code success)
- (canonical-sexp->string signature))))
+ (let* ((key-pairs keys
+ (match (vhash-assoc signing-key key-pairs)
+ ((_ . keys)
+ (values key-pairs keys))
+ (#f
+ (let ((keys (load-key-pair signing-key)))
+ (values (vhash-cons signing-key keys
+ key-pairs)
+ keys))))))
+ (with-reply (canonical-sexp->string
+ (match keys
+ ((public . secret)
+ (sign-with-key public secret hash)))))
+ (loop key-pairs)))
(("verify" signature)
- (send-reply (reply-code success)
- (bytevector->base16-string
+ (with-reply (bytevector->base16-string
(validate-signature
- (string->canonical-sexp signature)))))
+ (string->canonical-sexp signature)
+ acl)))
+ (loop key-pairs))
(()
(exit 0))
(commands
(warning (G_ "~s: invalid command; ignoring~%") commands)
(send-reply (reply-code command-not-found)
- "invalid command"))))
-
- (loop)))
+ "invalid command")
+ (loop key-pairs))))))
(_
(leave (G_ "wrong arguments~%"))))))