Add (guix openpgp).

* guix/openpgp.scm, tests/openpgp.scm, tests/civodul.key,
tests/dsa.key, tests/ed25519.key, tests/rsa.key,
tests/ed25519.sec: New files.
* Makefile.am (MODULES): Add guix/openpgp.scm.
(SCM_TESTS): Add tests/openpgp.scm.
(EXTRA_DIST): Add tests/*.key and tests/ed25519.sec.

1 files changed, 1022 insertions, 0 deletions

diff --git a/guix/openpgp.scm b/guix/openpgp.scm
new file mode 100644
index 0000000000..bfdbe4b61b
--- /dev/null
+++ b/guix/openpgp.scm
@@ -0,0 +1,1022 @@
+;; -*- mode: scheme; coding: utf-8 -*-
+;; Copyright © 2010, 2012 Göran Weinholt <goran@weinholt.se>
+;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the "Software"),
+;; to deal in the Software without restriction, including without limitation
+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;; and/or sell copies of the Software, and to permit persons to whom the
+;; Software is furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;; DEALINGS IN THE SOFTWARE.
+
+;;; This code was originally written by Göran Weinholt for Industria and
+;;; released under the Expat license shown above.  It was then modified by
+;;; Ludovic Courtès for use in GNU Guix: turned into a native Guile module,
+;;; ported to Guile-Gcrypt, and extended and simplified in other ways.
+
+(define-module (guix openpgp)
+  #:export (get-openpgp-detached-signature/ascii
+            (get-packet . get-openpgp-packet)
+            verify-openpgp-signature
+            port-ascii-armored?
+
+            openpgp-signature?
+            openpgp-signature-issuer
+            openpgp-signature-public-key-algorithm
+            openpgp-signature-hash-algorithm
+            openpgp-signature-creation-time
+            openpgp-signature-expiration-time
+
+            openpgp-user-id?
+            openpgp-user-id-value
+            openpgp-user-attribute?
+
+            openpgp-public-key?
+            openpgp-public-key-subkey?
+            openpgp-public-key-value
+            openpgp-public-key-fingerprint openpgp-format-fingerprint
+            openpgp-public-key-id
+
+            openpgp-keyring?
+            %empty-keyring
+            lookup-key-by-id
+            get-openpgp-keyring
+
+            read-radix-64)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-60)
+  #:use-module (ice-9 match)
+  #:use-module ((ice-9 rdelim) #:select (read-line))
+  #:use-module (ice-9 vlist)
+  #:use-module (gcrypt hash)
+  #:use-module (gcrypt pk-crypto)
+  #:use-module (gcrypt base64)
+  #:use-module (gcrypt base16)
+  #:use-module ((guix build utils) #:select (dump-port)))
+
+;;; Commentary:
+;;;
+;;; This module contains code to read OpenPGP messages as described in
+;;; <https://tools.ietf.org/html/rfc4880>, with extensions from
+;;; <https://tools.ietf.org/html/draft-ietf-openpgp-rfc4880bis-06> (notably
+;;; EdDSA support and extra signature sub-packets).
+;;;
+;;; Currently this module does enough to verify detached signatures of binary
+;;; data.  It does _not_ perform sanity checks on self-signatures, subkey
+;;; binding signatures, etc., among others.  Use only in a context where this
+;;; limitations are acceptable!
+;;;
+;;; Code:
+
+(define-syntax print
+  (syntax-rules ()
+    ;; ((_ args ...) (pk 'openpgp args))
+    ((_ args ...) (values))))
+
+(define-syntax-rule (define-alias new old)
+  (define-syntax new (identifier-syntax old)))
+
+(define-alias fx+ +)
+(define-alias fx- -)
+(define-alias fx* *)
+(define-alias fx/ /)
+(define-alias fxdiv quotient)
+(define-alias fxand logand)
+(define-alias fxbit-set? bit-set?)
+(define-alias fxbit-field bit-field)
+(define-alias bitwise-bit-field bit-field)
+(define-alias fxarithmetic-shift-left ash)
+(define-inlinable (fxarithmetic-shift-right i n) (ash i (- n)))
+(define-inlinable (port-eof? port) (eof-object? (lookahead-u8 port)))
+
+(define (string-hex-pad str)
+  (if (odd? (string-length str))
+      (string-append "0" str)
+      str))
+
+(define (unixtime n)
+  (time-monotonic->date (make-time 'time-monotonic 0 n)))
+
+
+;;;
+;;; Bitwise I/O.
+;;;
+;;; TODO: Use Bytestructures instead.
+;;;
+
+(define-syntax-rule (integer-read size)
+  (lambda (port)
+    "Read from PORT a big-endian integer of SIZE bytes.  Return the EOF object
+on end-of-file."
+    (let ((buf (make-bytevector size)))
+      (match (get-bytevector-n! port buf 0 size)
+        (size (bytevector-uint-ref buf 0 (endianness big) size))
+        (_    (eof-object))))))
+
+(define get-u16 (integer-read 2))
+(define get-u32 (integer-read 4))
+(define get-u64 (integer-read 8))
+
+(define-syntax get-integers
+  (syntax-rules ()
+    "Read from PORT integers of the given TYPE, in big endian encoding.  Each
+TYPE must be one of u8, u16, u32, u64, or _, as in this example:
+
+  (get-integers port u8 _ _ _ u32 u16)
+
+In the case of _ (wildcard), one byte is read and discarded.  Return as many
+values as there are TYPEs."
+    ((_ port type ...)
+     (letrec-syntax ((get-integer (syntax-rules (u8 u16 u32 u64)
+                                    ((x u8) (get-u8 port))
+                                    ((x u16) (get-u16 port))
+                                    ((x u32) (get-u32 port))
+                                    ((x u64) (get-u64 port))))
+                     (values*     (syntax-rules (_)
+                                    ((x (result (... ...)))
+                                     (values result (... ...)))
+                                    ((x (result (... ...)) _ rest (... ...))
+                                     (let ((x (get-u8 port)))
+                                       (values* (result (... ...))
+                                                rest (... ...))))
+                                    ((x (result (... ...)) t rest (... ...))
+                                     (let ((x (get-integer t)))
+                                       (values* (result (... ...) x)
+                                                rest (... ...)))))))
+       (values* () type ...)))))
+
+(define (bytevector->uint bv)
+  (bytevector-uint-ref bv 0 (endianness big)
+                       (bytevector-length bv)))
+
+(define-syntax-rule (integer-write size)
+  (lambda (port integer)
+    "Write INTEGER to PORT as a SIZE-byte integer and as big endian."
+    (let ((bv (make-bytevector size)))
+      (bytevector-uint-set! bv 0 integer (endianness big) size)
+      (put-bytevector port bv))))
+
+(define put-u16 (integer-write 2))
+(define put-u32 (integer-write 4))
+(define put-u64 (integer-write 8))
+
+(define-syntax put-integers
+  (syntax-rules ()
+    "Write the given integers as big endian to PORT.  For example:
+
+  (put-integers port u8 42 u32 #x7777)
+
+writes to PORT the value 42 as an 8-bit integer and the value #x7777 as a
+32-bit integer."
+    ((_ port)
+     #t)
+    ((_ port type value rest ...)
+     (let-syntax ((put (syntax-rules (u8 u16 u32 u64)
+                         ((_ u8 port integer)
+                          (put-u8 port integer))
+                         ((_ u16 port integer)
+                          (put-u16 port integer))
+                         ((_ u32 port integer)
+                          (put-u32 port integer))
+                         ((_ u64 port integer)
+                          (put-u64 port integer)))))
+       (begin
+         (put type port value)
+         (put-integers port rest ...))))))
+
+(define-syntax-rule (integers->bytevector type value rest ...)
+  "Return the the TYPE/VALUE integers representation as a bytevector."
+  (let-values (((port get) (open-bytevector-output-port)))
+    (put-integers port type value rest ...)
+    (force-output port)
+    (get)))
+
+
+(define (bytevector->bitnames bv names)
+  (define (bit-set? bv i)
+    (let ((idx (fxarithmetic-shift-right i 3))
+          (bit (fxand i #b111)))
+      (and (< idx (bytevector-length bv))
+           (fxbit-set? (bytevector-u8-ref bv idx) bit))))
+  (do ((names names (cdr names))
+       (i 0 (fx+ i 1))
+       (bits '()
+             (if (bit-set? bv i)
+                 (cons (car names) bits)
+                 bits)))
+      ((null? names) (reverse bits))))
+
+(define (openpgp-format-fingerprint bv)
+  "Return a string representing BV, a bytevector, in the conventional OpenPGP
+hexadecimal format for fingerprints."
+  (define (h i)
+    (string-pad (string-upcase
+                 (number->string
+                  (bytevector-u16-ref bv (* i 2) (endianness big))
+                  16))
+                4 #\0))
+  (string-append (h 0) " " (h 1) " " (h 2) " " (h 3) " " (h 4)
+                 "  "
+                 (h 5) " " (h 6) " " (h 7) " " (h 8) " " (h 9)))
+
+;;; Constants
+
+
+(define PACKET-SESSION-KEY 1)
+(define PACKET-SIGNATURE 2)
+(define PACKET-SYMMETRIC-SESSION-KEY 3)
+(define PACKET-ONE-PASS-SIGNATURE 4)
+(define PACKET-SECRET-KEY 5)
+(define PACKET-PUBLIC-KEY 6)
+(define PACKET-SECRET-SUBKEY 7)
+(define PACKET-COMPRESSED-DATA 8)
+(define PACKET-SYMMETRIC-ENCRYPTED-DATA 9)
+(define PACKET-MARKER 10)
+(define PACKET-LITERAL-DATA 11)
+(define PACKET-TRUST 12)
+(define PACKET-USER-ID 13)
+(define PACKET-PUBLIC-SUBKEY 14)
+(define PACKET-USER-ATTRIBUTE 17)
+(define PACKET-SYMMETRIC-ENCRYPTED/PROTECTED-DATA 18)
+(define PACKET-MDC 19)
+
+(define PUBLIC-KEY-RSA 1)
+(define PUBLIC-KEY-RSA-ENCRYPT-ONLY 2)
+(define PUBLIC-KEY-RSA-SIGN-ONLY 3)
+(define PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY 16)
+(define PUBLIC-KEY-DSA 17)
+(define PUBLIC-KEY-ECDH 18)                       ;RFC-6637
+(define PUBLIC-KEY-ECDSA 19)                      ;RFC-6639
+(define PUBLIC-KEY-ELGAMAL 20)                    ;encrypt + sign (legacy)
+(define PUBLIC-KEY-EDDSA 22)                      ;"not yet assigned" says GPG
+
+(define (public-key-algorithm id)
+  (cond ((= id PUBLIC-KEY-RSA) 'rsa)
+        ((= id PUBLIC-KEY-DSA) 'dsa)
+        ((= id PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) 'elgamal)
+        ((= id PUBLIC-KEY-EDDSA) 'eddsa)
+        (else id)))
+
+(define SYMMETRIC-KEY-PLAINTEXT 0)
+(define SYMMETRIC-KEY-IDEA 1)
+(define SYMMETRIC-KEY-TRIPLE-DES 2)
+(define SYMMETRIC-KEY-CAST5-128 3)
+(define SYMMETRIC-KEY-BLOWFISH-128 4)
+(define SYMMETRIC-KEY-AES-128 7)
+(define SYMMETRIC-KEY-AES-192 8)
+(define SYMMETRIC-KEY-AES-256 9)
+(define SYMMETRIC-KEY-TWOFISH-256 10)
+(define SYMMETRIC-KEY-CAMELLIA-128 11)            ;RFC-5581
+(define SYMMETRIC-KEY-CAMELLIA-192 12)
+(define SYMMETRIC-KEY-CAMELLIA-256 13)
+
+(define (symmetric-key-algorithm id)
+  (cond ((= id SYMMETRIC-KEY-PLAINTEXT) 'plaintext)
+        ((= id SYMMETRIC-KEY-IDEA) 'idea)
+        ((= id SYMMETRIC-KEY-TRIPLE-DES) 'tdea)
+        ((= id SYMMETRIC-KEY-CAST5-128) 'cast5-128)
+        ((= id SYMMETRIC-KEY-BLOWFISH-128) 'blowfish-128)
+        ((= id SYMMETRIC-KEY-AES-128) 'aes-128)
+        ((= id SYMMETRIC-KEY-AES-192) 'aes-192)
+        ((= id SYMMETRIC-KEY-AES-256) 'aes-256)
+        ((= id SYMMETRIC-KEY-TWOFISH-256) 'twofish-256)
+        (else id)))
+
+(define HASH-MD5 1)
+(define HASH-SHA-1 2)
+(define HASH-RIPE-MD160 3)
+(define HASH-SHA-256 8)
+(define HASH-SHA-384 9)
+(define HASH-SHA-512 10)
+(define HASH-SHA-224 11)
+
+(define (openpgp-hash-algorithm id)
+  (cond ((= id HASH-MD5) 'md5)
+        ((= id HASH-SHA-1) 'sha1)
+        ((= id HASH-RIPE-MD160) 'rmd160)
+        ((= id HASH-SHA-256) 'sha256)
+        ((= id HASH-SHA-384) 'sha384)
+        ((= id HASH-SHA-512) 'sha512)
+        ((= id HASH-SHA-224) 'sha224)
+        (else (error "unknown hash algorithm" id))))
+
+(define COMPRESSION-UNCOMPRESSED 0)
+(define COMPRESSION-ZIP 1)                      ;deflate
+
+(define COMPRESSION-ZLIB 2)
+(define COMPRESSION-BZIP2 3)
+
+(define (compression-algorithm id)
+  (cond ((= id COMPRESSION-UNCOMPRESSED) 'uncompressed)
+        ((= id COMPRESSION-ZIP) 'deflate)
+        ((= id COMPRESSION-ZLIB) 'zlib)
+        ((= id COMPRESSION-BZIP2) 'bzip2)
+        (else id)))
+
+(define SUBPACKET-SIGNATURE-CTIME 2)
+(define SUBPACKET-SIGNATURE-ETIME 3)
+  ;;  4 = Exportable Certification
+
+(define SUBPACKET-TRUST-SIGNATURE 5)
+  ;;  6 = Regular Expression
+
+(define SUBPACKET-REVOCABLE 7)
+(define SUBPACKET-KEY-ETIME 9)
+(define SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS 11)
+  ;; 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)
+(define SUBPACKET-KEY-SERVER-PREFERENCES 23)
+(define SUBPACKET-PREFERRED-KEY-SERVER 24)
+(define SUBPACKET-PRIMARY-USER-ID 25)
+(define SUBPACKET-POLICY-URI 26)
+(define SUBPACKET-KEY-FLAGS 27)
+(define SUBPACKET-SIGNER-USER-ID 28)
+(define SUBPACKET-REASON-FOR-REVOCATION 29)
+(define SUBPACKET-FEATURES 30)
+  ;; 31 = Signature Target
+
+(define SUBPACKET-EMBEDDED-SIGNATURE 32)
+
+(define SIGNATURE-BINARY #x00)
+(define SIGNATURE-TEXT #x01)
+(define SIGNATURE-STANDALONE #x02)
+(define SIGNATURE-GENERIC-CERT #x10)
+(define SIGNATURE-PERSONA-CERT #x11)
+(define SIGNATURE-CASUAL-CERT #x12)
+(define SIGNATURE-POSITIVE-CERT #x13)
+(define SIGNATURE-SUBKEY-BINDING #x18)
+(define SIGNATURE-PRIMARY-KEY-BINDING #x19)
+(define SIGNATURE-DIRECT #x1f)
+(define SIGNATURE-KEY-REVOCATION #x20)
+(define SIGNATURE-SUBKEY-REVOCATION #x28)
+(define SIGNATURE-CERT-REVOCATION #x30)
+(define SIGNATURE-TIMESTAMP #x40)
+(define SIGNATURE-THIRD-PARTY #x50)
+
+;;; Parsing
+
+  ;; Look at the tag byte and see if it looks reasonable, if it does
+  ;; then the file is likely not armored. Does not move the port
+  ;; position.
+
+(define (port-ascii-armored? p)
+  (let ((tag (lookahead-u8 p)))
+    (cond ((eof-object? tag) #f)
+          ((not (fxbit-set? tag 7)) #t)
+          (else
+           (let ((type (if (fxbit-set? tag 6)
+                           (fxbit-field tag 0 6)
+                           (fxbit-field tag 2 6))))
+             (not (<= PACKET-SESSION-KEY type PACKET-MDC)))))))
+
+(define (get-mpi/bytevector p)
+  (let* ((bitlen  (get-u16 p))
+         (bytelen (fxdiv (fx+ bitlen 7) 8)))
+    (get-bytevector-n p bytelen)))
+
+(define (get-mpi p)
+  (bytevector->uint (get-mpi/bytevector p)))
+
+(define (get-v4-length p)
+  ;; TODO: indeterminate length (only for data packets)
+  (let ((o1 (get-u8 p)))
+    (cond ((< o1 192) o1)
+          ((< o1 255)
+           (+ (fxarithmetic-shift-left (fx- o1 192) 8)
+              (get-u8 p)
+              192))
+          ((= o1 255)
+           (get-u32 p)))))
+
+(define (get-packet p)
+  (if (port-eof? p)
+      (eof-object)
+      (get-packet* p get-data)))
+
+(define (get-packet* p get-data)
+  (let ((tag (get-u8 p)))
+    ;; (unless (fxbit-set? tag 7) (error 'get-packet "Invalid tag" tag))
+    (cond ((fxbit-set? tag 6)                     ;New packet format
+           (let ((tag (fxbit-field tag 0 6))
+                 (len (get-v4-length p)))
+             (get-data p tag len)))
+          (else                                   ;Old packet format
+           (let ((tag (fxbit-field tag 2 6))
+                 (len (case (fxbit-field tag 0 2)
+                        ((0) (get-u8 p))
+                        ((1) (get-u16 p))
+                        ((2) (get-u32 p))
+                        ((3) #f))))
+             (get-data p tag len))))))
+
+(define (get-data p tag len)
+  (let ((pp (if len
+                (open-bytevector-input-port (get-bytevector-n p len))
+                p)))                              ;indeterminate length
+    (cond
+     ((= tag PACKET-SIGNATURE)
+      (get-signature pp))
+     ((= tag PACKET-PUBLIC-KEY)
+      (get-public-key pp #f))
+     ((= tag PACKET-TRUST)
+      'openpgp-trust)                             ;XXX: non-standard format?
+     ((= tag PACKET-USER-ID)
+      (get-user-id pp len))
+     ((= tag PACKET-PUBLIC-SUBKEY)
+      (get-public-key pp #t))
+     ((= tag PACKET-USER-ATTRIBUTE)
+      (get-user-attribute pp len))
+     ((= tag PACKET-ONE-PASS-SIGNATURE)
+      'one-pass-signature)                        ;TODO: implement
+     (else
+      (error 'get-data "Unsupported packet type" tag)))))
+
+(define-record-type <openpgp-public-key>
+  (make-openpgp-public-key version subkey? time value fingerprint)
+  openpgp-public-key?
+  (version      openpgp-public-key-version)
+  (subkey?      openpgp-public-key-subkey?)
+  (time         openpgp-public-key-time)
+  (value        openpgp-public-key-value)
+  (fingerprint  openpgp-public-key-fingerprint))
+
+;;; Signatures
+
+(define-record-type <openpgp-signature>
+  (make-openpgp-signature version type pk-algorithm hash-algorithm hashl16
+                          append-data hashed-subpackets unhashed-subpackets
+                          value)
+  openpgp-signature?
+  (version               openpgp-signature-version)
+  (type                  openpgp-signature-type)
+  (pk-algorithm          openpgp-signature-public-key-algorithm)
+  (hash-algorithm        openpgp-signature-hash-algorithm)
+  (hashl16               openpgp-signature-hashl16) ;left 16 bits of signed hash
+  (append-data           openpgp-signature-append-data) ;append to data when hashing
+  (hashed-subpackets     openpgp-signature-hashed-subpackets)
+  (unhashed-subpackets   openpgp-signature-unhashed-subpackets)
+  (value                 openpgp-signature-value))
+
+(define (openpgp-signature-issuer sig)
+  (cond ((assq 'issuer (openpgp-signature-unhashed-subpackets sig)) => cdr)
+        ;; XXX: is the issuer always in the unhashed subpackets?
+        (else #f)))
+
+(define (openpgp-signature-creation-time sig)
+  (cond ((assq 'signature-ctime (openpgp-signature-hashed-subpackets sig))
+         => (lambda (x) (unixtime (cdr x))))
+        ;; XXX: should be an error?
+        (else #f)))
+
+(define (openpgp-signature-expiration-time sig)
+  (cond ((assq 'signature-etime (openpgp-signature-hashed-subpackets sig))
+         => (lambda (x)
+              (unixtime (+ (cdr x)
+                           (openpgp-signature-creation-time sig)))))
+        (else #f)))
+
+
+(define (get-openpgp-detached-signature/ascii port)
+  "Read from PORT an ASCII-armored detached signature.  Return an
+<openpgp-signature> record or the end-of-file object.  Raise an error if the
+data read from PORT does is invalid or does not correspond to a detached
+signature."
+  (let-values (((data type) (read-radix-64 port)))
+    (cond ((eof-object? data) data)
+          ((string=? type "PGP SIGNATURE")
+           (get-packet (open-bytevector-input-port data)))
+          (else
+           (error "expected PGP SIGNATURE" type)))))
+
+(define (hash-algorithm-name algorithm)        ;XXX: should be in Guile-Gcrypt
+  "Return the name of ALGORITHM, a 'hash-algorithm' integer, as a symbol."
+  (letrec-syntax ((->name (syntax-rules ()
+                            ((_) #f)
+                            ((_ name rest ...)
+                             (if (= algorithm (hash-algorithm name))
+                                 'name
+                                 (->name rest ...))))))
+    (->name sha1 sha256 sha384 sha512 sha224
+            sha3-224 sha3-256 sha3-384 sha3-512)))
+
+(define (verify-openpgp-signature sig keyring dataport)
+  "Verify that the data read from DATAPORT matches SIG, an
+<openpgp-signature>.  Fetch the public key of the issuer of SIG from KEYRING,
+a keyring as returned by 'get-openpgp-keyring'.  Return two values: a status
+symbol, such as 'bad-signature or 'missing-key, and additional info, such as
+the issuer's OpenPGP public key extracted from KEYRING."
+  (define (check key sig)
+    (let*-values (((hash-algorithm) (lookup-hash-algorithm
+                                     (openpgp-signature-hash-algorithm sig)))
+                  ((port get-hash) (open-hash-port hash-algorithm)))
+      (dump-port dataport port)
+
+      ;; As per RFC4880 Section 5.2.4 ("Computing Signatures"), hash some of
+      ;; the fields from the signature packet.
+      (for-each (cut put-bytevector port <>)
+                (openpgp-signature-append-data sig))
+      (close-port port)
+
+      (let* ((signature  (openpgp-signature-value sig))
+             (public-key (openpgp-public-key-value key))
+             (hash       (get-hash))
+             (key-type   (key-type public-key))
+             (data
+              ;; See "(gcrypt) Cryptographic Functions".
+              (sexp->canonical-sexp
+               (if (eq? key-type 'ecc)
+                   `(data
+                     (flags eddsa)
+                     (hash-algo sha512)
+                     (value ,hash))
+                   `(data
+                     (flags ,(match key-type
+                               ('rsa 'pkcs1)
+                               ('dsa 'rfc6979)))
+                     (hash ,(hash-algorithm-name hash-algorithm)
+                           ,hash))))))
+        (values (if (verify signature data public-key)
+                    'good-signature
+                    'bad-signature)
+                key))))
+
+  ;; TODO: Support SIGNATURE-TEXT.
+  (if (= (openpgp-signature-type sig) SIGNATURE-BINARY)
+      (let* ((issuer   (openpgp-signature-issuer sig))
+             (key-data (lookup-key-by-id keyring issuer)))
+        ;; Find the primary key or subkey that made the signature.
+        (let ((key (find (lambda (k)
+                           (and (openpgp-public-key? k)
+                                (= (openpgp-public-key-id k) issuer)))
+                         key-data)))
+          (if key
+              (check key sig)
+              (values 'missing-key issuer))))
+      (values 'unsupported-signature sig)))
+
+(define (get-signature p)
+  (define (->hex n)
+    (string-hex-pad (number->string n 16)))
+
+  (define (get-sig p pkalg)
+    (cond ((= pkalg PUBLIC-KEY-RSA)
+           (print "RSA signature")
+           (string->canonical-sexp
+            (format #f "(sig-val (rsa (s #~a#)))"
+                    (->hex (get-mpi p)))))
+          ((= pkalg PUBLIC-KEY-DSA)
+           (print "DSA signature")
+           (let ((r (get-mpi p)) (s (get-mpi p)))
+             (string->canonical-sexp
+              (format #f "(sig-val (dsa (r #~a#) (s #~a#)))"
+                      (->hex r) (->hex s)))))
+          ((= pkalg PUBLIC-KEY-EDDSA)
+           (print "EdDSA signature")
+           (let ((r (get-mpi/bytevector p))
+                 (s (get-mpi/bytevector p)))
+             ;; XXX: 'verify' fails down the road with GPG_ERR_INV_LENGTH if
+             ;; we provide a 31-byte R or S below, hence the second argument
+             ;; to '->hex' ensuring the MPIs are represented as two-byte
+             ;; multiples, with leading zeros.
+             (define (bytevector->hex bv)
+               (let ((str (bytevector->base16-string bv)))
+                 (if (odd? (bytevector-length bv))
+                     (string-append "00" str)
+                     str)))
+
+             (string->canonical-sexp
+              (format #f "(sig-val (eddsa (r #~a#) (s #~a#)))"
+                      (bytevector->hex r) (bytevector->hex s)))))
+          (else
+           (list 'unsupported-algorithm
+                 (public-key-algorithm pkalg)
+                 (get-bytevector-all p)))))
+  (let ((version (get-u8 p)))
+    (case version
+      ((3)
+       (let-values (((hmlen type ctime keyid pkalg halg hashl16)
+                     (get-integers p u8 u8 u32 u64 u8 u8 u16)))
+         (unless (= hmlen 5)
+           (error "invalid signature packet"))
+         (print "Signature type: " type " creation time: " (unixtime ctime))
+         (print "Hash algorithm: " (openpgp-hash-algorithm halg))
+         (let ((value (get-sig p pkalg)))
+           (unless (port-eof? p)
+             (print "Trailing data in signature: " (get-bytevector-all p)))
+           (make-openpgp-signature version type
+                                   (public-key-algorithm pkalg)
+                                   (openpgp-hash-algorithm halg) hashl16
+                                   (list (integers->bytevector u8 type
+                                                               u32 ctime))
+                                   ;; Emulate hashed subpackets
+                                   (list (cons 'signature-ctime ctime))
+                                   ;; Unhashed subpackets
+                                   (list (cons 'issuer keyid))
+                                   value))))
+      ((4)
+       (let*-values (((type pkalg halg) (get-integers p u8 u8 u8))
+                     ((hashed-subpackets)
+                      (get-bytevector-n p (get-u16 p)))
+                     ((unhashed-subpackets)
+                      (get-bytevector-n p (get-u16 p)))
+                     ((hashl16) (get-u16 p)))
+         (print "Signature type: " type)
+         (print "Hash algorithm: " (openpgp-hash-algorithm halg))
+         (let ((value (get-sig p pkalg)))
+           (unless (port-eof? p)
+             (print "Trailing data in signature: " (get-bytevector-all p)))
+           (let* ((subpacket-len (bytevector-length hashed-subpackets))
+                  (append-data
+                   (list
+                    (integers->bytevector u8 version
+                                          u8 type
+                                          u8 pkalg
+                                          u8 halg
+                                          u16 subpacket-len)
+                    hashed-subpackets
+                    ;; http://www.rfc-editor.org/errata_search.php?rfc=4880
+                    ;; Errata ID: 2214.
+                    (integers->bytevector u8 #x04
+                                          u8 #xff
+                                          u32 (+ 6 subpacket-len)))))
+             (make-openpgp-signature version type
+                                     (public-key-algorithm pkalg)
+                                     (openpgp-hash-algorithm halg)
+                                     hashl16
+                                     append-data
+                                     (parse-subpackets hashed-subpackets)
+                                     (parse-subpackets unhashed-subpackets)
+                                     value)))))
+      (else
+       (print "Unsupported signature version: " version)
+       'unsupported-signature-version))))
+
+(define (parse-subpackets bv)
+  (define (parse tag data)
+    (let ((type (fxbit-field tag 0 7))
+          (critical? (fxbit-set? tag 7)))
+      (cond
+       ((= type SUBPACKET-SIGNATURE-CTIME)
+        (cons 'signature-ctime
+              (bytevector-u32-ref data 0 (endianness big))))
+       ((= type SUBPACKET-SIGNATURE-ETIME)
+        (cons 'signature-etime
+              (bytevector-u32-ref data 0 (endianness big))))
+       ((= type SUBPACKET-TRUST-SIGNATURE)
+        (cons 'trust-signature
+              (bytevector-u8-ref data 0)))
+       ((= type SUBPACKET-REVOCABLE)
+        (cons 'revocable
+              (= (bytevector-u8-ref data 0) 1)))
+       ((= type SUBPACKET-KEY-ETIME)
+        (cons 'key-etime
+              (bytevector-u32-ref data 0 (endianness big))))
+       ((= type SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS)
+        (cons 'preferred-symmetric-algorithms
+              (map symmetric-key-algorithm (bytevector->u8-list data))))
+       ((= type SUBPACKET-ISSUER)
+        (cons 'issuer
+              (bytevector-u64-ref data 0 (endianness big))))
+       ((= type SUBPACKET-NOTATION-DATA)
+        (let ((p (open-bytevector-input-port data)))
+          (let-values (((f1 nlen vlen)
+                        (get-integers p u8 _ _ _ u16 u16)))
+            (let* ((name (get-bytevector-n p nlen))
+                   (value (get-bytevector-n p vlen)))
+              (cons 'notation-data
+                    (list (utf8->string name)
+                          (if (fxbit-set? f1 7)
+                              (utf8->string value)
+                              value)))))))
+       ((= type SUBPACKET-PREFERRED-HASH-ALGORITHMS)
+        (cons 'preferred-hash-algorithms
+              (map openpgp-hash-algorithm (bytevector->u8-list data))))
+       ((= type SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS)
+        (cons 'preferred-compression-algorithms
+              (map compression-algorithm (bytevector->u8-list data))))
+       ((= type SUBPACKET-KEY-SERVER-PREFERENCES)
+        (cons 'key-server-preferences
+              (if (and (>= (bytevector-length data) 1)
+                       (fxbit-set? (bytevector-u8-ref data 0) 7))
+                  (list 'no-modify)
+                  (list))))
+       ((= type SUBPACKET-PREFERRED-KEY-SERVER)
+        (cons 'preferred-key-server (utf8->string data)))
+       ((= type SUBPACKET-PRIMARY-USER-ID)
+        (cons 'primary-user-id (not (zero? (bytevector-u8-ref data 0)))))
+       ((= type SUBPACKET-POLICY-URI)
+        (cons 'policy-uri (utf8->string data)))
+       ((= type SUBPACKET-KEY-FLAGS)
+        (cons 'key-flags (bytevector->bitnames
+                          data
+                          '(certification sign-data
+                                          communications-encryption
+                                          storage-encryption
+                                          split-key authentication
+                                          group-key))))
+       ((= type SUBPACKET-SIGNER-USER-ID)
+        (cons 'signer-user-id (utf8->string data)))
+       ((= type SUBPACKET-REASON-FOR-REVOCATION)
+        (let* ((p (open-bytevector-input-port data))
+               (revocation-code (get-u8 p)))
+          (cons 'reason-for-revocation
+                (list revocation-code
+                      (if (port-eof? p)
+                          ""
+                          (utf8->string (get-bytevector-all p)))))))
+       ((= type SUBPACKET-FEATURES)
+        (cons 'features (bytevector->bitnames
+                         data '(modification-detection))))
+       ((= type SUBPACKET-EMBEDDED-SIGNATURE)
+        (cons 'embedded-signature
+              (get-signature (open-bytevector-input-port data))))
+       (else
+        ;; Unknown subpacket type.  If it is critical, then the signature
+        ;; should be considered invalid.
+        (print "Unknown subpacket type: " type)
+        (if critical?
+            (error "unrecognized critical signature subpacket" type)
+            (list 'unsupported-subpacket type data))))))
+
+  (let ((p (open-bytevector-input-port bv)))
+    (let lp ((subpackets '()))
+      ;; In case of multiple subpackets of the same type, the last
+      ;; one should be used. Therefore the list is not reversed
+      ;; here.
+      (if (port-eof? p)
+          (reverse subpackets)
+          (let* ((len (- (get-v4-length p) 1))
+                 (tag (get-u8 p))
+                 (sp (parse tag (get-bytevector-n p len))))
+            (print "#;Subpacket " sp)
+            (lp (cons sp subpackets)))))))
+
+;;; Public keys
+
+
+(define (openpgp-public-key-id k)
+  (let ((bv (openpgp-public-key-fingerprint k)))
+    (bytevector-u64-ref bv
+                        (- (bytevector-length bv) 8)
+                        (endianness big))))
+
+(define (get-public-key p subkey?)
+  (define (fingerprint p)
+    (let ((len (port-position p)))
+      (set-port-position! p 0)
+      (let-values (((sha1-port get)
+                    (open-hash-port (hash-algorithm sha1))))
+        (put-u8 sha1-port #x99)
+        (put-u16 sha1-port len)
+        (dump-port p sha1-port)
+        (close-port sha1-port)
+        (get))))
+  (define (get-key p alg)
+    (define (->hex n)
+      (string-hex-pad (number->string n 16)))
+
+    (cond ((= alg PUBLIC-KEY-RSA)
+           (print "Public RSA key")
+           (let* ((n (get-mpi p)) (e (get-mpi p)))
+             (string->canonical-sexp
+              (format #f "(public-key (rsa (n #~a#) (e #~a#)))"
+                      (->hex n) (->hex e)))))
+          ((= alg PUBLIC-KEY-DSA)
+           (print "Public DSA key")
+           (let* ((p* (get-mpi p)) (q (get-mpi p))
+                  (g (get-mpi p)) (y (get-mpi p)))
+             (string->canonical-sexp
+              (format #f "(public-key (dsa (p #~a#)(q #~a#)(g #~a#)(y #~a#)))"
+                      (->hex p*) (->hex q) (->hex g) (->hex y)))))
+          #;
+          ((= alg PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) ; ; ; ;
+          (print "Public El-Gamal Key")         ; ; ; ;
+          (let* ((p* (get-mpi p)) (g (get-mpi p)) (y (get-mpi p))) ; ; ; ;
+          (make-public-elgamal-key p* g y)))
+          ((= alg PUBLIC-KEY-EDDSA)
+           ;; See
+           ;; <https://tools.ietf.org/html/draft-koch-eddsa-for-openpgp-04>
+           ;; and openpgp-oid.c in GnuPG.
+           (print "Public EdDSA key")
+           (let* ((len     (get-u8 p))
+                  (oid     (bytevector->uint (get-bytevector-n p len)))
+                  (q (get-mpi p)))
+             (define curve
+               (match oid
+                 (#x2b06010401da470f01   'Ed25519)
+                 (#x2b060104019755010501 'Curve25519)))
+
+             (string->canonical-sexp
+              (format #f "(public-key (ecc (curve ~a)(flags ~a)(q #~a#)))"
+                      curve
+                      (if (eq? curve 'Curve25519) 'djb-tweak 'eddsa)
+                      (->hex q)))))
+          (else
+           (list 'unsupported-algorithm           ;FIXME: throw
+                 (public-key-algorithm alg)
+                 (get-bytevector-all p)))))
+  (let ((version (get-u8 p)))
+    (case version
+      ((4)
+       (let-values (((ctime alg) (get-integers p u32 u8)))
+         (print "Key creation time: " (unixtime ctime))
+         (let ((key (get-key p alg)))
+           (unless (port-eof? p)
+             ;; Probably an error? Gonna cause trouble anyway.
+             (print "Trailing data in public key: " (get-bytevector-all p)))
+           (let ((digest (fingerprint p)))
+             (make-openpgp-public-key version subkey? ctime key
+                                      digest)))))
+      (else
+       (print "Unsupported public key version: " version)
+       'unsupported-public-key-version))))
+
+(define (openpgp-public-key-primary? key)
+  (and (openpgp-public-key? key)
+       (not (openpgp-public-key-subkey? key))))
+
+;;; User IDs and User attributes
+
+
+(define-record-type <openpgp-user-id>
+  (make-openpgp-user-id value unparsed)
+  openpgp-user-id?
+  (value     openpgp-user-id-value)
+  (unparsed  openpgp-user-id-unparsed))
+
+(define (get-user-id p len)
+  (let ((unparsed (get-bytevector-n p len)))
+    (make-openpgp-user-id (utf8->string unparsed) unparsed)))
+
+(define-record-type <openpgp-user-attribute>
+  (make-openpgp-user-attribute unparsed)
+  openpgp-user-attribute?
+  (unparsed   openpgp-user-attribute-unparsed))
+
+(define (get-user-attribute p len)
+  (let ((bv (get-bytevector-n p len)))
+    ;; TODO: bv contains subpackets. Type 1 is JFIF.
+    (make-openpgp-user-attribute bv)))
+
+
+;;; Keyring management
+
+(define-record-type <openpgp-keyring>
+  (openpgp-keyring table)
+  openpgp-keyring?
+  (table openpgp-keyring-table))              ;vhash mapping key id to packets
+
+(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))
+    ((_ . lst) lst)
+    (#f '())))
+
+;; Reads a keyring from the binary input port p. It must not be
+;; ASCII armored.
+
+(define %empty-keyring
+  ;; The empty keyring.
+  (openpgp-keyring vlist-null))
+
+(define* (get-openpgp-keyring port
+                              #:optional (keyring %empty-keyring)
+                              #:key (limit -1))
+  "Read from PORT an OpenPGP keyring in binary format; return a keyring based
+on all the OpenPGP primary keys that were read.  The returned keyring
+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)))
+    (print "#;key " pkt)
+    (cond ((or (zero? limit) (eof-object? pkt))
+           (openpgp-keyring keyring))
+          ((openpgp-public-key-primary? pkt)
+           ;; Read signatures, user id's, subkeys
+           (let lp* ((pkt (get-packet port))
+                     (pkts (list pkt))
+                     (key-ids (list (openpgp-public-key-id pkt))))
+             (print "#;keydata " pkt)
+             (cond ((or (eof-object? pkt)
+                        (eq? pkt 'unsupported-public-key-version)
+                        (openpgp-public-key-primary? pkt))
+                    ;; KEYRING is indexed by key-id.  Key ids for both the
+                    ;; primary key and subkeys all point to the list of
+                    ;; packets.
+                    (lp pkt
+                        (- limit 1)
+                        (fold (cute vhash-consv <> (reverse pkts) <>)
+                              keyring key-ids)))
+                   ((openpgp-public-key? pkt)     ;subkey
+                    (lp* (get-packet port) (cons pkt pkts)
+                         (cons (openpgp-public-key-id pkt) key-ids)))
+                   (else
+                    (lp* (get-packet port) (cons pkt pkts) key-ids)))))
+          (else
+           ;; Skip until there's a primary key. Ignore errors...
+           (lp (get-packet port) limit keyring)))))
+
+
+;;;
+;;; Radix-64 (RFC4880).
+;;;
+
+(define (crc24 bv)
+  "Compute a CRC24 as described in RFC4880, Section 6.1."
+  (define poly #x1864cfb)
+
+  (let loop ((crc #xb704ce)
+             (index 0))
+    (if (= index (bytevector-length bv))
+        (logand crc #xffffff)
+        (let ((crc (logxor (ash (bytevector-u8-ref bv index) 16)
+                           crc)))
+          (let inner ((i 0)
+                      (crc crc))
+            (if (< i 8)
+                (let ((crc (ash crc 1)))
+                  (inner (+ i 1)
+                         (if (zero? (logand crc #x1000000))
+                             crc
+                             (logxor crc poly))))
+                (loop crc (+ index 1))))))))
+
+(define %begin-block-prefix "-----BEGIN ")
+(define %begin-block-suffix "-----")
+
+(define %end-block-prefix "-----END ")
+(define %end-block-suffix "-----")
+
+(define (read-radix-64 port)
+  "Read from PORT an ASCII-armored Radix-64 stream, decode it, and return the
+result as a bytevector as well as the type, a string such as \"PGP MESSAGE\".
+Return #f if PORT does not contain a valid Radix-64 stream, and the
+end-of-file object if the Radix-64 sequence was truncated."
+  ;; This is the same as 'get-delimited-base64', except that it implements the
+  ;; CRC24 check.
+  (define (skip-headers port)
+    ;; Skip the Radix-64 "armor headers".
+    (match (read-line port)
+      ((? eof-object? eof) eof)
+      ((= string-trim-both "") "")
+      (_  (skip-headers port))))
+
+  (let ((line (string-trim-right (read-line port))))
+    (if (and (string-prefix? %begin-block-prefix line)
+             (string-suffix? %begin-block-suffix line))
+        (let* ((kind (string-drop-right
+                      (string-drop line (string-length %begin-block-prefix))
+                      (string-length %begin-block-suffix)))
+               (end  (string-append %end-block-prefix kind
+                                    %end-block-suffix)))
+          (skip-headers port)
+          (let loop ((lines '()))
+            (let ((line (read-line port)))
+              (match line
+                ((? eof-object? eof)
+                 (values eof kind))
+                ((= string-trim-both "")
+                 (loop lines))
+                ((= string-trim-both str)
+                 (if (string=? str end)
+                     (match lines
+                       ((crc lines ...)
+                        ;; The last line should be the CRC, starting with an
+                        ;; "=" sign.
+                        (let ((crc  (and (string-prefix? "=" crc)
+                                         (base64-decode (string-drop crc 1))))
+                              (data (base64-decode
+                                     (string-concatenate-reverse lines))))
+                          (if (and crc (= (bytevector->uint crc) (crc24 data)))
+                              (values data kind)
+                              (values #f kind))))
+                       (_
+                        (values #f kind)))
+                     (loop (cons str lines))))))))
+        (values #f #f))))