24b2b5f99a
* guix/openpgp.scm (hash-algorithm-name): Remove. This procedure has been provided by Guile-Gcrypt since 0.3.0.
1089 lines
43 KiB
Scheme
1089 lines
43 KiB
Scheme
;; -*- 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-error?
|
||
openpgp-unrecognized-packet-error?
|
||
openpgp-unrecognized-packet-error-port
|
||
openpgp-unrecognized-packet-error-type
|
||
openpgp-invalid-signature-error?
|
||
openpgp-invalid-signature-error-port
|
||
|
||
openpgp-signature?
|
||
openpgp-signature-issuer-key-id
|
||
openpgp-signature-issuer-fingerprint
|
||
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
|
||
lookup-key-by-fingerprint
|
||
get-openpgp-keyring
|
||
|
||
read-radix-64
|
||
string->openpgp-packet)
|
||
#: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-inlinable (fxbit-set? n index) (bit-set? index n))
|
||
(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)))
|
||
|
||
;; Root of the error hierarchy.
|
||
(define-condition-type &openpgp-error &error
|
||
openpgp-error?)
|
||
|
||
;; Error raised when reading an unsupported or unrecognized packet tag.
|
||
(define-condition-type &openpgp-unrecognized-packet-error &openpgp-error
|
||
openpgp-unrecognized-packet-error?
|
||
(type openpgp-unrecognized-packet-error-type)
|
||
(port openpgp-unrecognized-packet-error-port))
|
||
|
||
;; Error raised when reading an invalid signature packet.
|
||
(define-condition-type &openpgp-invalid-signature-error &openpgp-error
|
||
openpgp-invalid-signature-error?
|
||
(port openpgp-invalid-signature-error-port))
|
||
|
||
|
||
;;;
|
||
;;; 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 signature-port)
|
||
(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
|
||
(raise (condition
|
||
(&openpgp-invalid-signature-error (port signature-port)))))))
|
||
|
||
(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)
|
||
(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 SUBPACKET-ISSUER-FINGERPRINT 33) ;defined in RFC4880bis
|
||
|
||
(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
|
||
(raise (condition (&openpgp-unrecognized-packet-error (type tag)
|
||
(port p))))))))
|
||
|
||
(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 issuer issuer-fingerprint)
|
||
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)
|
||
(issuer openpgp-signature-issuer-key-id) ;integer | #f
|
||
(issuer-fingerprint openpgp-signature-issuer-fingerprint)) ;bytevector | #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
|
||
(print "expected PGP SIGNATURE" type)
|
||
(raise (condition
|
||
(&openpgp-invalid-signature-error (port port))))))))
|
||
|
||
(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* ((id (openpgp-signature-issuer-key-id sig))
|
||
(fingerprint (openpgp-signature-issuer-fingerprint sig))
|
||
(key (if fingerprint
|
||
(lookup-key-by-fingerprint keyring fingerprint)
|
||
(lookup-key-by-id keyring id))))
|
||
(if key
|
||
(check key sig)
|
||
(values 'missing-key (or fingerprint id))))
|
||
(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)))
|
||
|
||
(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)
|
||
(raise (condition
|
||
(&openpgp-invalid-signature-error (port p)))))
|
||
|
||
(print "Signature type: " type " creation time: " (unixtime ctime))
|
||
(print "Hash algorithm: " (openpgp-hash-algorithm halg p))
|
||
(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 p) hashl16
|
||
(list (integers->bytevector u8 type
|
||
u32 ctime))
|
||
;; Emulate hashed subpackets
|
||
(list (cons 'signature-ctime ctime))
|
||
;; Unhashed subpackets
|
||
(list (cons 'issuer keyid))
|
||
value
|
||
keyid #f))))
|
||
((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 p))
|
||
(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))))
|
||
(unhashed-subpackets
|
||
(parse-subpackets unhashed-subpackets p))
|
||
(hashed-subpackets (parse-subpackets hashed-subpackets p))
|
||
(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))
|
||
(print "issuer key id does not match fingerprint"
|
||
issuer-key-id issuer)
|
||
(raise (condition
|
||
(&openpgp-invalid-signature-error (port p)))))
|
||
|
||
(make-openpgp-signature version type
|
||
(public-key-algorithm pkalg)
|
||
(openpgp-hash-algorithm halg p)
|
||
hashl16
|
||
append-data
|
||
hashed-subpackets
|
||
unhashed-subpackets
|
||
value
|
||
issuer-key-id issuer)))))
|
||
(else
|
||
(print "Unsupported signature version: " version)
|
||
'unsupported-signature-version))))
|
||
|
||
(define (parse-subpackets bv signature-port)
|
||
(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-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)
|
||
(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 (cut openpgp-hash-algorithm <> signature-port)
|
||
(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?
|
||
(raise (condition
|
||
(&openpgp-unrecognized-packet-error
|
||
(type type)
|
||
(port signature-port))))
|
||
(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 ids fingerprints)
|
||
openpgp-keyring?
|
||
(ids openpgp-keyring-ids) ;vhash mapping key id to packets
|
||
(fingerprints openpgp-keyring-fingerprints)) ;mapping fingerprint to packets
|
||
|
||
(define* (keyring-insert key keyring #:optional (packets '()))
|
||
"Insert the KEY/PACKETS association into KEYRING and return the resulting
|
||
keyring. PACKETS typically contains KEY, an <openpgp-public-key>, alongside
|
||
with additional <openpgp-public-key> records for sub-keys, <openpgp-user-id>
|
||
records, and so on."
|
||
(openpgp-keyring (vhash-consv (openpgp-public-key-id key)
|
||
(cons key packets)
|
||
(openpgp-keyring-ids keyring))
|
||
(vhash-cons (openpgp-public-key-fingerprint key)
|
||
(cons key packets)
|
||
(openpgp-keyring-fingerprints keyring))))
|
||
|
||
(define (lookup-key-by-id keyring id)
|
||
"Return two values: the first key with ID in KEYRING, and a list of
|
||
associated packets (user IDs, signatures, etc.). Return #f and the empty list
|
||
of ID was not found. ID must be the 64-bit key ID of the key, an integer."
|
||
(match (vhash-assv id (openpgp-keyring-ids keyring))
|
||
((_ key packets ...) (values key packets))
|
||
(#f (values #f '()))))
|
||
|
||
(define (lookup-key-by-fingerprint keyring fingerprint)
|
||
"Return two values: the key with FINGERPRINT in KEYRING, and a list of
|
||
associated packets (user IDs, signatures, etc.). Return #f and the empty list
|
||
of FINGERPRINT was not found. FINGERPRINT must be a bytevector."
|
||
(match (vhash-assoc fingerprint (openpgp-keyring-fingerprints keyring))
|
||
((_ key packets ...) (values key packets))
|
||
(#f (values #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 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 keyring))
|
||
(print "#;key " pkt)
|
||
(cond ((or (zero? limit) (eof-object? pkt))
|
||
keyring)
|
||
((openpgp-public-key-primary? pkt)
|
||
;; Read signatures, user id's, subkeys
|
||
(let lp* ((pkt (get-packet port))
|
||
(pkts (list pkt))
|
||
(keys (list 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 keyring-insert <> <> (reverse pkts))
|
||
keyring keys)))
|
||
((openpgp-public-key? pkt) ;subkey
|
||
(lp* (get-packet port) (cons pkt pkts)
|
||
(cons pkt keys)))
|
||
(else
|
||
(lp* (get-packet port) (cons pkt pkts) keys)))))
|
||
(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."
|
||
;; We used to have it implemented in Scheme but the C version here makes
|
||
;; 'load-keyring-from-reference' 18% faster when loading the 72
|
||
;; ASCII-armored files of today's Guix keyring.
|
||
(bytevector->uint (bytevector-hash bv (hash-algorithm crc24-rfc2440))))
|
||
|
||
(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))))
|
||
|
||
(define (string->openpgp-packet str)
|
||
"Read STR, an ASCII-armored OpenPGP packet, and return the corresponding
|
||
OpenPGP record."
|
||
(get-packet
|
||
(open-bytevector-input-port (call-with-input-string str read-radix-64))))
|