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