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