From 43408e304ffb1149f35cb539b40d673d567c9116 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Jan 2020 00:03:58 +0100 Subject: 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. --- guix/openpgp.scm | 1022 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1022 insertions(+) create mode 100644 guix/openpgp.scm (limited to 'guix/openpgp.scm') 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 +;; Copyright © 2020 Ludovic Courtès + +;; 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 +;;; , with extensions from +;;; (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 + (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 + (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 + 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 +. 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 + ;; + ;; 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 + (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 + (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 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)))) -- cgit v1.2.3 From 4459c7859c286ab54fa3a9901c8a17591b04c516 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Apr 2020 23:23:51 +0200 Subject: openpgp: Decode the issuer-fingerprint signature subpacket. * guix/openpgp.scm (SUBPACKET-ISSUER-FINGERPRINT): New variable. (openpgp-signature-issuer-fingerprint): New procedure. (key-id-matches-fingerprint?): New procedure. (get-signature): Look for the 'issuer and 'issuer-fingerprint subpackets. Ensure the issuer key ID matches the fingerprint when both are available. (parse-subpackets): Handle SUBPACKET-ISSUER-FINGERPRINT. * tests/openpgp.scm (%rsa-key-fingerprint) (%dsa-key-fingerprint, %ed25519-key-fingerprint): New variables. * tests/openpgp.scm ("get-openpgp-detached-signature/ascii"): Check the result of 'openpgp-signature-issuer-fingerprint'. --- guix/openpgp.scm | 44 +++++++++++++++++++++++++++++++++++++++----- tests/openpgp.scm | 22 +++++++++++++++++----- 2 files changed, 56 insertions(+), 10 deletions(-) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index bfdbe4b61b..77a75373df 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -33,6 +33,7 @@ (define-module (guix openpgp) openpgp-signature? openpgp-signature-issuer + openpgp-signature-issuer-fingerprint openpgp-signature-public-key-algorithm openpgp-signature-hash-algorithm openpgp-signature-creation-time @@ -345,7 +346,6 @@ (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) @@ -358,8 +358,8 @@ (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) @@ -486,6 +486,13 @@ (define (openpgp-signature-issuer sig) ;; XXX: is the issuer always in the unhashed subpackets? (else #f))) +(define (openpgp-signature-issuer-fingerprint sig) + "When it's available, return the fingerprint, a bytevector, or the issuer of +SIG. Otherwise, return #f." + (or (assoc-ref (openpgp-signature-hashed-subpackets sig) 'issuer-fingerprint) + (assoc-ref (openpgp-signature-unhashed-subpackets sig) + 'issuer-fingerprint))) + (define (openpgp-signature-creation-time sig) (cond ((assq 'signature-ctime (openpgp-signature-hashed-subpackets sig)) => (lambda (x) (unixtime (cdr x)))) @@ -578,6 +585,14 @@ (define (check key sig) (values 'missing-key issuer)))) (values 'unsupported-signature sig))) +(define (key-id-matches-fingerprint? key-id fingerprint) + "Return true if KEY-ID, a number, corresponds to the low 8 bytes of +FINGERPRINT, a bytevector." + (let* ((len (bytevector-length fingerprint)) + (low (make-bytevector 8))) + (bytevector-copy! fingerprint (- len 8) low 0 8) + (= (bytevector->uint low) key-id))) + (define (get-signature p) (define (->hex n) (string-hex-pad (number->string n 16))) @@ -662,14 +677,26 @@ (define (bytevector->hex bv) ;; Errata ID: 2214. (integers->bytevector u8 #x04 u8 #xff - u32 (+ 6 subpacket-len))))) + u32 (+ 6 subpacket-len)))) + (unhashed-subpackets + (parse-subpackets unhashed-subpackets)) + (hashed-subpackets (parse-subpackets hashed-subpackets)) + (subpackets (append hashed-subpackets + unhashed-subpackets)) + (issuer-key-id (assoc-ref subpackets 'issuer)) + (issuer (assoc-ref subpackets + 'issuer-fingerprint))) + (unless (or (not issuer) (not issuer-key-id) + (key-id-matches-fingerprint? issuer-key-id issuer)) + (error "issuer key id does not match fingerprint" issuer)) + (make-openpgp-signature version type (public-key-algorithm pkalg) (openpgp-hash-algorithm halg) hashl16 append-data - (parse-subpackets hashed-subpackets) - (parse-subpackets unhashed-subpackets) + hashed-subpackets + unhashed-subpackets value))))) (else (print "Unsupported signature version: " version) @@ -701,6 +728,13 @@ (define (parse tag 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) diff --git a/tests/openpgp.scm b/tests/openpgp.scm index 8a3c7bbeb7..20d65171fd 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -18,6 +18,7 @@ (define-module (tests-openpgp) #:use-module (guix openpgp) + #:use-module (gcrypt base16) #:use-module (gcrypt hash) #:use-module (gcrypt pk-crypto) #:use-module (ice-9 binary-ports) @@ -65,6 +66,16 @@ (define %rsa-key-id #xAE25DA2A70DEED59) ;rsa.key (define %dsa-key-id #x587918047BE8BD2C) ;dsa.key (define %ed25519-key-id #x771F49CBFAAE072D) ;ed25519.key +(define %rsa-key-fingerprint + (base16-string->bytevector + (string-downcase "385F86CFC86B665A5C165E6BAE25DA2A70DEED59"))) +(define %dsa-key-fingerprint + (base16-string->bytevector + (string-downcase "2884A980422330A4F33DD97F587918047BE8BD2C"))) +(define %ed25519-key-fingerprint + (base16-string->bytevector + (string-downcase "44D31E21AF7138F9B632280A771F49CBFAAE072D"))) + ;;; The following are detached signatures created commands like: ;;; echo 'Hello!' | gpg -sba --digest-algo sha512 @@ -160,15 +171,16 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 "Ludovic Courtès ")))))) (test-equal "get-openpgp-detached-signature/ascii" - (list `(,%dsa-key-id dsa sha256) - `(,%rsa-key-id rsa sha256) - `(,%ed25519-key-id eddsa sha256) - `(,%ed25519-key-id eddsa sha512) - `(,%ed25519-key-id eddsa sha1)) + (list `(,%dsa-key-id ,%dsa-key-fingerprint dsa sha256) + `(,%rsa-key-id ,%rsa-key-fingerprint rsa sha256) + `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha256) + `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha512) + `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha1)) (map (lambda (str) (let ((signature (get-openpgp-detached-signature/ascii (open-input-string str)))) (list (openpgp-signature-issuer signature) + (openpgp-signature-issuer-fingerprint signature) (openpgp-signature-public-key-algorithm signature) (openpgp-signature-hash-algorithm signature)))) (list %hello-signature/dsa -- cgit v1.2.3 From 7b2b3a13cc2d9b043f37b2e7ba0f147c08de8fad Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Apr 2020 16:03:46 +0200 Subject: openpgp: Store the issuer key id and fingerprint in . * guix/openpgp.scm ()[issuer, issuer-fingerprint]: New fields. (openpgp-signature-issuer, openpgp-signature-issuer-fingerprint): Remove. (verify-openpgp-signature): Use 'openpgp-signature-issuer-key-id'. (get-signature): Initialize 'issuer' and 'issuer-fingerprint'. * tests/openpgp.scm ("get-openpgp-detached-signature/ascii"): Adjust accordingly. --- guix/openpgp.scm | 28 ++++++++++------------------ tests/openpgp.scm | 2 +- 2 files changed, 11 insertions(+), 19 deletions(-) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 77a75373df..3b11998c11 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -32,7 +32,7 @@ (define-module (guix openpgp) port-ascii-armored? openpgp-signature? - openpgp-signature-issuer + openpgp-signature-issuer-key-id openpgp-signature-issuer-fingerprint openpgp-signature-public-key-algorithm openpgp-signature-hash-algorithm @@ -469,7 +469,7 @@ (define-record-type (define-record-type (make-openpgp-signature version type pk-algorithm hash-algorithm hashl16 append-data hashed-subpackets unhashed-subpackets - value) + value issuer issuer-fingerprint) openpgp-signature? (version openpgp-signature-version) (type openpgp-signature-type) @@ -479,19 +479,9 @@ (define-record-type (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-issuer-fingerprint sig) - "When it's available, return the fingerprint, a bytevector, or the issuer of -SIG. Otherwise, return #f." - (or (assoc-ref (openpgp-signature-hashed-subpackets sig) 'issuer-fingerprint) - (assoc-ref (openpgp-signature-unhashed-subpackets sig) - 'issuer-fingerprint))) + (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)) @@ -573,7 +563,7 @@ (define (check key sig) ;; TODO: Support SIGNATURE-TEXT. (if (= (openpgp-signature-type sig) SIGNATURE-BINARY) - (let* ((issuer (openpgp-signature-issuer sig)) + (let* ((issuer (openpgp-signature-issuer-key-id sig)) (key-data (lookup-key-by-id keyring issuer))) ;; Find the primary key or subkey that made the signature. (let ((key (find (lambda (k) @@ -651,7 +641,8 @@ (define (bytevector->hex bv) (list (cons 'signature-ctime ctime)) ;; Unhashed subpackets (list (cons 'issuer keyid)) - value)))) + value + keyid #f)))) ((4) (let*-values (((type pkalg halg) (get-integers p u8 u8 u8)) ((hashed-subpackets) @@ -697,7 +688,8 @@ (define (bytevector->hex bv) append-data hashed-subpackets unhashed-subpackets - value))))) + value + issuer-key-id issuer))))) (else (print "Unsupported signature version: " version) 'unsupported-signature-version)))) diff --git a/tests/openpgp.scm b/tests/openpgp.scm index 20d65171fd..1709167859 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -179,7 +179,7 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 (map (lambda (str) (let ((signature (get-openpgp-detached-signature/ascii (open-input-string str)))) - (list (openpgp-signature-issuer signature) + (list (openpgp-signature-issuer-key-id signature) (openpgp-signature-issuer-fingerprint signature) (openpgp-signature-public-key-algorithm signature) (openpgp-signature-hash-algorithm signature)))) -- cgit v1.2.3 From efe1f0122c61b8932671d07419f0200c170a994e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Apr 2020 23:20:26 +0200 Subject: openpgp: Add 'lookup-key-by-fingerprint'. * guix/openpgp.scm ()[table]: Rename to... [ids]: ... this. [fingerprints]: New field. (keyring-insert, lookup-key-by-fingerprint): New procedures. (%empty-keyring): Adjust. (get-openpgp-keyring): Manipulate KEYRING instead of its vhash, use 'keyring-insert'. * tests/openpgp.scm ("get-openpgp-keyring"): Test 'lookup-key-by-fingerprint'. --- guix/openpgp.scm | 43 +++++++++++++++++++++++++++++++------------ tests/openpgp.scm | 16 +++++++++------- 2 files changed, 40 insertions(+), 19 deletions(-) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 3b11998c11..8479f8a168 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -52,6 +52,7 @@ (define-module (guix openpgp) openpgp-keyring? %empty-keyring lookup-key-by-id + lookup-key-by-fingerprint get-openpgp-keyring read-radix-64) @@ -912,14 +913,32 @@ (define (get-user-attribute p len) ;;; Keyring management (define-record-type - (openpgp-keyring table) + (openpgp-keyring ids fingerprints) openpgp-keyring? - (table openpgp-keyring-table)) ;vhash mapping key id to packets + (ids openpgp-keyring-ids) ;vhash mapping key id to packets + (fingerprints openpgp-keyring-fingerprints)) ;mapping fingerprint to packets + +(define* (keyring-insert key keyring #:optional (packets (list key))) + "Insert the KEY/PACKETS association into KEYRING and return the resulting +keyring. PACKETS typically contains KEY, an , alongside +with additional records for sub-keys, +records, and so on." + (openpgp-keyring (vhash-consv (openpgp-public-key-id key) packets + (openpgp-keyring-ids keyring)) + (vhash-cons (openpgp-public-key-fingerprint key) packets + (openpgp-keyring-fingerprints keyring)))) (define (lookup-key-by-id keyring id) "Return a list of packets for the key with ID in KEYRING, or #f if ID could not be found. ID must be the 64-bit key ID of the key, an integer." - (match (vhash-assv id (openpgp-keyring-table keyring)) + (match (vhash-assv id (openpgp-keyring-ids keyring)) + ((_ . lst) lst) + (#f '()))) + +(define (lookup-key-by-fingerprint keyring fingerprint) + "Return a list of packets for the key with FINGERPRINT in KEYRING, or #f if +FINGERPRINT could not be found. FINGERPRINT must be a bytevector." + (match (vhash-assoc fingerprint (openpgp-keyring-fingerprints keyring)) ((_ . lst) lst) (#f '()))) @@ -928,7 +947,7 @@ (define (lookup-key-by-id keyring id) (define %empty-keyring ;; The empty keyring. - (openpgp-keyring vlist-null)) + (openpgp-keyring vlist-null vlist-null)) (define* (get-openpgp-keyring port #:optional (keyring %empty-keyring) @@ -939,15 +958,15 @@ (define* (get-openpgp-keyring port there is no limit." (let lp ((pkt (get-packet port)) (limit limit) - (keyring (openpgp-keyring-table keyring))) + (keyring keyring)) (print "#;key " pkt) (cond ((or (zero? limit) (eof-object? pkt)) - (openpgp-keyring keyring)) + keyring) ((openpgp-public-key-primary? pkt) ;; Read signatures, user id's, subkeys - (let lp* ((pkt (get-packet port)) + (let lp* ((pkt (get-packet port)) (pkts (list pkt)) - (key-ids (list (openpgp-public-key-id pkt)))) + (keys (list pkt))) (print "#;keydata " pkt) (cond ((or (eof-object? pkt) (eq? pkt 'unsupported-public-key-version) @@ -957,13 +976,13 @@ (define* (get-openpgp-keyring port ;; packets. (lp pkt (- limit 1) - (fold (cute vhash-consv <> (reverse pkts) <>) - keyring key-ids))) + (fold (cute keyring-insert <> <> (reverse pkts)) + keyring keys))) ((openpgp-public-key? pkt) ;subkey (lp* (get-packet port) (cons pkt pkts) - (cons (openpgp-public-key-id pkt) key-ids))) + (cons pkt keys))) (else - (lp* (get-packet port) (cons pkt pkts) key-ids))))) + (lp* (get-packet port) (cons pkt pkts) keys))))) (else ;; Skip until there's a primary key. Ignore errors... (lp (get-packet port) limit keyring))))) diff --git a/tests/openpgp.scm b/tests/openpgp.scm index 1709167859..eac2e88f74 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -162,13 +162,15 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 (call-with-input-file key read-radix-64))))) (match (lookup-key-by-id keyring %civodul-key-id) (((? openpgp-public-key? primary) packets ...) - (and (= (openpgp-public-key-id primary) %civodul-key-id) - (not (openpgp-public-key-subkey? primary)) - (string=? (openpgp-format-fingerprint - (openpgp-public-key-fingerprint primary)) - %civodul-fingerprint) - (string=? (openpgp-user-id-value (find openpgp-user-id? packets)) - "Ludovic Courtès ")))))) + (let ((fingerprint (openpgp-public-key-fingerprint primary))) + (and (= (openpgp-public-key-id primary) %civodul-key-id) + (not (openpgp-public-key-subkey? primary)) + (string=? (openpgp-format-fingerprint fingerprint) + %civodul-fingerprint) + (string=? (openpgp-user-id-value (find openpgp-user-id? packets)) + "Ludovic Courtès ") + (equal? (lookup-key-by-id keyring %civodul-key-id) + (lookup-key-by-fingerprint keyring fingerprint)))))))) (test-equal "get-openpgp-detached-signature/ascii" (list `(,%dsa-key-id ,%dsa-key-fingerprint dsa sha256) -- cgit v1.2.3 From b45fa0a123bec8d023e5520dfb381bfc73313929 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Apr 2020 23:27:36 +0200 Subject: openpgp: 'verify-openpgp-signature' looks up by fingerprint when possible. * guix/openpgp.scm (verify-openpgp-signature): Use 'lookup-key-by-fingerprint' when SIG contains a fingerprint. Honor FINGERPRINT in the 'find' predicate. Upon missing-key, return FINGERPRINT if available. * tests/openpgp.scm ("verify-openpgp-signature, missing key"): Adjust expected value accordingly. --- guix/openpgp.scm | 15 +++++++++++---- tests/openpgp.scm | 2 +- 2 files changed, 12 insertions(+), 5 deletions(-) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 8479f8a168..a871eb1a16 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -564,16 +564,23 @@ (define (check key sig) ;; TODO: Support SIGNATURE-TEXT. (if (= (openpgp-signature-type sig) SIGNATURE-BINARY) - (let* ((issuer (openpgp-signature-issuer-key-id sig)) - (key-data (lookup-key-by-id keyring issuer))) + (let* ((id (openpgp-signature-issuer-key-id sig)) + (fingerprint (openpgp-signature-issuer-fingerprint sig)) + (key-data (if fingerprint + (lookup-key-by-fingerprint keyring fingerprint) + (lookup-key-by-id keyring id)))) ;; 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))) + (if fingerprint + (bytevector=? + (openpgp-public-key-fingerprint k) + fingerprint) + (= (openpgp-public-key-id k) id)))) key-data))) (if key (check key sig) - (values 'missing-key issuer)))) + (values 'missing-key (or fingerprint id))))) (values 'unsupported-signature sig))) (define (key-id-matches-fingerprint? key-id fingerprint) diff --git a/tests/openpgp.scm b/tests/openpgp.scm index eac2e88f74..cc5e6cbcf7 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -192,7 +192,7 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 %hello-signature/ed25519/sha1))) (test-equal "verify-openpgp-signature, missing key" - `(missing-key ,%rsa-key-id) + `(missing-key ,%rsa-key-fingerprint) (let* ((keyring (get-openpgp-keyring (%make-void-port "r"))) (signature (get-openpgp-packet (open-bytevector-input-port -- cgit v1.2.3 From bd8126558dc7a022d7853d803d7134ffa1b7bc52 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Apr 2020 15:43:19 +0200 Subject: openpgp: 'lookup-key-by-{id,fingerprint}' return the key first. Previously, 'lookup-key-by-{id,fingerprint}' would always return the list of packets where the primary key is first. Thus, the caller would need to use 'find' to actually find the requested key. * guix/openpgp.scm (keyring-insert): Always add KEY to PACKETS. (lookup-key-by-id, lookup-key-by-fingerprint): Change to return the key as the first value. (verify-openpgp-signature): Remove now unneeded call to 'find'. * tests/openpgp.scm ("get-openpgp-keyring"): Adjust accordingly. --- guix/openpgp.scm | 43 +++++++++++++++++++------------------------ tests/openpgp.scm | 22 +++++++++++----------- 2 files changed, 30 insertions(+), 35 deletions(-) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index a871eb1a16..987660fa29 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -566,21 +566,12 @@ (define (check key sig) (if (= (openpgp-signature-type sig) SIGNATURE-BINARY) (let* ((id (openpgp-signature-issuer-key-id sig)) (fingerprint (openpgp-signature-issuer-fingerprint sig)) - (key-data (if fingerprint + (key (if fingerprint (lookup-key-by-fingerprint keyring fingerprint) (lookup-key-by-id keyring id)))) - ;; Find the primary key or subkey that made the signature. - (let ((key (find (lambda (k) - (and (openpgp-public-key? k) - (if fingerprint - (bytevector=? - (openpgp-public-key-fingerprint k) - fingerprint) - (= (openpgp-public-key-id k) id)))) - key-data))) - (if key - (check key sig) - (values 'missing-key (or fingerprint id))))) + (if key + (check key sig) + (values 'missing-key (or fingerprint id)))) (values 'unsupported-signature sig))) (define (key-id-matches-fingerprint? key-id fingerprint) @@ -925,29 +916,33 @@ (define-record-type (ids openpgp-keyring-ids) ;vhash mapping key id to packets (fingerprints openpgp-keyring-fingerprints)) ;mapping fingerprint to packets -(define* (keyring-insert key keyring #:optional (packets (list key))) +(define* (keyring-insert key keyring #:optional (packets '())) "Insert the KEY/PACKETS association into KEYRING and return the resulting keyring. PACKETS typically contains KEY, an , alongside with additional records for sub-keys, records, and so on." - (openpgp-keyring (vhash-consv (openpgp-public-key-id key) packets + (openpgp-keyring (vhash-consv (openpgp-public-key-id key) + (cons key packets) (openpgp-keyring-ids keyring)) - (vhash-cons (openpgp-public-key-fingerprint key) packets + (vhash-cons (openpgp-public-key-fingerprint key) + (cons key packets) (openpgp-keyring-fingerprints keyring)))) (define (lookup-key-by-id keyring id) - "Return a list of packets for the key with ID in KEYRING, or #f if ID could -not be found. ID must be the 64-bit key ID of the key, an integer." + "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)) - ((_ . lst) lst) - (#f '()))) + ((_ key packets ...) (values key packets)) + (#f (values #f '())))) (define (lookup-key-by-fingerprint keyring fingerprint) - "Return a list of packets for the key with FINGERPRINT in KEYRING, or #f if -FINGERPRINT could not be found. FINGERPRINT must be a bytevector." + "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)) - ((_ . lst) lst) - (#f '()))) + ((_ key packets ...) (values key packets)) + (#f (values #f '())))) ;; Reads a keyring from the binary input port p. It must not be ;; ASCII armored. diff --git a/tests/openpgp.scm b/tests/openpgp.scm index cc5e6cbcf7..a85fe6a6cb 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -160,17 +160,17 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 (keyring (get-openpgp-keyring (open-bytevector-input-port (call-with-input-file key read-radix-64))))) - (match (lookup-key-by-id keyring %civodul-key-id) - (((? openpgp-public-key? primary) packets ...) - (let ((fingerprint (openpgp-public-key-fingerprint primary))) - (and (= (openpgp-public-key-id primary) %civodul-key-id) - (not (openpgp-public-key-subkey? primary)) - (string=? (openpgp-format-fingerprint fingerprint) - %civodul-fingerprint) - (string=? (openpgp-user-id-value (find openpgp-user-id? packets)) - "Ludovic Courtès ") - (equal? (lookup-key-by-id keyring %civodul-key-id) - (lookup-key-by-fingerprint keyring fingerprint)))))))) + (let-values (((primary packets) + (lookup-key-by-id keyring %civodul-key-id))) + (let ((fingerprint (openpgp-public-key-fingerprint primary))) + (and (= (openpgp-public-key-id primary) %civodul-key-id) + (not (openpgp-public-key-subkey? primary)) + (string=? (openpgp-format-fingerprint fingerprint) + %civodul-fingerprint) + (string=? (openpgp-user-id-value (find openpgp-user-id? packets)) + "Ludovic Courtès ") + (eq? (lookup-key-by-fingerprint keyring fingerprint) + primary)))))) (test-equal "get-openpgp-detached-signature/ascii" (list `(,%dsa-key-id ,%dsa-key-fingerprint dsa sha256) -- cgit v1.2.3 From b835e158d51c873a99367afd27f3d57cfe92e10e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Apr 2020 15:56:54 +0200 Subject: openpgp: Add 'string->openpgp-packet'. * guix/openpgp.scm (string->openpgp-packet): New procedure. * tests/openpgp.scm ("verify-openpgp-signature, missing key") ("verify-openpgp-signature, good signatures") ("verify-openpgp-signature, bad signature"): Use it. --- guix/openpgp.scm | 9 ++++++++- tests/openpgp.scm | 15 +++------------ 2 files changed, 11 insertions(+), 13 deletions(-) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 987660fa29..2b2997dcd4 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -55,7 +55,8 @@ (define-module (guix openpgp) lookup-key-by-fingerprint get-openpgp-keyring - read-radix-64) + read-radix-64 + string->openpgp-packet) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) @@ -1067,3 +1068,9 @@ (define (skip-headers port) (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)))) diff --git a/tests/openpgp.scm b/tests/openpgp.scm index a85fe6a6cb..0beab6f88b 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -194,10 +194,7 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 (test-equal "verify-openpgp-signature, missing key" `(missing-key ,%rsa-key-fingerprint) (let* ((keyring (get-openpgp-keyring (%make-void-port "r"))) - (signature (get-openpgp-packet - (open-bytevector-input-port - (call-with-input-string %hello-signature/rsa - read-radix-64))))) + (signature (string->openpgp-packet %hello-signature/rsa))) (let-values (((status key) (verify-openpgp-signature signature keyring (open-input-string "Hello!\n")))) @@ -214,10 +211,7 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 (keyring (get-openpgp-keyring (open-bytevector-input-port (call-with-input-file key read-radix-64)))) - (signature (get-openpgp-packet - (open-bytevector-input-port - (call-with-input-string signature - read-radix-64))))) + (signature (string->openpgp-packet signature))) (let-values (((status key) (verify-openpgp-signature signature keyring (open-input-string "Hello!\n")))) @@ -246,10 +240,7 @@ (define %hello-signature/ed25519/sha1 ;digest-algo: sha1 "tests/ed25519.key" "tests/ed25519.key" "tests/ed25519.key")))) (map (lambda (signature) - (let ((signature (get-openpgp-packet - (open-bytevector-input-port - (call-with-input-string signature - read-radix-64))))) + (let ((signature (string->openpgp-packet signature))) (let-values (((status key) (verify-openpgp-signature signature keyring (open-input-string "What?!")))) -- cgit v1.2.3 From 05d973eef2488d647277dc3f1bde9d019f17eef5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 2 May 2020 23:44:00 +0200 Subject: openpgp: Raise error conditions instead of calling 'error'. * guix/openpgp.scm (&openpgp-error, &openpgp-unrecognized-packet-error) (&openpgp-invalid-signature-error): New error conditions. (openpgp-hash-algorithm): Add 'signature-port' parameter. Raise an error condition instead of calling 'error'. (parse-subpackets): Likewise. (get-data): Raise instead of calling 'error'. (get-openpgp-detached-signature/ascii): Likewise. (get-signature): Likewise. --- guix/openpgp.scm | 61 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 46 insertions(+), 15 deletions(-) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 2b2997dcd4..9370c8ada8 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -31,6 +31,12 @@ (define-module (guix openpgp) verify-openpgp-signature port-ascii-armored? + openpgp-error? + openpgp-unrecognized-packet-error? + openpgp-unrecognized-packet-error-port + openpgp-invalid-signature-error? + openpgp-invalid-signature-error-port + openpgp-signature? openpgp-signature-issuer-key-id openpgp-signature-issuer-fingerprint @@ -119,6 +125,19 @@ (define (string-hex-pad 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? + (port openpgp-unrecognized-packet-error-port)) + +;; Error raised when reading an invalid signature packet. +(define-condition-type &openpgp-invalid-signature-error &openpgp-error + (port openpgp-invalid-signature-error-port)) + ;;; ;;; Bitwise I/O. @@ -312,7 +331,7 @@ (define HASH-SHA-384 9) (define HASH-SHA-512 10) (define HASH-SHA-224 11) -(define (openpgp-hash-algorithm id) +(define (openpgp-hash-algorithm id signature-port) (cond ((= id HASH-MD5) 'md5) ((= id HASH-SHA-1) 'sha1) ((= id HASH-RIPE-MD160) 'rmd160) @@ -320,7 +339,9 @@ (define (openpgp-hash-algorithm id) ((= id HASH-SHA-384) 'sha384) ((= id HASH-SHA-512) 'sha512) ((= id HASH-SHA-224) 'sha224) - (else (error "unknown hash algorithm" id)))) + (else + (raise (condition + (&openpgp-invalid-signature-error (port signature-port))))))) (define COMPRESSION-UNCOMPRESSED 0) (define COMPRESSION-ZIP 1) ;deflate @@ -455,7 +476,7 @@ (define (get-data p tag len) ((= tag PACKET-ONE-PASS-SIGNATURE) 'one-pass-signature) ;TODO: implement (else - (error 'get-data "Unsupported packet type" tag))))) + (raise (condition (&openpgp-unrecognized-packet-error (port p)))))))) (define-record-type (make-openpgp-public-key version subkey? time value fingerprint) @@ -509,7 +530,9 @@ (define (get-openpgp-detached-signature/ascii port) ((string=? type "PGP SIGNATURE") (get-packet (open-bytevector-input-port data))) (else - (error "expected PGP SIGNATURE" type))))) + (print "expected PGP SIGNATURE" type) + (raise (condition + (&openpgp-invalid-signature-error (port port)))))))) (define (hash-algorithm-name algorithm) ;XXX: should be in Guile-Gcrypt "Return the name of ALGORITHM, a 'hash-algorithm' integer, as a symbol." @@ -626,15 +649,17 @@ (define (bytevector->hex bv) (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")) + (raise (condition + (&openpgp-invalid-signature-error (port p))))) + (print "Signature type: " type " creation time: " (unixtime ctime)) - (print "Hash algorithm: " (openpgp-hash-algorithm halg)) + (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) hashl16 + (openpgp-hash-algorithm halg p) hashl16 (list (integers->bytevector u8 type u32 ctime)) ;; Emulate hashed subpackets @@ -651,7 +676,7 @@ (define (bytevector->hex bv) (get-bytevector-n p (get-u16 p))) ((hashl16) (get-u16 p))) (print "Signature type: " type) - (print "Hash algorithm: " (openpgp-hash-algorithm halg)) + (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))) @@ -670,8 +695,8 @@ (define (bytevector->hex bv) u8 #xff u32 (+ 6 subpacket-len)))) (unhashed-subpackets - (parse-subpackets unhashed-subpackets)) - (hashed-subpackets (parse-subpackets hashed-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)) @@ -679,11 +704,14 @@ (define (bytevector->hex bv) 'issuer-fingerprint))) (unless (or (not issuer) (not issuer-key-id) (key-id-matches-fingerprint? issuer-key-id issuer)) - (error "issuer key id does not match fingerprint" issuer)) + (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) + (openpgp-hash-algorithm halg p) hashl16 append-data hashed-subpackets @@ -694,7 +722,7 @@ (define (bytevector->hex bv) (print "Unsupported signature version: " version) 'unsupported-signature-version)))) -(define (parse-subpackets bv) +(define (parse-subpackets bv signature-port) (define (parse tag data) (let ((type (fxbit-field tag 0 7)) (critical? (fxbit-set? tag 7))) @@ -740,7 +768,8 @@ (define (parse tag data) value))))))) ((= type SUBPACKET-PREFERRED-HASH-ALGORITHMS) (cons 'preferred-hash-algorithms - (map openpgp-hash-algorithm (bytevector->u8-list data)))) + (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)))) @@ -785,7 +814,9 @@ (define (parse tag data) ;; should be considered invalid. (print "Unknown subpacket type: " type) (if critical? - (error "unrecognized critical signature subpacket" type) + (raise (condition + (&openpgp-unrecognized-packet-error + (port signature-port)))) (list 'unsupported-subpacket type data)))))) (let ((p (open-bytevector-input-port bv))) -- cgit v1.2.3 From 06735a57a9cec47b5fe01d1c57960b723f52de0d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2020 10:51:39 +0200 Subject: openpgp: Add missing type predicate for '&openpgp-invalid-signature-error'. Reported by brendyyn on #guix. The mistake led to a macro expansion error on Guile 2.2 but not on 3.0.2. * guix/openpgp.scm (&openpgp-invalid-signature-error): Add missing type predicate. --- guix/openpgp.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix/openpgp.scm') diff --git a/guix/openpgp.scm b/guix/openpgp.scm index 9370c8ada8..b74f8ff5bf 100644 --- a/guix/openpgp.scm +++ b/guix/openpgp.scm @@ -136,6 +136,7 @@ (define-condition-type &openpgp-unrecognized-packet-error &openpgp-error ;; 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)) -- cgit v1.2.3