05/12: openpgp: Add 'lookup-key-by-fingerprint'.

[guix-commits]

civodul pushed a commit to branch wip-openpgp
in repository guix.

commit fbbe09567cc28c6ba343c3e495bcd2b6bf4e066b
Author: Ludovic Courtès <address@hidden>
AuthorDate: Sun Apr 26 23:20:26 2020 +0200

    openpgp: Add 'lookup-key-by-fingerprint'.
    
    * guix/openpgp.scm (<openpgp-keyring>)[table]: Rename to...
    [ids]: ... this.
    [fingerprints]: New field.
    (keyring-insert, lookup-key-by-fingerprint): New procedures.
    (%empty-keyring): Adjust.
    (get-openpgp-keyring): Manipulate KEYRING instead of its vhash, use
    'keyring-insert'.
    * tests/openpgp.scm ("get-openpgp-keyring"): Test
    'lookup-key-by-fingerprint'.
---
 guix/openpgp.scm  | 43 +++++++++++++++++++++++++++++++------------
 tests/openpgp.scm | 16 +++++++++-------
 2 files changed, 40 insertions(+), 19 deletions(-)

diff --git a/guix/openpgp.scm b/guix/openpgp.scm
index d9f8a41..e4fa2da 100644
--- a/guix/openpgp.scm
+++ b/guix/openpgp.scm
@@ -52,6 +52,7 @@
             openpgp-keyring?
             %empty-keyring
             lookup-key-by-id
+            lookup-key-by-fingerprint
             get-openpgp-keyring
 
             read-radix-64)
@@ -924,14 +925,32 @@ FINGERPRINT, a bytevector."
 ;;; Keyring management
 
 (define-record-type <openpgp-keyring>
-  (openpgp-keyring table)
+  (openpgp-keyring ids fingerprints)
   openpgp-keyring?
-  (table openpgp-keyring-table))              ;vhash mapping key id to packets
+  (ids            openpgp-keyring-ids)        ;vhash mapping key id to packets
+  (fingerprints   openpgp-keyring-fingerprints)) ;mapping fingerprint to 
packets
+
+(define* (keyring-insert key keyring #:optional (packets (list key)))
+  "Insert the KEY/PACKETS association into KEYRING and return the resulting
+keyring.  PACKETS typically contains KEY, an <openpgp-public-key>, alongside
+with additional <openpgp-public-key> records for sub-keys, <openpgp-user-id>
+records, and so on."
+  (openpgp-keyring (vhash-consv (openpgp-public-key-id key) packets
+                                (openpgp-keyring-ids keyring))
+                   (vhash-cons (openpgp-public-key-fingerprint key) packets
+                               (openpgp-keyring-fingerprints keyring))))
 
 (define (lookup-key-by-id keyring id)
   "Return a list of packets for the key with ID in KEYRING, or #f if ID could
 not be found.  ID must be the 64-bit key ID of the key, an integer."
-  (match (vhash-assv id (openpgp-keyring-table keyring))
+  (match (vhash-assv id (openpgp-keyring-ids keyring))
+    ((_ . lst) lst)
+    (#f '())))
+
+(define (lookup-key-by-fingerprint keyring fingerprint)
+  "Return a list of packets for the key with FINGERPRINT in KEYRING, or #f if
+FINGERPRINT could not be found.  FINGERPRINT must be a bytevector."
+  (match (vhash-assoc fingerprint (openpgp-keyring-fingerprints keyring))
     ((_ . lst) lst)
     (#f '())))
 
@@ -940,7 +959,7 @@ not be found.  ID must be the 64-bit key ID of the key, an 
integer."
 
 (define %empty-keyring
   ;; The empty keyring.
-  (openpgp-keyring vlist-null))
+  (openpgp-keyring vlist-null vlist-null))
 
 (define* (get-openpgp-keyring port
                               #:optional (keyring %empty-keyring)
@@ -951,15 +970,15 @@ complements KEYRING.  LIMIT is the maximum number of keys 
to read, or -1 if
 there is no limit."
   (let lp ((pkt (get-packet port))
            (limit limit)
-           (keyring (openpgp-keyring-table keyring)))
+           (keyring keyring))
     (print "#;key " pkt)
     (cond ((or (zero? limit) (eof-object? pkt))
-           (openpgp-keyring keyring))
+           keyring)
           ((openpgp-public-key-primary? pkt)
            ;; Read signatures, user id's, subkeys
-           (let lp* ((pkt (get-packet port))
+           (let lp* ((pkt  (get-packet port))
                      (pkts (list pkt))
-                     (key-ids (list (openpgp-public-key-id pkt))))
+                     (keys (list pkt)))
              (print "#;keydata " pkt)
              (cond ((or (eof-object? pkt)
                         (eq? pkt 'unsupported-public-key-version)
@@ -969,13 +988,13 @@ there is no limit."
                     ;; packets.
                     (lp pkt
                         (- limit 1)
-                        (fold (cute vhash-consv <> (reverse pkts) <>)
-                              keyring key-ids)))
+                        (fold (cute keyring-insert <> <> (reverse pkts))
+                              keyring keys)))
                    ((openpgp-public-key? pkt)     ;subkey
                     (lp* (get-packet port) (cons pkt pkts)
-                         (cons (openpgp-public-key-id pkt) key-ids)))
+                         (cons pkt keys)))
                    (else
-                    (lp* (get-packet port) (cons pkt pkts) key-ids)))))
+                    (lp* (get-packet port) (cons pkt pkts) keys)))))
           (else
            ;; Skip until there's a primary key. Ignore errors...
            (lp (get-packet port) limit keyring)))))
diff --git a/tests/openpgp.scm b/tests/openpgp.scm
index 1709167..eac2e88 100644
--- a/tests/openpgp.scm
+++ b/tests/openpgp.scm
@@ -162,13 +162,15 @@ Pz7oopeN72xgggYUNT37ezqN3MeCqw0=
                     (call-with-input-file key read-radix-64)))))
     (match (lookup-key-by-id keyring %civodul-key-id)
       (((? openpgp-public-key? primary) packets ...)
-       (and (= (openpgp-public-key-id primary) %civodul-key-id)
-            (not (openpgp-public-key-subkey? primary))
-            (string=? (openpgp-format-fingerprint
-                       (openpgp-public-key-fingerprint primary))
-                      %civodul-fingerprint)
-            (string=? (openpgp-user-id-value (find openpgp-user-id? packets))
-                      "Ludovic Courtès <address@hidden>"))))))
+       (let ((fingerprint (openpgp-public-key-fingerprint primary)))
+         (and (= (openpgp-public-key-id primary) %civodul-key-id)
+              (not (openpgp-public-key-subkey? primary))
+              (string=? (openpgp-format-fingerprint fingerprint)
+                        %civodul-fingerprint)
+              (string=? (openpgp-user-id-value (find openpgp-user-id? packets))
+                        "Ludovic Courtès <address@hidden>")
+              (equal? (lookup-key-by-id keyring %civodul-key-id)
+                      (lookup-key-by-fingerprint keyring fingerprint))))))))
 
 (test-equal "get-openpgp-detached-signature/ascii"
   (list `(,%dsa-key-id ,%dsa-key-fingerprint dsa sha256)