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