[bug#43340] [PATCH 5/5] authenticate: Cache the ACL and key pairs.

[Ludovic Courtès]

In practice we're always using the same key pair,
/etc/guix/signing-key.{pub,sec}.  Keeping them in cache allows us to
avoid redundant I/O and parsing when signing multiple store items in a
row.

* guix/scripts/authenticate.scm (load-key-pair): New procedure.
(sign-with-key): Remove 'key-file' parameter and add 'public-key' and
'secret-key'.  Adjust accordingly.
(validate-signature): Add 'acl' parameter and pass it to
'authorized-key?'.
(guix-authenticate): Call 'current-acl' upfront and cache its result.
Add 'key-pairs' as an argument to 'loop' and use it as a cache of key
pairs.
---
 guix/scripts/authenticate.scm | 108 +++++++++++++++++++++-------------
 1 file changed, 66 insertions(+), 42 deletions(-)

diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index 34737481d5..95005641c4 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -24,10 +24,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:
@@ -42,32 +44,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))
+                           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 (validate-signature signature)
+(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,29 +155,43 @@ be used internally by 'guix-daemon'.\n")))
       (("--version")
        (show-version-and-exit "guix authenticate"))
       (()
-       (let loop ()
-         (guard (c ((formatted-message? c)
-                    (send-reply 500
-                                (apply format #f
-                                       (G_ (formatted-message-string c))
-                                       (formatted-message-arguments c)))))
-           ;; 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 0 (canonical-sexp->string signature))))
-             (("verify" signature)
-              (send-reply 0
-                          (bytevector->base16-string
-                           (validate-signature
-                            (string->canonical-sexp signature)))))
-             (()
-              (exit 0))
-             (commands
-              (warning (G_ "~s: invalid command; ignoring~%") commands)
-              (send-reply 404 "invalid command"))))
-
-         (loop)))
+       (let ((acl (current-acl)))
+         (let loop ((key-pairs vlist-null))
+           (guard (c ((formatted-message? c)
+                      (send-reply 500
+                                  (apply format #f
+                                         (G_ (formatted-message-string c))
+                                         (formatted-message-arguments c)))))
+             ;; Read a request on standard input and reply.
+             (match (read-command (current-input-port))
+               (("sign" signing-key (= base16-string->bytevector hash))
+                (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)))))
+                       (signature (match keys
+                                    ((public . secret)
+                                     (sign-with-key public secret hash)))))
+                  (send-reply 0 (canonical-sexp->string signature))
+                  (loop key-pairs)))
+               (("verify" signature)
+                (send-reply 0
+                            (bytevector->base16-string
+                             (validate-signature
+                              (string->canonical-sexp signature)
+                              acl)))
+                (loop key-pairs))
+               (()
+                (exit 0))
+               (commands
+                (warning (G_ "~s: invalid command; ignoring~%") commands)
+                (send-reply 404 "invalid command")
+                (loop key-pairs)))))))
       (_
        (leave (G_ "wrong arguments~%"))))))
 
-- 
2.28.0