2 files changed, 56 insertions, 10 deletions

diff --git a/guix/openpgp.scm b/guix/openpgp.scm
index bfdbe4b61b7..77a75373df2 100644
--- a/guix/openpgp.scm
+++ b/guix/openpgp.scm
@@ -33,6 +33,7 @@
 
             openpgp-signature?
             openpgp-signature-issuer
+            openpgp-signature-issuer-fingerprint
             openpgp-signature-public-key-algorithm
             openpgp-signature-hash-algorithm
             openpgp-signature-creation-time
@@ -345,7 +346,6 @@ hexadecimal format for fingerprints."
   ;; 12 = Revocation Key
 
 (define SUBPACKET-ISSUER 16)
-;; TODO: hashed SUBPACKET-ISSUER-FINGERPRINT-V4
 (define SUBPACKET-NOTATION-DATA 20)
 (define SUBPACKET-PREFERRED-HASH-ALGORITHMS 21)
 (define SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS 22)
@@ -358,8 +358,8 @@ hexadecimal format for fingerprints."
 (define SUBPACKET-REASON-FOR-REVOCATION 29)
 (define SUBPACKET-FEATURES 30)
   ;; 31 = Signature Target
-
 (define SUBPACKET-EMBEDDED-SIGNATURE 32)
+(define SUBPACKET-ISSUER-FINGERPRINT 33)          ;defined in RFC4880bis
 
 (define SIGNATURE-BINARY #x00)
 (define SIGNATURE-TEXT #x01)
@@ -486,6 +486,13 @@ hexadecimal format for fingerprints."
         ;; XXX: is the issuer always in the unhashed subpackets?
         (else #f)))
 
+(define (openpgp-signature-issuer-fingerprint sig)
+  "When it's available, return the fingerprint, a bytevector, or the issuer of
+SIG.  Otherwise, return #f."
+  (or (assoc-ref (openpgp-signature-hashed-subpackets sig) 'issuer-fingerprint)
+      (assoc-ref (openpgp-signature-unhashed-subpackets sig)
+                 'issuer-fingerprint)))
+
 (define (openpgp-signature-creation-time sig)
   (cond ((assq 'signature-ctime (openpgp-signature-hashed-subpackets sig))
          => (lambda (x) (unixtime (cdr x))))
@@ -578,6 +585,14 @@ the issuer's OpenPGP public key extracted from KEYRING."
               (values 'missing-key issuer))))
       (values 'unsupported-signature sig)))
 
+(define (key-id-matches-fingerprint? key-id fingerprint)
+  "Return true if KEY-ID, a number, corresponds to the low 8 bytes of
+FINGERPRINT, a bytevector."
+  (let* ((len (bytevector-length fingerprint))
+         (low (make-bytevector 8)))
+    (bytevector-copy! fingerprint (- len 8) low 0 8)
+    (= (bytevector->uint low) key-id)))
+
 (define (get-signature p)
   (define (->hex n)
     (string-hex-pad (number->string n 16)))
@@ -662,14 +677,26 @@ the issuer's OpenPGP public key extracted from KEYRING."
                     ;; Errata ID: 2214.
                     (integers->bytevector u8 #x04
                                           u8 #xff
-                                          u32 (+ 6 subpacket-len)))))
+                                          u32 (+ 6 subpacket-len))))
+                  (unhashed-subpackets
+                   (parse-subpackets unhashed-subpackets))
+                  (hashed-subpackets (parse-subpackets hashed-subpackets))
+                  (subpackets        (append hashed-subpackets
+                                             unhashed-subpackets))
+                  (issuer-key-id     (assoc-ref subpackets 'issuer))
+                  (issuer            (assoc-ref subpackets
+                                                'issuer-fingerprint)))
+             (unless (or (not issuer) (not issuer-key-id)
+                         (key-id-matches-fingerprint? issuer-key-id issuer))
+               (error "issuer key id does not match fingerprint" issuer))
+
              (make-openpgp-signature version type
                                      (public-key-algorithm pkalg)
                                      (openpgp-hash-algorithm halg)
                                      hashl16
                                      append-data
-                                     (parse-subpackets hashed-subpackets)
-                                     (parse-subpackets unhashed-subpackets)
+                                     hashed-subpackets
+                                     unhashed-subpackets
                                      value)))))
       (else
        (print "Unsupported signature version: " version)
@@ -701,6 +728,13 @@ the issuer's OpenPGP public key extracted from KEYRING."
        ((= type SUBPACKET-ISSUER)
         (cons 'issuer
               (bytevector-u64-ref data 0 (endianness big))))
+       ((= type SUBPACKET-ISSUER-FINGERPRINT)     ;v4+ only, RFC4880bis
+        (cons 'issuer-fingerprint
+              (let* ((version     (bytevector-u8-ref data 0))
+                     (len         (match version (4 20) (5 32)) )
+                     (fingerprint (make-bytevector len)))
+                (bytevector-copy! data 1 fingerprint 0 len)
+                fingerprint)))
        ((= type SUBPACKET-NOTATION-DATA)
         (let ((p (open-bytevector-input-port data)))
           (let-values (((f1 nlen vlen)
diff --git a/tests/openpgp.scm b/tests/openpgp.scm
index 8a3c7bbeb7d..20d65171fd8 100644
--- a/tests/openpgp.scm
+++ b/tests/openpgp.scm
@@ -18,6 +18,7 @@
 
 (define-module (tests-openpgp)
   #:use-module (guix openpgp)
+  #:use-module (gcrypt base16)
   #:use-module (gcrypt hash)
   #:use-module (gcrypt pk-crypto)
   #:use-module (ice-9 binary-ports)
@@ -65,6 +66,16 @@ vBSFjNSiVHsuAA==
 (define %dsa-key-id      #x587918047BE8BD2C)      ;dsa.key
 (define %ed25519-key-id  #x771F49CBFAAE072D)      ;ed25519.key
 
+(define %rsa-key-fingerprint
+  (base16-string->bytevector
+   (string-downcase "385F86CFC86B665A5C165E6BAE25DA2A70DEED59")))
+(define %dsa-key-fingerprint
+  (base16-string->bytevector
+   (string-downcase "2884A980422330A4F33DD97F587918047BE8BD2C")))
+(define %ed25519-key-fingerprint
+  (base16-string->bytevector
+   (string-downcase "44D31E21AF7138F9B632280A771F49CBFAAE072D")))
+
 
 ;;; The following are detached signatures created commands like:
 ;;;    echo 'Hello!' | gpg -sba --digest-algo sha512
@@ -160,15 +171,16 @@ Pz7oopeN72xgggYUNT37ezqN3MeCqw0=
                       "Ludovic Courtès <ludo@gnu.org>"))))))
 
 (test-equal "get-openpgp-detached-signature/ascii"
-  (list `(,%dsa-key-id dsa sha256)
-        `(,%rsa-key-id rsa sha256)
-        `(,%ed25519-key-id eddsa sha256)
-        `(,%ed25519-key-id eddsa sha512)
-        `(,%ed25519-key-id eddsa sha1))
+  (list `(,%dsa-key-id ,%dsa-key-fingerprint dsa sha256)
+        `(,%rsa-key-id ,%rsa-key-fingerprint rsa sha256)
+        `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha256)
+        `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha512)
+        `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha1))
   (map (lambda (str)
          (let ((signature (get-openpgp-detached-signature/ascii
                            (open-input-string str))))
            (list (openpgp-signature-issuer signature)
+                 (openpgp-signature-issuer-fingerprint signature)
                  (openpgp-signature-public-key-algorithm signature)
                  (openpgp-signature-hash-algorithm signature))))
        (list %hello-signature/dsa