Fix buffer-list rename&refresh after after killing a buffer in ido.
[emacs.git] / lisp / pgg-parse.el
blobb0f2a815cbdff97b31790af5a36954a225c50a4d
1 ;;; pgg-parse.el --- OpenPGP packet parsing
3 ;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Daiki Ueno <ueno@unixuser.org>
7 ;; Created: 1999/10/28
8 ;; Keywords: PGP, OpenPGP, GnuPG
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;;; Commentary:
27 ;; This module is based on
29 ;; [OpenPGP] RFC 2440: "OpenPGP Message Format"
30 ;; by John W. Noerenberg, II <jwn2@qualcomm.com>,
31 ;; Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>,
32 ;; Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com>
33 ;; (1998/11)
35 ;;; Code:
37 (eval-when-compile
38 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
39 (require 'cl))
41 (defgroup pgg-parse ()
42 "OpenPGP packet parsing."
43 :group 'pgg)
45 (defcustom pgg-parse-public-key-algorithm-alist
46 '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
47 "Alist of the assigned number to the public key algorithm."
48 :group 'pgg-parse
49 :type '(repeat
50 (cons (sexp :tag "Number") (sexp :tag "Type"))))
52 (defcustom pgg-parse-symmetric-key-algorithm-alist
53 '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
54 "Alist of the assigned number to the simmetric key algorithm."
55 :group 'pgg-parse
56 :type '(repeat
57 (cons (sexp :tag "Number") (sexp :tag "Type"))))
59 (defcustom pgg-parse-hash-algorithm-alist
60 '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384)
61 (10 . SHA512))
62 "Alist of the assigned number to the cryptographic hash algorithm."
63 :group 'pgg-parse
64 :type '(repeat
65 (cons (sexp :tag "Number") (sexp :tag "Type"))))
67 (defcustom pgg-parse-compression-algorithm-alist
68 '((0 . nil); Uncompressed
69 (1 . ZIP)
70 (2 . ZLIB))
71 "Alist of the assigned number to the compression algorithm."
72 :group 'pgg-parse
73 :type '(repeat
74 (cons (sexp :tag "Number") (sexp :tag "Type"))))
76 (defcustom pgg-parse-signature-type-alist
77 '((0 . "Signature of a binary document")
78 (1 . "Signature of a canonical text document")
79 (2 . "Standalone signature")
80 (16 . "Generic certification of a User ID and Public Key packet")
81 (17 . "Persona certification of a User ID and Public Key packet")
82 (18 . "Casual certification of a User ID and Public Key packet")
83 (19 . "Positive certification of a User ID and Public Key packet")
84 (24 . "Subkey Binding Signature")
85 (31 . "Signature directly on a key")
86 (32 . "Key revocation signature")
87 (40 . "Subkey revocation signature")
88 (48 . "Certification revocation signature")
89 (64 . "Timestamp signature."))
90 "Alist of the assigned number to the signature type."
91 :group 'pgg-parse
92 :type '(repeat
93 (cons (sexp :tag "Number") (sexp :tag "Type"))))
95 (defcustom pgg-ignore-packet-checksum t; XXX
96 "If non-nil checksum of each ascii armored packet will be ignored."
97 :group 'pgg-parse
98 :type 'boolean)
100 (defvar pgg-armor-header-lines
101 '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$"
102 "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
103 "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$"
104 "^-----BEGIN PGP SIGNATURE-----\r?$")
105 "Armor headers.")
107 (eval-and-compile
108 (defalias 'pgg-char-int (if (fboundp 'char-int)
109 'char-int
110 'identity)))
112 (defmacro pgg-format-key-identifier (string)
113 `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c)))
114 ,string "")
115 ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
116 ;; (string-to-number-list ,string)))
119 (defmacro pgg-parse-time-field (bytes)
120 `(list (logior (lsh (car ,bytes) 8)
121 (nth 1 ,bytes))
122 (logior (lsh (nth 2 ,bytes) 8)
123 (nth 3 ,bytes))
126 (defmacro pgg-byte-after (&optional pos)
127 `(pgg-char-int (char-after ,(or pos `(point)))))
129 (defmacro pgg-read-byte ()
130 `(pgg-char-int (char-after (prog1 (point) (forward-char)))))
132 (defmacro pgg-read-bytes-string (nbytes)
133 `(buffer-substring
134 (point) (prog1 (+ ,nbytes (point))
135 (forward-char ,nbytes))))
137 (defmacro pgg-read-bytes (nbytes)
138 `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes))
139 ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes))
142 (defmacro pgg-read-body-string (ptag)
143 `(if (nth 1 ,ptag)
144 (pgg-read-bytes-string (nth 1 ,ptag))
145 (pgg-read-bytes-string (- (point-max) (point)))))
147 (defmacro pgg-read-body (ptag)
148 `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag))
149 ;; `(string-to-number-list (pgg-read-body-string ,ptag))
152 (defalias 'pgg-skip-bytes 'forward-char)
154 (defmacro pgg-skip-header (ptag)
155 `(pgg-skip-bytes (nth 2 ,ptag)))
157 (defmacro pgg-skip-body (ptag)
158 `(pgg-skip-bytes (nth 1 ,ptag)))
160 (defmacro pgg-set-alist (alist key value)
161 `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
163 (when (fboundp 'define-ccl-program)
165 (define-ccl-program pgg-parse-crc24
167 ((loop
168 (read r0) (r1 ^= r0) (r2 ^= 0)
169 (r5 = 0)
170 (loop
171 (r1 <<= 1)
172 (r1 += ((r2 >> 15) & 1))
173 (r2 <<= 1)
174 (if (r1 & 256)
175 ((r1 ^= 390) (r2 ^= 19707)))
176 (if (r5 < 7)
177 ((r5 += 1)
178 (repeat))))
179 (repeat)))))
181 (defvar pgg-parse-crc24)
183 (defun pgg-parse-crc24-string (string)
184 (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
185 (ccl-execute-on-string pgg-parse-crc24 h string)
186 (format "%c%c%c"
187 (logand (aref h 1) 255)
188 (logand (lsh (aref h 2) -8) 255)
189 (logand (aref h 2) 255)))))
191 (defmacro pgg-parse-length-type (c)
192 `(cond
193 ((< ,c 192) (cons ,c 1))
194 ((< ,c 224)
195 (cons (+ (lsh (- ,c 192) 8)
196 (pgg-byte-after (+ 2 (point)))
197 192)
199 ((= ,c 255)
200 (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
201 (pgg-byte-after (+ 3 (point))))
202 (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
203 (pgg-byte-after (+ 5 (point)))))
205 (t;partial body length
206 '(0 . 0))))
208 (defun pgg-parse-packet-header ()
209 (let ((ptag (pgg-byte-after))
210 length-type content-tag packet-bytes header-bytes)
211 (if (zerop (logand 64 ptag));Old format
212 (progn
213 (setq length-type (logand ptag 3)
214 length-type (if (= 3 length-type) 0 (lsh 1 length-type))
215 content-tag (logand 15 (lsh ptag -2))
216 packet-bytes 0
217 header-bytes (1+ length-type))
218 (dotimes (i length-type)
219 (setq packet-bytes
220 (logior (lsh packet-bytes 8)
221 (pgg-byte-after (+ 1 i (point)))))))
222 (setq content-tag (logand 63 ptag)
223 length-type (pgg-parse-length-type
224 (pgg-byte-after (1+ (point))))
225 packet-bytes (car length-type)
226 header-bytes (1+ (cdr length-type))))
227 (list content-tag packet-bytes header-bytes)))
229 (defun pgg-parse-packet (ptag)
230 (case (car ptag)
231 (1 ;Public-Key Encrypted Session Key Packet
232 (pgg-parse-public-key-encrypted-session-key-packet ptag))
233 (2 ;Signature Packet
234 (pgg-parse-signature-packet ptag))
235 (3 ;Symmetric-Key Encrypted Session Key Packet
236 (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
237 ;; 4 -- One-Pass Signature Packet
238 ;; 5 -- Secret Key Packet
239 (6 ;Public Key Packet
240 (pgg-parse-public-key-packet ptag))
241 ;; 7 -- Secret Subkey Packet
242 ;; 8 -- Compressed Data Packet
243 (9 ;Symmetrically Encrypted Data Packet
244 (pgg-read-body-string ptag))
245 (10 ;Marker Packet
246 (pgg-read-body-string ptag))
247 (11 ;Literal Data Packet
248 (pgg-read-body-string ptag))
249 ;; 12 -- Trust Packet
250 (13 ;User ID Packet
251 (pgg-read-body-string ptag))
252 ;; 14 -- Public Subkey Packet
253 ;; 60 .. 63 -- Private or Experimental Values
256 (defun pgg-parse-packets (&optional header-parser body-parser)
257 (let ((header-parser
258 (or header-parser
259 (function pgg-parse-packet-header)))
260 (body-parser
261 (or body-parser
262 (function pgg-parse-packet)))
263 result ptag)
264 (while (> (point-max) (1+ (point)))
265 (setq ptag (funcall header-parser))
266 (pgg-skip-header ptag)
267 (push (cons (car ptag)
268 (save-excursion
269 (funcall body-parser ptag)))
270 result)
271 (if (zerop (nth 1 ptag))
272 (goto-char (point-max))
273 (forward-char (nth 1 ptag))))
274 result))
276 (defun pgg-parse-signature-subpacket-header ()
277 (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
278 (list (pgg-byte-after (+ (cdr length-type) (point)))
279 (1- (car length-type))
280 (1+ (cdr length-type)))))
282 (defun pgg-parse-signature-subpacket (ptag)
283 (case (car ptag)
284 (2 ;signature creation time
285 (cons 'creation-time
286 (let ((bytes (pgg-read-bytes 4)))
287 (pgg-parse-time-field bytes))))
288 (3 ;signature expiration time
289 (cons 'signature-expiry
290 (let ((bytes (pgg-read-bytes 4)))
291 (pgg-parse-time-field bytes))))
292 (4 ;exportable certification
293 (cons 'exportability (pgg-read-byte)))
294 (5 ;trust signature
295 (cons 'trust-level (pgg-read-byte)))
296 (6 ;regular expression
297 (cons 'regular-expression
298 (pgg-read-body-string ptag)))
299 (7 ;revocable
300 (cons 'revocability (pgg-read-byte)))
301 (9 ;key expiration time
302 (cons 'key-expiry
303 (let ((bytes (pgg-read-bytes 4)))
304 (pgg-parse-time-field bytes))))
305 ;; 10 = placeholder for backward compatibility
306 (11 ;preferred symmetric algorithms
307 (cons 'preferred-symmetric-key-algorithm
308 (cdr (assq (pgg-read-byte)
309 pgg-parse-symmetric-key-algorithm-alist))))
310 (12 ;revocation key
312 (16 ;issuer key ID
313 (cons 'key-identifier
314 (pgg-format-key-identifier (pgg-read-body-string ptag))))
315 (20 ;notation data
316 (pgg-skip-bytes 4)
317 (cons 'notation
318 (let ((name-bytes (pgg-read-bytes 2))
319 (value-bytes (pgg-read-bytes 2)))
320 (cons (pgg-read-bytes-string
321 (logior (lsh (car name-bytes) 8)
322 (nth 1 name-bytes)))
323 (pgg-read-bytes-string
324 (logior (lsh (car value-bytes) 8)
325 (nth 1 value-bytes)))))))
326 (21 ;preferred hash algorithms
327 (cons 'preferred-hash-algorithm
328 (cdr (assq (pgg-read-byte)
329 pgg-parse-hash-algorithm-alist))))
330 (22 ;preferred compression algorithms
331 (cons 'preferred-compression-algorithm
332 (cdr (assq (pgg-read-byte)
333 pgg-parse-compression-algorithm-alist))))
334 (23 ;key server preferences
335 (cons 'key-server-preferences
336 (pgg-read-body ptag)))
337 (24 ;preferred key server
338 (cons 'preferred-key-server
339 (pgg-read-body-string ptag)))
340 ;; 25 = primary user id
341 (26 ;policy URL
342 (cons 'policy-url (pgg-read-body-string ptag)))
343 ;; 27 = key flags
344 ;; 28 = signer's user id
345 ;; 29 = reason for revocation
346 ;; 100 to 110 = internal or user-defined
349 (defun pgg-parse-signature-packet (ptag)
350 (let* ((signature-version (pgg-byte-after))
351 (result (list (cons 'version signature-version)))
352 hashed-material field n)
353 (cond
354 ((= signature-version 3)
355 (pgg-skip-bytes 2)
356 (setq hashed-material (pgg-read-bytes 5))
357 (pgg-set-alist result
358 'signature-type
359 (cdr (assq (pop hashed-material)
360 pgg-parse-signature-type-alist)))
361 (pgg-set-alist result
362 'creation-time
363 (pgg-parse-time-field hashed-material))
364 (pgg-set-alist result
365 'key-identifier
366 (pgg-format-key-identifier
367 (pgg-read-bytes-string 8)))
368 (pgg-set-alist result
369 'public-key-algorithm (pgg-read-byte))
370 (pgg-set-alist result
371 'hash-algorithm (pgg-read-byte)))
372 ((= signature-version 4)
373 (pgg-skip-bytes 1)
374 (pgg-set-alist result
375 'signature-type
376 (cdr (assq (pgg-read-byte)
377 pgg-parse-signature-type-alist)))
378 (pgg-set-alist result
379 'public-key-algorithm
380 (pgg-read-byte))
381 (pgg-set-alist result
382 'hash-algorithm (pgg-read-byte))
383 (when (>= 10000 (setq n (pgg-read-bytes 2)
384 n (logior (lsh (car n) 8)
385 (nth 1 n))))
386 (save-restriction
387 (narrow-to-region (point)(+ n (point)))
388 (nconc result
389 (mapcar (function cdr) ;remove packet types
390 (pgg-parse-packets
391 #'pgg-parse-signature-subpacket-header
392 #'pgg-parse-signature-subpacket)))
393 (goto-char (point-max))))
394 (when (>= 10000 (setq n (pgg-read-bytes 2)
395 n (logior (lsh (car n) 8)
396 (nth 1 n))))
397 (save-restriction
398 (narrow-to-region (point)(+ n (point)))
399 (nconc result
400 (mapcar (function cdr) ;remove packet types
401 (pgg-parse-packets
402 #'pgg-parse-signature-subpacket-header
403 #'pgg-parse-signature-subpacket)))))))
405 (setcdr (setq field (assq 'public-key-algorithm
406 result))
407 (cdr (assq (cdr field)
408 pgg-parse-public-key-algorithm-alist)))
409 (setcdr (setq field (assq 'hash-algorithm
410 result))
411 (cdr (assq (cdr field)
412 pgg-parse-hash-algorithm-alist)))
413 result))
415 (defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
416 (let (result)
417 (pgg-set-alist result
418 'version (pgg-read-byte))
419 (pgg-set-alist result
420 'key-identifier
421 (pgg-format-key-identifier
422 (pgg-read-bytes-string 8)))
423 (pgg-set-alist result
424 'public-key-algorithm
425 (cdr (assq (pgg-read-byte)
426 pgg-parse-public-key-algorithm-alist)))
427 result))
429 (defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
430 (let (result)
431 (pgg-set-alist result
432 'version
433 (pgg-read-byte))
434 (pgg-set-alist result
435 'symmetric-key-algorithm
436 (cdr (assq (pgg-read-byte)
437 pgg-parse-symmetric-key-algorithm-alist)))
438 result))
440 (defun pgg-parse-public-key-packet (ptag)
441 (let* ((key-version (pgg-read-byte))
442 (result (list (cons 'version key-version)))
443 field)
444 (cond
445 ((= 3 key-version)
446 (pgg-set-alist result
447 'creation-time
448 (let ((bytes (pgg-read-bytes 4)))
449 (pgg-parse-time-field bytes)))
450 (pgg-set-alist result
451 'key-expiry (pgg-read-bytes 2))
452 (pgg-set-alist result
453 'public-key-algorithm (pgg-read-byte)))
454 ((= 4 key-version)
455 (pgg-set-alist result
456 'creation-time
457 (let ((bytes (pgg-read-bytes 4)))
458 (pgg-parse-time-field bytes)))
459 (pgg-set-alist result
460 'public-key-algorithm (pgg-read-byte))))
462 (setcdr (setq field (assq 'public-key-algorithm
463 result))
464 (cdr (assq (cdr field)
465 pgg-parse-public-key-algorithm-alist)))
466 result))
468 ;; p-d-p only calls this if it is defined, but the compiler does not
469 ;; recognize that.
470 (declare-function pgg-parse-crc24-string "pgg-parse" (string))
472 (defun pgg-decode-packets ()
473 (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t)
474 (let ((p (match-beginning 0))
475 (checksum (match-string 1)))
476 (delete-region p (point-max))
477 (if (ignore-errors (base64-decode-region (point-min) p))
478 (or (not (fboundp 'pgg-parse-crc24-string))
479 pgg-ignore-packet-checksum
480 (string-equal (base64-encode-string (pgg-parse-crc24-string
481 (buffer-string)))
482 checksum)
483 (progn
484 (message "PGP packet checksum does not match")
485 nil))
486 (message "PGP packet contain invalid base64")
487 nil))
488 (message "PGP packet checksum not found")
489 nil))
491 (defun pgg-decode-armor-region (start end)
492 (save-restriction
493 (narrow-to-region start end)
494 (goto-char (point-min))
495 (re-search-forward "^-+BEGIN PGP" nil t)
496 (delete-region (point-min)
497 (and (search-forward "\n\n")
498 (match-end 0)))
499 (when (pgg-decode-packets)
500 (goto-char (point-min))
501 (pgg-parse-packets))))
503 (defun pgg-parse-armor (string)
504 (with-temp-buffer
505 (buffer-disable-undo)
506 (if (fboundp 'set-buffer-multibyte)
507 (set-buffer-multibyte nil))
508 (insert string)
509 (pgg-decode-armor-region (point-min)(point))))
511 (eval-and-compile
512 (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte)
513 'string-as-unibyte
514 'identity)))
516 (defun pgg-parse-armor-region (start end)
517 (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end))))
519 (provide 'pgg-parse)
521 ;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e
522 ;;; pgg-parse.el ends here