guix/openpgp.scm

   1 ;; -*- mode: scheme; coding: utf-8 -*-
   2 ;; Copyright © 2010, 2012 Göran Weinholt <goran@weinholt.se>
   3 ;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
   4
   5 ;; Permission is hereby granted, free of charge, to any person obtaining a
   6 ;; copy of this software and associated documentation files (the "Software"),
   7 ;; to deal in the Software without restriction, including without limitation
   8 ;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
   9 ;; and/or sell copies of the Software, and to permit persons to whom the
  10 ;; Software is furnished to do so, subject to the following conditions:
  11
  12 ;; The above copyright notice and this permission notice shall be included in
  13 ;; all copies or substantial portions of the Software.
  14
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  16 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  17 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  18 ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  19 ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  20 ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  21 ;; DEALINGS IN THE SOFTWARE.
  22
  23 ;;; This code was originally written by Göran Weinholt for Industria and
  24 ;;; released under the Expat license shown above.  It was then modified by
  25 ;;; Ludovic Courtès for use in GNU Guix: turned into a native Guile module,
  26 ;;; ported to Guile-Gcrypt, and extended and simplified in other ways.
  27
  28 (define-module (guix openpgp)
  29   #:export (get-openpgp-detached-signature/ascii
  30             (get-packet . get-openpgp-packet)
  31             verify-openpgp-signature
  32             port-ascii-armored?
  33
  34             openpgp-error?
  35             openpgp-unrecognized-packet-error?
  36             openpgp-unrecognized-packet-error-port
  37             openpgp-unrecognized-packet-error-type
  38             openpgp-invalid-signature-error?
  39             openpgp-invalid-signature-error-port
  40
  41             openpgp-signature?
  42             openpgp-signature-issuer-key-id
  43             openpgp-signature-issuer-fingerprint
  44             openpgp-signature-public-key-algorithm
  45             openpgp-signature-hash-algorithm
  46             openpgp-signature-creation-time
  47             openpgp-signature-expiration-time
  48
  49             openpgp-user-id?
  50             openpgp-user-id-value
  51             openpgp-user-attribute?
  52
  53             openpgp-public-key?
  54             openpgp-public-key-subkey?
  55             openpgp-public-key-value
  56             openpgp-public-key-fingerprint openpgp-format-fingerprint
  57             openpgp-public-key-id
  58
  59             openpgp-keyring?
  60             %empty-keyring
  61             lookup-key-by-id
  62             lookup-key-by-fingerprint
  63             get-openpgp-keyring
  64
  65             read-radix-64
  66             string->openpgp-packet)
  67   #:use-module (rnrs bytevectors)
  68   #:use-module (rnrs io ports)
  69   #:use-module (srfi srfi-1)
  70   #:use-module (srfi srfi-9)
  71   #:use-module (srfi srfi-11)
  72   #:use-module (srfi srfi-19)
  73   #:use-module (srfi srfi-26)
  74   #:use-module (srfi srfi-34)
  75   #:use-module (srfi srfi-35)
  76   #:use-module (srfi srfi-60)
  77   #:use-module (ice-9 match)
  78   #:use-module ((ice-9 rdelim) #:select (read-line))
  79   #:use-module (ice-9 vlist)
  80   #:use-module (gcrypt hash)
  81   #:use-module (gcrypt pk-crypto)
  82   #:use-module (gcrypt base64)
  83   #:use-module (gcrypt base16)
  84   #:use-module ((guix build utils) #:select (dump-port)))
  85
  86 ;;; Commentary:
  87 ;;;
  88 ;;; This module contains code to read OpenPGP messages as described in
  89 ;;; <https://tools.ietf.org/html/rfc4880>, with extensions from
  90 ;;; <https://tools.ietf.org/html/draft-ietf-openpgp-rfc4880bis-06> (notably
  91 ;;; EdDSA support and extra signature sub-packets).
  92 ;;;
  93 ;;; Currently this module does enough to verify detached signatures of binary
  94 ;;; data.  It does _not_ perform sanity checks on self-signatures, subkey
  95 ;;; binding signatures, etc., among others.  Use only in a context where this
  96 ;;; limitations are acceptable!
  97 ;;;
  98 ;;; Code:
  99
 100 (define-syntax print
 101   (syntax-rules ()
 102     ;; ((_ args ...) (pk 'openpgp args))
 103     ((_ args ...) (values))))
 104
 105 (define-syntax-rule (define-alias new old)
 106   (define-syntax new (identifier-syntax old)))
 107
 108 (define-alias fx+ +)
 109 (define-alias fx- -)
 110 (define-alias fx* *)
 111 (define-alias fx/ /)
 112 (define-alias fxdiv quotient)
 113 (define-alias fxand logand)
 114 (define-inlinable (fxbit-set? n index) (bit-set? index n))
 115 (define-alias fxbit-field bit-field)
 116 (define-alias bitwise-bit-field bit-field)
 117 (define-alias fxarithmetic-shift-left ash)
 118 (define-inlinable (fxarithmetic-shift-right i n) (ash i (- n)))
 119 (define-inlinable (port-eof? port) (eof-object? (lookahead-u8 port)))
 120
 121 (define (string-hex-pad str)
 122   (if (odd? (string-length str))
 123       (string-append "0" str)
 124       str))
 125
 126 (define (unixtime n)
 127   (time-monotonic->date (make-time 'time-monotonic 0 n)))
 128
 129 ;; Root of the error hierarchy.
 130 (define-condition-type &openpgp-error &error
 131   openpgp-error?)
 132
 133 ;; Error raised when reading an unsupported or unrecognized packet tag.
 134 (define-condition-type &openpgp-unrecognized-packet-error &openpgp-error
 135   openpgp-unrecognized-packet-error?
 136   (type openpgp-unrecognized-packet-error-type)
 137   (port openpgp-unrecognized-packet-error-port))
 138
 139 ;; Error raised when reading an invalid signature packet.
 140 (define-condition-type &openpgp-invalid-signature-error &openpgp-error
 141   openpgp-invalid-signature-error?
 142   (port openpgp-invalid-signature-error-port))
 143
 144 \f
 145 ;;;
 146 ;;; Bitwise I/O.
 147 ;;;
 148 ;;; TODO: Use Bytestructures instead.
 149 ;;;
 150
 151 (define-syntax-rule (integer-read size)
 152   (lambda (port)
 153     "Read from PORT a big-endian integer of SIZE bytes.  Return the EOF object
 154 on end-of-file."
 155     (let ((buf (make-bytevector size)))
 156       (match (get-bytevector-n! port buf 0 size)
 157         (size (bytevector-uint-ref buf 0 (endianness big) size))
 158         (_    (eof-object))))))
 159
 160 (define get-u16 (integer-read 2))
 161 (define get-u32 (integer-read 4))
 162 (define get-u64 (integer-read 8))
 163
 164 (define-syntax get-integers
 165   (syntax-rules ()
 166     "Read from PORT integers of the given TYPE, in big endian encoding.  Each
 167 TYPE must be one of u8, u16, u32, u64, or _, as in this example:
 168
 169   (get-integers port u8 _ _ _ u32 u16)
 170
 171 In the case of _ (wildcard), one byte is read and discarded.  Return as many
 172 values as there are TYPEs."
 173     ((_ port type ...)
 174      (letrec-syntax ((get-integer (syntax-rules (u8 u16 u32 u64)
 175                                     ((x u8) (get-u8 port))
 176                                     ((x u16) (get-u16 port))
 177                                     ((x u32) (get-u32 port))
 178                                     ((x u64) (get-u64 port))))
 179                      (values*     (syntax-rules (_)
 180                                     ((x (result (... ...)))
 181                                      (values result (... ...)))
 182                                     ((x (result (... ...)) _ rest (... ...))
 183                                      (let ((x (get-u8 port)))
 184                                        (values* (result (... ...))
 185                                                 rest (... ...))))
 186                                     ((x (result (... ...)) t rest (... ...))
 187                                      (let ((x (get-integer t)))
 188                                        (values* (result (... ...) x)
 189                                                 rest (... ...)))))))
 190        (values* () type ...)))))
 191
 192 (define (bytevector->uint bv)
 193   (bytevector-uint-ref bv 0 (endianness big)
 194                        (bytevector-length bv)))
 195
 196 (define-syntax-rule (integer-write size)
 197   (lambda (port integer)
 198     "Write INTEGER to PORT as a SIZE-byte integer and as big endian."
 199     (let ((bv (make-bytevector size)))
 200       (bytevector-uint-set! bv 0 integer (endianness big) size)
 201       (put-bytevector port bv))))
 202
 203 (define put-u16 (integer-write 2))
 204 (define put-u32 (integer-write 4))
 205 (define put-u64 (integer-write 8))
 206
 207 (define-syntax put-integers
 208   (syntax-rules ()
 209     "Write the given integers as big endian to PORT.  For example:
 210
 211   (put-integers port u8 42 u32 #x7777)
 212
 213 writes to PORT the value 42 as an 8-bit integer and the value #x7777 as a
 214 32-bit integer."
 215     ((_ port)
 216      #t)
 217     ((_ port type value rest ...)
 218      (let-syntax ((put (syntax-rules (u8 u16 u32 u64)
 219                          ((_ u8 port integer)
 220                           (put-u8 port integer))
 221                          ((_ u16 port integer)
 222                           (put-u16 port integer))
 223                          ((_ u32 port integer)
 224                           (put-u32 port integer))
 225                          ((_ u64 port integer)
 226                           (put-u64 port integer)))))
 227        (begin
 228          (put type port value)
 229          (put-integers port rest ...))))))
 230
 231 (define-syntax-rule (integers->bytevector type value rest ...)
 232   "Return the the TYPE/VALUE integers representation as a bytevector."
 233   (let-values (((port get) (open-bytevector-output-port)))
 234     (put-integers port type value rest ...)
 235     (force-output port)
 236     (get)))
 237
 238 \f
 239 (define (bytevector->bitnames bv names)
 240   (define (bit-set? bv i)
 241     (let ((idx (fxarithmetic-shift-right i 3))
 242           (bit (fxand i #b111)))
 243       (and (< idx (bytevector-length bv))
 244            (fxbit-set? (bytevector-u8-ref bv idx) bit))))
 245   (do ((names names (cdr names))
 246        (i 0 (fx+ i 1))
 247        (bits '()
 248              (if (bit-set? bv i)
 249                  (cons (car names) bits)
 250                  bits)))
 251       ((null? names) (reverse bits))))
 252
 253 (define (openpgp-format-fingerprint bv)
 254   "Return a string representing BV, a bytevector, in the conventional OpenPGP
 255 hexadecimal format for fingerprints."
 256   (define (h i)
 257     (string-pad (string-upcase
 258                  (number->string
 259                   (bytevector-u16-ref bv (* i 2) (endianness big))
 260                   16))
 261                 4 #\0))
 262   (string-append (h 0) " " (h 1) " " (h 2) " " (h 3) " " (h 4)
 263                  "  "
 264                  (h 5) " " (h 6) " " (h 7) " " (h 8) " " (h 9)))
 265
 266 ;;; Constants
 267
 268
 269 (define PACKET-SESSION-KEY 1)
 270 (define PACKET-SIGNATURE 2)
 271 (define PACKET-SYMMETRIC-SESSION-KEY 3)
 272 (define PACKET-ONE-PASS-SIGNATURE 4)
 273 (define PACKET-SECRET-KEY 5)
 274 (define PACKET-PUBLIC-KEY 6)
 275 (define PACKET-SECRET-SUBKEY 7)
 276 (define PACKET-COMPRESSED-DATA 8)
 277 (define PACKET-SYMMETRIC-ENCRYPTED-DATA 9)
 278 (define PACKET-MARKER 10)
 279 (define PACKET-LITERAL-DATA 11)
 280 (define PACKET-TRUST 12)
 281 (define PACKET-USER-ID 13)
 282 (define PACKET-PUBLIC-SUBKEY 14)
 283 (define PACKET-USER-ATTRIBUTE 17)
 284 (define PACKET-SYMMETRIC-ENCRYPTED/PROTECTED-DATA 18)
 285 (define PACKET-MDC 19)
 286
 287 (define PUBLIC-KEY-RSA 1)
 288 (define PUBLIC-KEY-RSA-ENCRYPT-ONLY 2)
 289 (define PUBLIC-KEY-RSA-SIGN-ONLY 3)
 290 (define PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY 16)
 291 (define PUBLIC-KEY-DSA 17)
 292 (define PUBLIC-KEY-ECDH 18)                       ;RFC-6637
 293 (define PUBLIC-KEY-ECDSA 19)                      ;RFC-6639
 294 (define PUBLIC-KEY-ELGAMAL 20)                    ;encrypt + sign (legacy)
 295 (define PUBLIC-KEY-EDDSA 22)                      ;"not yet assigned" says GPG
 296
 297 (define (public-key-algorithm id)
 298   (cond ((= id PUBLIC-KEY-RSA) 'rsa)
 299         ((= id PUBLIC-KEY-DSA) 'dsa)
 300         ((= id PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) 'elgamal)
 301         ((= id PUBLIC-KEY-EDDSA) 'eddsa)
 302         (else id)))
 303
 304 (define SYMMETRIC-KEY-PLAINTEXT 0)
 305 (define SYMMETRIC-KEY-IDEA 1)
 306 (define SYMMETRIC-KEY-TRIPLE-DES 2)
 307 (define SYMMETRIC-KEY-CAST5-128 3)
 308 (define SYMMETRIC-KEY-BLOWFISH-128 4)
 309 (define SYMMETRIC-KEY-AES-128 7)
 310 (define SYMMETRIC-KEY-AES-192 8)
 311 (define SYMMETRIC-KEY-AES-256 9)
 312 (define SYMMETRIC-KEY-TWOFISH-256 10)
 313 (define SYMMETRIC-KEY-CAMELLIA-128 11)            ;RFC-5581
 314 (define SYMMETRIC-KEY-CAMELLIA-192 12)
 315 (define SYMMETRIC-KEY-CAMELLIA-256 13)
 316
 317 (define (symmetric-key-algorithm id)
 318   (cond ((= id SYMMETRIC-KEY-PLAINTEXT) 'plaintext)
 319         ((= id SYMMETRIC-KEY-IDEA) 'idea)
 320         ((= id SYMMETRIC-KEY-TRIPLE-DES) 'tdea)
 321         ((= id SYMMETRIC-KEY-CAST5-128) 'cast5-128)
 322         ((= id SYMMETRIC-KEY-BLOWFISH-128) 'blowfish-128)
 323         ((= id SYMMETRIC-KEY-AES-128) 'aes-128)
 324         ((= id SYMMETRIC-KEY-AES-192) 'aes-192)
 325         ((= id SYMMETRIC-KEY-AES-256) 'aes-256)
 326         ((= id SYMMETRIC-KEY-TWOFISH-256) 'twofish-256)
 327         (else id)))
 328
 329 (define HASH-MD5 1)
 330 (define HASH-SHA-1 2)
 331 (define HASH-RIPE-MD160 3)
 332 (define HASH-SHA-256 8)
 333 (define HASH-SHA-384 9)
 334 (define HASH-SHA-512 10)
 335 (define HASH-SHA-224 11)
 336
 337 (define (openpgp-hash-algorithm id signature-port)
 338   (cond ((= id HASH-MD5) 'md5)
 339         ((= id HASH-SHA-1) 'sha1)
 340         ((= id HASH-RIPE-MD160) 'rmd160)
 341         ((= id HASH-SHA-256) 'sha256)
 342         ((= id HASH-SHA-384) 'sha384)
 343         ((= id HASH-SHA-512) 'sha512)
 344         ((= id HASH-SHA-224) 'sha224)
 345         (else
 346          (raise (condition
 347                  (&openpgp-invalid-signature-error (port signature-port)))))))
 348
 349 (define COMPRESSION-UNCOMPRESSED 0)
 350 (define COMPRESSION-ZIP 1)                      ;deflate
 351
 352 (define COMPRESSION-ZLIB 2)
 353 (define COMPRESSION-BZIP2 3)
 354
 355 (define (compression-algorithm id)
 356   (cond ((= id COMPRESSION-UNCOMPRESSED) 'uncompressed)
 357         ((= id COMPRESSION-ZIP) 'deflate)
 358         ((= id COMPRESSION-ZLIB) 'zlib)
 359         ((= id COMPRESSION-BZIP2) 'bzip2)
 360         (else id)))
 361
 362 (define SUBPACKET-SIGNATURE-CTIME 2)
 363 (define SUBPACKET-SIGNATURE-ETIME 3)
 364   ;;  4 = Exportable Certification
 365
 366 (define SUBPACKET-TRUST-SIGNATURE 5)
 367   ;;  6 = Regular Expression
 368
 369 (define SUBPACKET-REVOCABLE 7)
 370 (define SUBPACKET-KEY-ETIME 9)
 371 (define SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS 11)
 372   ;; 12 = Revocation Key
 373
 374 (define SUBPACKET-ISSUER 16)
 375 (define SUBPACKET-NOTATION-DATA 20)
 376 (define SUBPACKET-PREFERRED-HASH-ALGORITHMS 21)
 377 (define SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS 22)
 378 (define SUBPACKET-KEY-SERVER-PREFERENCES 23)
 379 (define SUBPACKET-PREFERRED-KEY-SERVER 24)
 380 (define SUBPACKET-PRIMARY-USER-ID 25)
 381 (define SUBPACKET-POLICY-URI 26)
 382 (define SUBPACKET-KEY-FLAGS 27)
 383 (define SUBPACKET-SIGNER-USER-ID 28)
 384 (define SUBPACKET-REASON-FOR-REVOCATION 29)
 385 (define SUBPACKET-FEATURES 30)
 386   ;; 31 = Signature Target
 387 (define SUBPACKET-EMBEDDED-SIGNATURE 32)
 388 (define SUBPACKET-ISSUER-FINGERPRINT 33)          ;defined in RFC4880bis
 389
 390 (define SIGNATURE-BINARY #x00)
 391 (define SIGNATURE-TEXT #x01)
 392 (define SIGNATURE-STANDALONE #x02)
 393 (define SIGNATURE-GENERIC-CERT #x10)
 394 (define SIGNATURE-PERSONA-CERT #x11)
 395 (define SIGNATURE-CASUAL-CERT #x12)
 396 (define SIGNATURE-POSITIVE-CERT #x13)
 397 (define SIGNATURE-SUBKEY-BINDING #x18)
 398 (define SIGNATURE-PRIMARY-KEY-BINDING #x19)
 399 (define SIGNATURE-DIRECT #x1f)
 400 (define SIGNATURE-KEY-REVOCATION #x20)
 401 (define SIGNATURE-SUBKEY-REVOCATION #x28)
 402 (define SIGNATURE-CERT-REVOCATION #x30)
 403 (define SIGNATURE-TIMESTAMP #x40)
 404 (define SIGNATURE-THIRD-PARTY #x50)
 405
 406 ;;; Parsing
 407
 408   ;; Look at the tag byte and see if it looks reasonable, if it does
 409   ;; then the file is likely not armored. Does not move the port
 410   ;; position.
 411
 412 (define (port-ascii-armored? p)
 413   (let ((tag (lookahead-u8 p)))
 414     (cond ((eof-object? tag) #f)
 415           ((not (fxbit-set? tag 7)) #t)
 416           (else
 417            (let ((type (if (fxbit-set? tag 6)
 418                            (fxbit-field tag 0 6)
 419                            (fxbit-field tag 2 6))))
 420              (not (<= PACKET-SESSION-KEY type PACKET-MDC)))))))
 421
 422 (define (get-mpi/bytevector p)
 423   (let* ((bitlen  (get-u16 p))
 424          (bytelen (fxdiv (fx+ bitlen 7) 8)))
 425     (get-bytevector-n p bytelen)))
 426
 427 (define (get-mpi p)
 428   (bytevector->uint (get-mpi/bytevector p)))
 429
 430 (define (get-v4-length p)
 431   ;; TODO: indeterminate length (only for data packets)
 432   (let ((o1 (get-u8 p)))
 433     (cond ((< o1 192) o1)
 434           ((< o1 255)
 435            (+ (fxarithmetic-shift-left (fx- o1 192) 8)
 436               (get-u8 p)
 437               192))
 438           ((= o1 255)
 439            (get-u32 p)))))
 440
 441 (define (get-packet p)
 442   (if (port-eof? p)
 443       (eof-object)
 444       (get-packet* p get-data)))
 445
 446 (define (get-packet* p get-data)
 447   (let ((tag (get-u8 p)))
 448     ;; (unless (fxbit-set? tag 7) (error 'get-packet "Invalid tag" tag))
 449     (cond ((fxbit-set? tag 6)                     ;New packet format
 450            (let ((tag (fxbit-field tag 0 6))
 451                  (len (get-v4-length p)))
 452              (get-data p tag len)))
 453           (else                                   ;Old packet format
 454            (let ((tag (fxbit-field tag 2 6))
 455                  (len (case (fxbit-field tag 0 2)
 456                         ((0) (get-u8 p))
 457                         ((1) (get-u16 p))
 458                         ((2) (get-u32 p))
 459                         ((3) #f))))
 460              (get-data p tag len))))))
 461
 462 (define (get-data p tag len)
 463   (let ((pp (if len
 464                 (open-bytevector-input-port (get-bytevector-n p len))
 465                 p)))                              ;indeterminate length
 466     (cond
 467      ((= tag PACKET-SIGNATURE)
 468       (get-signature pp))
 469      ((= tag PACKET-PUBLIC-KEY)
 470       (get-public-key pp #f))
 471      ((= tag PACKET-TRUST)
 472       'openpgp-trust)                             ;XXX: non-standard format?
 473      ((= tag PACKET-USER-ID)
 474       (get-user-id pp len))
 475      ((= tag PACKET-PUBLIC-SUBKEY)
 476       (get-public-key pp #t))
 477      ((= tag PACKET-USER-ATTRIBUTE)
 478       (get-user-attribute pp len))
 479      ((= tag PACKET-ONE-PASS-SIGNATURE)
 480       'one-pass-signature)                        ;TODO: implement
 481      (else
 482       (raise (condition (&openpgp-unrecognized-packet-error (type tag)
 483                                                             (port p))))))))
 484
 485 (define-record-type <openpgp-public-key>
 486   (make-openpgp-public-key version subkey? time value fingerprint)
 487   openpgp-public-key?
 488   (version      openpgp-public-key-version)
 489   (subkey?      openpgp-public-key-subkey?)
 490   (time         openpgp-public-key-time)
 491   (value        openpgp-public-key-value)
 492   (fingerprint  openpgp-public-key-fingerprint))
 493
 494 ;;; Signatures
 495
 496 (define-record-type <openpgp-signature>
 497   (make-openpgp-signature version type pk-algorithm hash-algorithm hashl16
 498                           append-data hashed-subpackets unhashed-subpackets
 499                           value issuer issuer-fingerprint)
 500   openpgp-signature?
 501   (version               openpgp-signature-version)
 502   (type                  openpgp-signature-type)
 503   (pk-algorithm          openpgp-signature-public-key-algorithm)
 504   (hash-algorithm        openpgp-signature-hash-algorithm)
 505   (hashl16               openpgp-signature-hashl16) ;left 16 bits of signed hash
 506   (append-data           openpgp-signature-append-data) ;append to data when hashing
 507   (hashed-subpackets     openpgp-signature-hashed-subpackets)
 508   (unhashed-subpackets   openpgp-signature-unhashed-subpackets)
 509   (value                 openpgp-signature-value)
 510   (issuer                openpgp-signature-issuer-key-id)       ;integer | #f
 511   (issuer-fingerprint    openpgp-signature-issuer-fingerprint)) ;bytevector | #f
 512
 513 (define (openpgp-signature-creation-time sig)
 514   (cond ((assq 'signature-ctime (openpgp-signature-hashed-subpackets sig))
 515          => (lambda (x) (unixtime (cdr x))))
 516         ;; XXX: should be an error?
 517         (else #f)))
 518
 519 (define (openpgp-signature-expiration-time sig)
 520   (cond ((assq 'signature-etime (openpgp-signature-hashed-subpackets sig))
 521          => (lambda (x)
 522               (unixtime (+ (cdr x)
 523                            (openpgp-signature-creation-time sig)))))
 524         (else #f)))
 525
 526
 527 (define (get-openpgp-detached-signature/ascii port)
 528   "Read from PORT an ASCII-armored detached signature.  Return an
 529 <openpgp-signature> record or the end-of-file object.  Raise an error if the
 530 data read from PORT does is invalid or does not correspond to a detached
 531 signature."
 532   (let-values (((data type) (read-radix-64 port)))
 533     (cond ((eof-object? data) data)
 534           ((string=? type "PGP SIGNATURE")
 535            (get-packet (open-bytevector-input-port data)))
 536           (else
 537            (print "expected PGP SIGNATURE" type)
 538            (raise (condition
 539                    (&openpgp-invalid-signature-error (port port))))))))
 540
 541 (define (verify-openpgp-signature sig keyring dataport)
 542   "Verify that the data read from DATAPORT matches SIG, an
 543 <openpgp-signature>.  Fetch the public key of the issuer of SIG from KEYRING,
 544 a keyring as returned by 'get-openpgp-keyring'.  Return two values: a status
 545 symbol, such as 'bad-signature or 'missing-key, and additional info, such as
 546 the issuer's OpenPGP public key extracted from KEYRING."
 547   (define (check key sig)
 548     (let*-values (((hash-algorithm) (lookup-hash-algorithm
 549                                      (openpgp-signature-hash-algorithm sig)))
 550                   ((port get-hash) (open-hash-port hash-algorithm)))
 551       (dump-port dataport port)
 552
 553       ;; As per RFC4880 Section 5.2.4 ("Computing Signatures"), hash some of
 554       ;; the fields from the signature packet.
 555       (for-each (cut put-bytevector port <>)
 556                 (openpgp-signature-append-data sig))
 557       (close-port port)
 558
 559       (let* ((signature  (openpgp-signature-value sig))
 560              (public-key (openpgp-public-key-value key))
 561              (hash       (get-hash))
 562              (key-type   (key-type public-key))
 563              (data
 564               ;; See "(gcrypt) Cryptographic Functions".
 565               (sexp->canonical-sexp
 566                (if (eq? key-type 'ecc)
 567                    `(data
 568                      (flags eddsa)
 569                      (hash-algo sha512)
 570                      (value ,hash))
 571                    `(data
 572                      (flags ,(match key-type
 573                                ('rsa 'pkcs1)
 574                                ('dsa 'rfc6979)))
 575                      (hash ,(hash-algorithm-name hash-algorithm)
 576                            ,hash))))))
 577         (values (if (verify signature data public-key)
 578                     'good-signature
 579                     'bad-signature)
 580                 key))))
 581
 582   ;; TODO: Support SIGNATURE-TEXT.
 583   (if (= (openpgp-signature-type sig) SIGNATURE-BINARY)
 584       (let* ((id          (openpgp-signature-issuer-key-id sig))
 585              (fingerprint (openpgp-signature-issuer-fingerprint sig))
 586              (key         (if fingerprint
 587                               (lookup-key-by-fingerprint keyring fingerprint)
 588                               (lookup-key-by-id keyring id))))
 589         (if key
 590             (check key sig)
 591             (values 'missing-key (or fingerprint id))))
 592       (values 'unsupported-signature sig)))
 593
 594 (define (key-id-matches-fingerprint? key-id fingerprint)
 595   "Return true if KEY-ID, a number, corresponds to the low 8 bytes of
 596 FINGERPRINT, a bytevector."
 597   (let* ((len (bytevector-length fingerprint))
 598          (low (make-bytevector 8)))
 599     (bytevector-copy! fingerprint (- len 8) low 0 8)
 600     (= (bytevector->uint low) key-id)))
 601
 602 (define (get-signature p)
 603   (define (->hex n)
 604     (string-hex-pad (number->string n 16)))
 605
 606   (define (get-sig p pkalg)
 607     (cond ((= pkalg PUBLIC-KEY-RSA)
 608            (print "RSA signature")
 609            (string->canonical-sexp
 610             (format #f "(sig-val (rsa (s #~a#)))"
 611                     (->hex (get-mpi p)))))
 612           ((= pkalg PUBLIC-KEY-DSA)
 613            (print "DSA signature")
 614            (let ((r (get-mpi p)) (s (get-mpi p)))
 615              (string->canonical-sexp
 616               (format #f "(sig-val (dsa (r #~a#) (s #~a#)))"
 617                       (->hex r) (->hex s)))))
 618           ((= pkalg PUBLIC-KEY-EDDSA)
 619            (print "EdDSA signature")
 620            (let ((r (get-mpi/bytevector p))
 621                  (s (get-mpi/bytevector p)))
 622              ;; XXX: 'verify' fails down the road with GPG_ERR_INV_LENGTH if
 623              ;; we provide a 31-byte R or S below, hence the second argument
 624              ;; to '->hex' ensuring the MPIs are represented as two-byte
 625              ;; multiples, with leading zeros.
 626              (define (bytevector->hex bv)
 627                (let ((str (bytevector->base16-string bv)))
 628                  (if (odd? (bytevector-length bv))
 629                      (string-append "00" str)
 630                      str)))
 631
 632              (string->canonical-sexp
 633               (format #f "(sig-val (eddsa (r #~a#) (s #~a#)))"
 634                       (bytevector->hex r) (bytevector->hex s)))))
 635           (else
 636            (list 'unsupported-algorithm
 637                  (public-key-algorithm pkalg)
 638                  (get-bytevector-all p)))))
 639   (let ((version (get-u8 p)))
 640     (case version
 641       ((3)
 642        (let-values (((hmlen type ctime keyid pkalg halg hashl16)
 643                      (get-integers p u8 u8 u32 u64 u8 u8 u16)))
 644          (unless (= hmlen 5)
 645            (raise (condition
 646                    (&openpgp-invalid-signature-error (port p)))))
 647
 648          (print "Signature type: " type " creation time: " (unixtime ctime))
 649          (print "Hash algorithm: " (openpgp-hash-algorithm halg p))
 650          (let ((value (get-sig p pkalg)))
 651            (unless (port-eof? p)
 652              (print "Trailing data in signature: " (get-bytevector-all p)))
 653            (make-openpgp-signature version type
 654                                    (public-key-algorithm pkalg)
 655                                    (openpgp-hash-algorithm halg p) hashl16
 656                                    (list (integers->bytevector u8 type
 657                                                                u32 ctime))
 658                                    ;; Emulate hashed subpackets
 659                                    (list (cons 'signature-ctime ctime))
 660                                    ;; Unhashed subpackets
 661                                    (list (cons 'issuer keyid))
 662                                    value
 663                                    keyid #f))))
 664       ((4)
 665        (let*-values (((type pkalg halg) (get-integers p u8 u8 u8))
 666                      ((hashed-subpackets)
 667                       (get-bytevector-n p (get-u16 p)))
 668                      ((unhashed-subpackets)
 669                       (get-bytevector-n p (get-u16 p)))
 670                      ((hashl16) (get-u16 p)))
 671          (print "Signature type: " type)
 672          (print "Hash algorithm: " (openpgp-hash-algorithm halg p))
 673          (let ((value (get-sig p pkalg)))
 674            (unless (port-eof? p)
 675              (print "Trailing data in signature: " (get-bytevector-all p)))
 676            (let* ((subpacket-len (bytevector-length hashed-subpackets))
 677                   (append-data
 678                    (list
 679                     (integers->bytevector u8 version
 680                                           u8 type
 681                                           u8 pkalg
 682                                           u8 halg
 683                                           u16 subpacket-len)
 684                     hashed-subpackets
 685                     ;; http://www.rfc-editor.org/errata_search.php?rfc=4880
 686                     ;; Errata ID: 2214.
 687                     (integers->bytevector u8 #x04
 688                                           u8 #xff
 689                                           u32 (+ 6 subpacket-len))))
 690                   (unhashed-subpackets
 691                    (parse-subpackets unhashed-subpackets p))
 692                   (hashed-subpackets (parse-subpackets hashed-subpackets p))
 693                   (subpackets        (append hashed-subpackets
 694                                              unhashed-subpackets))
 695                   (issuer-key-id     (assoc-ref subpackets 'issuer))
 696                   (issuer            (assoc-ref subpackets
 697                                                 'issuer-fingerprint)))
 698              (unless (or (not issuer) (not issuer-key-id)
 699                          (key-id-matches-fingerprint? issuer-key-id issuer))
 700                (print "issuer key id does not match fingerprint"
 701                       issuer-key-id issuer)
 702                (raise (condition
 703                        (&openpgp-invalid-signature-error (port p)))))
 704
 705              (make-openpgp-signature version type
 706                                      (public-key-algorithm pkalg)
 707                                      (openpgp-hash-algorithm halg p)
 708                                      hashl16
 709                                      append-data
 710                                      hashed-subpackets
 711                                      unhashed-subpackets
 712                                      value
 713                                      issuer-key-id issuer)))))
 714       (else
 715        (print "Unsupported signature version: " version)
 716        'unsupported-signature-version))))
 717
 718 (define (parse-subpackets bv signature-port)
 719   (define (parse tag data)
 720     (let ((type (fxbit-field tag 0 7))
 721           (critical? (fxbit-set? tag 7)))
 722       (cond
 723        ((= type SUBPACKET-SIGNATURE-CTIME)
 724         (cons 'signature-ctime
 725               (bytevector-u32-ref data 0 (endianness big))))
 726        ((= type SUBPACKET-SIGNATURE-ETIME)
 727         (cons 'signature-etime
 728               (bytevector-u32-ref data 0 (endianness big))))
 729        ((= type SUBPACKET-TRUST-SIGNATURE)
 730         (cons 'trust-signature
 731               (bytevector-u8-ref data 0)))
 732        ((= type SUBPACKET-REVOCABLE)
 733         (cons 'revocable
 734               (= (bytevector-u8-ref data 0) 1)))
 735        ((= type SUBPACKET-KEY-ETIME)
 736         (cons 'key-etime
 737               (bytevector-u32-ref data 0 (endianness big))))
 738        ((= type SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS)
 739         (cons 'preferred-symmetric-algorithms
 740               (map symmetric-key-algorithm (bytevector->u8-list data))))
 741        ((= type SUBPACKET-ISSUER)
 742         (cons 'issuer
 743               (bytevector-u64-ref data 0 (endianness big))))
 744        ((= type SUBPACKET-ISSUER-FINGERPRINT)     ;v4+ only, RFC4880bis
 745         (cons 'issuer-fingerprint
 746               (let* ((version     (bytevector-u8-ref data 0))
 747                      (len         (match version (4 20) (5 32)) )
 748                      (fingerprint (make-bytevector len)))
 749                 (bytevector-copy! data 1 fingerprint 0 len)
 750                 fingerprint)))
 751        ((= type SUBPACKET-NOTATION-DATA)
 752         (let ((p (open-bytevector-input-port data)))
 753           (let-values (((f1 nlen vlen)
 754                         (get-integers p u8 _ _ _ u16 u16)))
 755             (let* ((name (get-bytevector-n p nlen))
 756                    (value (get-bytevector-n p vlen)))
 757               (cons 'notation-data
 758                     (list (utf8->string name)
 759                           (if (fxbit-set? f1 7)
 760                               (utf8->string value)
 761                               value)))))))
 762        ((= type SUBPACKET-PREFERRED-HASH-ALGORITHMS)
 763         (cons 'preferred-hash-algorithms
 764               (map (cut openpgp-hash-algorithm <> signature-port)
 765                    (bytevector->u8-list data))))
 766        ((= type SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS)
 767         (cons 'preferred-compression-algorithms
 768               (map compression-algorithm (bytevector->u8-list data))))
 769        ((= type SUBPACKET-KEY-SERVER-PREFERENCES)
 770         (cons 'key-server-preferences
 771               (if (and (>= (bytevector-length data) 1)
 772                        (fxbit-set? (bytevector-u8-ref data 0) 7))
 773                   (list 'no-modify)
 774                   (list))))
 775        ((= type SUBPACKET-PREFERRED-KEY-SERVER)
 776         (cons 'preferred-key-server (utf8->string data)))
 777        ((= type SUBPACKET-PRIMARY-USER-ID)
 778         (cons 'primary-user-id (not (zero? (bytevector-u8-ref data 0)))))
 779        ((= type SUBPACKET-POLICY-URI)
 780         (cons 'policy-uri (utf8->string data)))
 781        ((= type SUBPACKET-KEY-FLAGS)
 782         (cons 'key-flags (bytevector->bitnames
 783                           data
 784                           '(certification sign-data
 785                                           communications-encryption
 786                                           storage-encryption
 787                                           split-key authentication
 788                                           group-key))))
 789        ((= type SUBPACKET-SIGNER-USER-ID)
 790         (cons 'signer-user-id (utf8->string data)))
 791        ((= type SUBPACKET-REASON-FOR-REVOCATION)
 792         (let* ((p (open-bytevector-input-port data))
 793                (revocation-code (get-u8 p)))
 794           (cons 'reason-for-revocation
 795                 (list revocation-code
 796                       (if (port-eof? p)
 797                           ""
 798                           (utf8->string (get-bytevector-all p)))))))
 799        ((= type SUBPACKET-FEATURES)
 800         (cons 'features (bytevector->bitnames
 801                          data '(modification-detection))))
 802        ((= type SUBPACKET-EMBEDDED-SIGNATURE)
 803         (cons 'embedded-signature
 804               (get-signature (open-bytevector-input-port data))))
 805        (else
 806         ;; Unknown subpacket type.  If it is critical, then the signature
 807         ;; should be considered invalid.
 808         (print "Unknown subpacket type: " type)
 809         (if critical?
 810             (raise (condition
 811                     (&openpgp-unrecognized-packet-error
 812                      (type type)
 813                      (port signature-port))))
 814             (list 'unsupported-subpacket type data))))))
 815
 816   (let ((p (open-bytevector-input-port bv)))
 817     (let lp ((subpackets '()))
 818       ;; In case of multiple subpackets of the same type, the last
 819       ;; one should be used. Therefore the list is not reversed
 820       ;; here.
 821       (if (port-eof? p)
 822           (reverse subpackets)
 823           (let* ((len (- (get-v4-length p) 1))
 824                  (tag (get-u8 p))
 825                  (sp (parse tag (get-bytevector-n p len))))
 826             (print "#;Subpacket " sp)
 827             (lp (cons sp subpackets)))))))
 828
 829 ;;; Public keys
 830
 831
 832 (define (openpgp-public-key-id k)
 833   (let ((bv (openpgp-public-key-fingerprint k)))
 834     (bytevector-u64-ref bv
 835                         (- (bytevector-length bv) 8)
 836                         (endianness big))))
 837
 838 (define (get-public-key p subkey?)
 839   (define (fingerprint p)
 840     (let ((len (port-position p)))
 841       (set-port-position! p 0)
 842       (let-values (((sha1-port get)
 843                     (open-hash-port (hash-algorithm sha1))))
 844         (put-u8 sha1-port #x99)
 845         (put-u16 sha1-port len)
 846         (dump-port p sha1-port)
 847         (close-port sha1-port)
 848         (get))))
 849   (define (get-key p alg)
 850     (define (->hex n)
 851       (string-hex-pad (number->string n 16)))
 852
 853     (cond ((= alg PUBLIC-KEY-RSA)
 854            (print "Public RSA key")
 855            (let* ((n (get-mpi p)) (e (get-mpi p)))
 856              (string->canonical-sexp
 857               (format #f "(public-key (rsa (n #~a#) (e #~a#)))"
 858                       (->hex n) (->hex e)))))
 859           ((= alg PUBLIC-KEY-DSA)
 860            (print "Public DSA key")
 861            (let* ((p* (get-mpi p)) (q (get-mpi p))
 862                   (g (get-mpi p)) (y (get-mpi p)))
 863              (string->canonical-sexp
 864               (format #f "(public-key (dsa (p #~a#)(q #~a#)(g #~a#)(y #~a#)))"
 865                       (->hex p*) (->hex q) (->hex g) (->hex y)))))
 866           #;
 867           ((= alg PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) ; ; ; ;
 868           (print "Public El-Gamal Key")         ; ; ; ;
 869           (let* ((p* (get-mpi p)) (g (get-mpi p)) (y (get-mpi p))) ; ; ; ;
 870           (make-public-elgamal-key p* g y)))
 871           ((= alg PUBLIC-KEY-EDDSA)
 872            ;; See
 873            ;; <https://tools.ietf.org/html/draft-koch-eddsa-for-openpgp-04>
 874            ;; and openpgp-oid.c in GnuPG.
 875            (print "Public EdDSA key")
 876            (let* ((len     (get-u8 p))
 877                   (oid     (bytevector->uint (get-bytevector-n p len)))
 878                   (q (get-mpi p)))
 879              (define curve
 880                (match oid
 881                  (#x2b06010401da470f01   'Ed25519)
 882                  (#x2b060104019755010501 'Curve25519)))
 883
 884              (string->canonical-sexp
 885               (format #f "(public-key (ecc (curve ~a)(flags ~a)(q #~a#)))"
 886                       curve
 887                       (if (eq? curve 'Curve25519) 'djb-tweak 'eddsa)
 888                       (->hex q)))))
 889           (else
 890            (list 'unsupported-algorithm           ;FIXME: throw
 891                  (public-key-algorithm alg)
 892                  (get-bytevector-all p)))))
 893   (let ((version (get-u8 p)))
 894     (case version
 895       ((4)
 896        (let-values (((ctime alg) (get-integers p u32 u8)))
 897          (print "Key creation time: " (unixtime ctime))
 898          (let ((key (get-key p alg)))
 899            (unless (port-eof? p)
 900              ;; Probably an error? Gonna cause trouble anyway.
 901              (print "Trailing data in public key: " (get-bytevector-all p)))
 902            (let ((digest (fingerprint p)))
 903              (make-openpgp-public-key version subkey? ctime key
 904                                       digest)))))
 905       (else
 906        (print "Unsupported public key version: " version)
 907        'unsupported-public-key-version))))
 908
 909 (define (openpgp-public-key-primary? key)
 910   (and (openpgp-public-key? key)
 911        (not (openpgp-public-key-subkey? key))))
 912
 913 ;;; User IDs and User attributes
 914
 915
 916 (define-record-type <openpgp-user-id>
 917   (make-openpgp-user-id value unparsed)
 918   openpgp-user-id?
 919   (value     openpgp-user-id-value)
 920   (unparsed  openpgp-user-id-unparsed))
 921
 922 (define (get-user-id p len)
 923   (let ((unparsed (get-bytevector-n p len)))
 924     (make-openpgp-user-id (utf8->string unparsed) unparsed)))
 925
 926 (define-record-type <openpgp-user-attribute>
 927   (make-openpgp-user-attribute unparsed)
 928   openpgp-user-attribute?
 929   (unparsed   openpgp-user-attribute-unparsed))
 930
 931 (define (get-user-attribute p len)
 932   (let ((bv (get-bytevector-n p len)))
 933     ;; TODO: bv contains subpackets. Type 1 is JFIF.
 934     (make-openpgp-user-attribute bv)))
 935
 936 \f
 937 ;;; Keyring management
 938
 939 (define-record-type <openpgp-keyring>
 940   (openpgp-keyring ids fingerprints)
 941   openpgp-keyring?
 942   (ids            openpgp-keyring-ids)        ;vhash mapping key id to packets
 943   (fingerprints   openpgp-keyring-fingerprints)) ;mapping fingerprint to packets
 944
 945 (define* (keyring-insert key keyring #:optional (packets '()))
 946   "Insert the KEY/PACKETS association into KEYRING and return the resulting
 947 keyring.  PACKETS typically contains KEY, an <openpgp-public-key>, alongside
 948 with additional <openpgp-public-key> records for sub-keys, <openpgp-user-id>
 949 records, and so on."
 950   (openpgp-keyring (vhash-consv (openpgp-public-key-id key)
 951                                 (cons key packets)
 952                                 (openpgp-keyring-ids keyring))
 953                    (vhash-cons (openpgp-public-key-fingerprint key)
 954                                (cons key packets)
 955                                (openpgp-keyring-fingerprints keyring))))
 956
 957 (define (lookup-key-by-id keyring id)
 958   "Return two values: the first key with ID in KEYRING, and a list of
 959 associated packets (user IDs, signatures, etc.).  Return #f and the empty list
 960 of ID was not found.  ID must be the 64-bit key ID of the key, an integer."
 961   (match (vhash-assv id (openpgp-keyring-ids keyring))
 962     ((_ key packets ...) (values key packets))
 963     (#f (values #f '()))))
 964
 965 (define (lookup-key-by-fingerprint keyring fingerprint)
 966   "Return two values: the key with FINGERPRINT in KEYRING, and a list of
 967 associated packets (user IDs, signatures, etc.).  Return #f and the empty list
 968 of FINGERPRINT was not found.  FINGERPRINT must be a bytevector."
 969   (match (vhash-assoc fingerprint (openpgp-keyring-fingerprints keyring))
 970     ((_ key packets ...) (values key packets))
 971     (#f (values #f '()))))
 972
 973 ;; Reads a keyring from the binary input port p. It must not be
 974 ;; ASCII armored.
 975
 976 (define %empty-keyring
 977   ;; The empty keyring.
 978   (openpgp-keyring vlist-null vlist-null))
 979
 980 (define* (get-openpgp-keyring port
 981                               #:optional (keyring %empty-keyring)
 982                               #:key (limit -1))
 983   "Read from PORT an OpenPGP keyring in binary format; return a keyring based
 984 on all the OpenPGP primary keys that were read.  The returned keyring
 985 complements KEYRING.  LIMIT is the maximum number of keys to read, or -1 if
 986 there is no limit."
 987   (let lp ((pkt (get-packet port))
 988            (limit limit)
 989            (keyring keyring))
 990     (print "#;key " pkt)
 991     (cond ((or (zero? limit) (eof-object? pkt))
 992            keyring)
 993           ((openpgp-public-key-primary? pkt)
 994            ;; Read signatures, user id's, subkeys
 995            (let lp* ((pkt  (get-packet port))
 996                      (pkts (list pkt))
 997                      (keys (list pkt)))
 998              (print "#;keydata " pkt)
 999              (cond ((or (eof-object? pkt)
1000                         (eq? pkt 'unsupported-public-key-version)
1001                         (openpgp-public-key-primary? pkt))
1002                     ;; KEYRING is indexed by key-id.  Key ids for both the
1003                     ;; primary key and subkeys all point to the list of
1004                     ;; packets.
1005                     (lp pkt
1006                         (- limit 1)
1007                         (fold (cute keyring-insert <> <> (reverse pkts))
1008                               keyring keys)))
1009                    ((openpgp-public-key? pkt)     ;subkey
1010                     (lp* (get-packet port) (cons pkt pkts)
1011                          (cons pkt keys)))
1012                    (else
1013                     (lp* (get-packet port) (cons pkt pkts) keys)))))
1014           (else
1015            ;; Skip until there's a primary key. Ignore errors...
1016            (lp (get-packet port) limit keyring)))))
1017
1018 \f
1019 ;;;
1020 ;;; Radix-64 (RFC4880).
1021 ;;;
1022
1023 (define (crc24 bv)
1024   "Compute a CRC24 as described in RFC4880, Section 6.1."
1025   ;; We used to have it implemented in Scheme but the C version here makes
1026   ;; 'load-keyring-from-reference' 18% faster when loading the 72
1027   ;; ASCII-armored files of today's Guix keyring.
1028   (bytevector->uint (bytevector-hash bv (hash-algorithm crc24-rfc2440))))
1029
1030 (define %begin-block-prefix "-----BEGIN ")
1031 (define %begin-block-suffix "-----")
1032
1033 (define %end-block-prefix "-----END ")
1034 (define %end-block-suffix "-----")
1035
1036 (define (read-radix-64 port)
1037   "Read from PORT an ASCII-armored Radix-64 stream, decode it, and return the
1038 result as a bytevector as well as the type, a string such as \"PGP MESSAGE\".
1039 Return #f if PORT does not contain a valid Radix-64 stream, and the
1040 end-of-file object if the Radix-64 sequence was truncated."
1041   ;; This is the same as 'get-delimited-base64', except that it implements the
1042   ;; CRC24 check.
1043   (define (skip-headers port)
1044     ;; Skip the Radix-64 "armor headers".
1045     (match (read-line port)
1046       ((? eof-object? eof) eof)
1047       ((= string-trim-both "") "")
1048       (_  (skip-headers port))))
1049
1050   (let ((line (string-trim-right (read-line port))))
1051     (if (and (string-prefix? %begin-block-prefix line)
1052              (string-suffix? %begin-block-suffix line))
1053         (let* ((kind (string-drop-right
1054                       (string-drop line (string-length %begin-block-prefix))
1055                       (string-length %begin-block-suffix)))
1056                (end  (string-append %end-block-prefix kind
1057                                     %end-block-suffix)))
1058           (skip-headers port)
1059           (let loop ((lines '()))
1060             (let ((line (read-line port)))
1061               (match line
1062                 ((? eof-object? eof)
1063                  (values eof kind))
1064                 ((= string-trim-both "")
1065                  (loop lines))
1066                 ((= string-trim-both str)
1067                  (if (string=? str end)
1068                      (match lines
1069                        ((crc lines ...)
1070                         ;; The last line should be the CRC, starting with an
1071                         ;; "=" sign.
1072                         (let ((crc  (and (string-prefix? "=" crc)
1073                                          (base64-decode (string-drop crc 1))))
1074                               (data (base64-decode
1075                                      (string-concatenate-reverse lines))))
1076                           (if (and crc (= (bytevector->uint crc) (crc24 data)))
1077                               (values data kind)
1078                               (values #f kind))))
1079                        (_
1080                         (values #f kind)))
1081                      (loop (cons str lines))))))))
1082         (values #f #f))))
1083
1084 (define (string->openpgp-packet str)
1085   "Read STR, an ASCII-armored OpenPGP packet, and return the corresponding
1086 OpenPGP record."
1087   (get-packet
1088    (open-bytevector-input-port (call-with-input-string str read-radix-64))))