Mercurial > emacs
comparison lisp/gnus/mml2015.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | |
children | 6d1f39d4f8e6 |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP) | |
2 ;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. | |
3 | |
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> | |
5 ;; Keywords: PGP MIME MML | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published | |
11 ;; by the Free Software Foundation; either version 2, or (at your | |
12 ;; option) any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, but | |
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
17 ;; General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 ;; Boston, MA 02111-1307, USA. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 ;; RFC 2015 is updated by RFC 3156, this file should be compatible | |
27 ;; with both. | |
28 | |
29 ;;; Code: | |
30 | |
31 (eval-when-compile (require 'cl)) | |
32 (require 'mm-decode) | |
33 (require 'mm-util) | |
34 (require 'mml) | |
35 | |
36 (defvar mml2015-use (or | |
37 (progn | |
38 (ignore-errors | |
39 (require 'pgg)) | |
40 (and (fboundp 'pgg-sign-region) | |
41 'pgg)) | |
42 (progn | |
43 (ignore-errors | |
44 (require 'gpg)) | |
45 (and (fboundp 'gpg-sign-detached) | |
46 'gpg)) | |
47 (progn (ignore-errors | |
48 (load "mc-toplev")) | |
49 (and (fboundp 'mc-encrypt-generic) | |
50 (fboundp 'mc-sign-generic) | |
51 (fboundp 'mc-cleanup-recipient-headers) | |
52 'mailcrypt))) | |
53 "The package used for PGP/MIME.") | |
54 | |
55 ;; Something is not RFC2015. | |
56 (defvar mml2015-function-alist | |
57 '((mailcrypt mml2015-mailcrypt-sign | |
58 mml2015-mailcrypt-encrypt | |
59 mml2015-mailcrypt-verify | |
60 mml2015-mailcrypt-decrypt | |
61 mml2015-mailcrypt-clear-verify | |
62 mml2015-mailcrypt-clear-decrypt) | |
63 (gpg mml2015-gpg-sign | |
64 mml2015-gpg-encrypt | |
65 mml2015-gpg-verify | |
66 mml2015-gpg-decrypt | |
67 mml2015-gpg-clear-verify | |
68 mml2015-gpg-clear-decrypt) | |
69 (pgg mml2015-pgg-sign | |
70 mml2015-pgg-encrypt | |
71 mml2015-pgg-verify | |
72 mml2015-pgg-decrypt | |
73 mml2015-pgg-clear-verify | |
74 mml2015-pgg-clear-decrypt)) | |
75 "Alist of PGP/MIME functions.") | |
76 | |
77 (defvar mml2015-result-buffer nil) | |
78 | |
79 (defcustom mml2015-unabbrev-trust-alist | |
80 '(("TRUST_UNDEFINED" . nil) | |
81 ("TRUST_NEVER" . nil) | |
82 ("TRUST_MARGINAL" . t) | |
83 ("TRUST_FULLY" . t) | |
84 ("TRUST_ULTIMATE" . t)) | |
85 "Map GnuPG trust output values to a boolean saying if you trust the key." | |
86 :type '(repeat (cons (regexp :tag "GnuPG output regexp") | |
87 (boolean :tag "Trust key")))) | |
88 | |
89 ;;; mailcrypt wrapper | |
90 | |
91 (eval-and-compile | |
92 (autoload 'mailcrypt-decrypt "mailcrypt") | |
93 (autoload 'mailcrypt-verify "mailcrypt") | |
94 (autoload 'mc-pgp-always-sign "mailcrypt") | |
95 (autoload 'mc-encrypt-generic "mc-toplev") | |
96 (autoload 'mc-cleanup-recipient-headers "mc-toplev") | |
97 (autoload 'mc-sign-generic "mc-toplev")) | |
98 | |
99 (eval-when-compile | |
100 (defvar mc-default-scheme) | |
101 (defvar mc-schemes)) | |
102 | |
103 (defvar mml2015-decrypt-function 'mailcrypt-decrypt) | |
104 (defvar mml2015-verify-function 'mailcrypt-verify) | |
105 | |
106 (defun mml2015-format-error (err) | |
107 (if (stringp (cadr err)) | |
108 (cadr err) | |
109 (format "%S" (cdr err)))) | |
110 | |
111 (defun mml2015-mailcrypt-decrypt (handle ctl) | |
112 (catch 'error | |
113 (let (child handles result) | |
114 (unless (setq child (mm-find-part-by-type | |
115 (cdr handle) | |
116 "application/octet-stream" nil t)) | |
117 (mm-set-handle-multipart-parameter | |
118 mm-security-handle 'gnus-info "Corrupted") | |
119 (throw 'error handle)) | |
120 (with-temp-buffer | |
121 (mm-insert-part child) | |
122 (setq result | |
123 (condition-case err | |
124 (funcall mml2015-decrypt-function) | |
125 (error | |
126 (mm-set-handle-multipart-parameter | |
127 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
128 nil) | |
129 (quit | |
130 (mm-set-handle-multipart-parameter | |
131 mm-security-handle 'gnus-details "Quit.") | |
132 nil))) | |
133 (unless (car result) | |
134 (mm-set-handle-multipart-parameter | |
135 mm-security-handle 'gnus-info "Failed") | |
136 (throw 'error handle)) | |
137 (setq handles (mm-dissect-buffer t))) | |
138 (mm-destroy-parts handle) | |
139 (mm-set-handle-multipart-parameter | |
140 mm-security-handle 'gnus-info | |
141 (concat "OK" | |
142 (let ((sig (with-current-buffer mml2015-result-buffer | |
143 (mml2015-gpg-extract-signature-details)))) | |
144 (concat ", Signer: " sig)))) | |
145 (if (listp (car handles)) | |
146 handles | |
147 (list handles))))) | |
148 | |
149 (defun mml2015-mailcrypt-clear-decrypt () | |
150 (let (result) | |
151 (setq result | |
152 (condition-case err | |
153 (funcall mml2015-decrypt-function) | |
154 (error | |
155 (mm-set-handle-multipart-parameter | |
156 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
157 nil) | |
158 (quit | |
159 (mm-set-handle-multipart-parameter | |
160 mm-security-handle 'gnus-details "Quit.") | |
161 nil))) | |
162 (if (car result) | |
163 (mm-set-handle-multipart-parameter | |
164 mm-security-handle 'gnus-info "OK") | |
165 (mm-set-handle-multipart-parameter | |
166 mm-security-handle 'gnus-info "Failed")))) | |
167 | |
168 (defun mml2015-fix-micalg (alg) | |
169 (and alg | |
170 ;; Mutt/1.2.5i has seen sending micalg=php-sha1 | |
171 (upcase (if (string-match "^p[gh]p-" alg) | |
172 (substring alg (match-end 0)) | |
173 alg)))) | |
174 | |
175 (defun mml2015-mailcrypt-verify (handle ctl) | |
176 (catch 'error | |
177 (let (part) | |
178 (unless (setq part (mm-find-raw-part-by-type | |
179 ctl (or (mm-handle-multipart-ctl-parameter | |
180 ctl 'protocol) | |
181 "application/pgp-signature") | |
182 t)) | |
183 (mm-set-handle-multipart-parameter | |
184 mm-security-handle 'gnus-info "Corrupted") | |
185 (throw 'error handle)) | |
186 (with-temp-buffer | |
187 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n") | |
188 (insert (format "Hash: %s\n\n" | |
189 (or (mml2015-fix-micalg | |
190 (mm-handle-multipart-ctl-parameter | |
191 ctl 'micalg)) | |
192 "SHA1"))) | |
193 (save-restriction | |
194 (narrow-to-region (point) (point)) | |
195 (insert part "\n") | |
196 (goto-char (point-min)) | |
197 (while (not (eobp)) | |
198 (if (looking-at "^-") | |
199 (insert "- ")) | |
200 (forward-line))) | |
201 (unless (setq part (mm-find-part-by-type | |
202 (cdr handle) "application/pgp-signature" nil t)) | |
203 (mm-set-handle-multipart-parameter | |
204 mm-security-handle 'gnus-info "Corrupted") | |
205 (throw 'error handle)) | |
206 (save-restriction | |
207 (narrow-to-region (point) (point)) | |
208 (mm-insert-part part) | |
209 (goto-char (point-min)) | |
210 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t) | |
211 (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) | |
212 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) | |
213 (replace-match "-----END PGP SIGNATURE-----" t t))) | |
214 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) | |
215 (unless (condition-case err | |
216 (prog1 | |
217 (funcall mml2015-verify-function) | |
218 (if (get-buffer " *mailcrypt stderr temp") | |
219 (mm-set-handle-multipart-parameter | |
220 mm-security-handle 'gnus-details | |
221 (with-current-buffer " *mailcrypt stderr temp" | |
222 (buffer-string)))) | |
223 (if (get-buffer " *mailcrypt stdout temp") | |
224 (kill-buffer " *mailcrypt stdout temp")) | |
225 (if (get-buffer " *mailcrypt stderr temp") | |
226 (kill-buffer " *mailcrypt stderr temp")) | |
227 (if (get-buffer " *mailcrypt status temp") | |
228 (kill-buffer " *mailcrypt status temp")) | |
229 (if (get-buffer mc-gpg-debug-buffer) | |
230 (kill-buffer mc-gpg-debug-buffer))) | |
231 (error | |
232 (mm-set-handle-multipart-parameter | |
233 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
234 nil) | |
235 (quit | |
236 (mm-set-handle-multipart-parameter | |
237 mm-security-handle 'gnus-details "Quit.") | |
238 nil)) | |
239 (mm-set-handle-multipart-parameter | |
240 mm-security-handle 'gnus-info "Failed") | |
241 (throw 'error handle)))) | |
242 (mm-set-handle-multipart-parameter | |
243 mm-security-handle 'gnus-info "OK") | |
244 handle))) | |
245 | |
246 (defun mml2015-mailcrypt-clear-verify () | |
247 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) | |
248 (if (condition-case err | |
249 (prog1 | |
250 (funcall mml2015-verify-function) | |
251 (if (get-buffer " *mailcrypt stderr temp") | |
252 (mm-set-handle-multipart-parameter | |
253 mm-security-handle 'gnus-details | |
254 (with-current-buffer " *mailcrypt stderr temp" | |
255 (buffer-string)))) | |
256 (if (get-buffer " *mailcrypt stdout temp") | |
257 (kill-buffer " *mailcrypt stdout temp")) | |
258 (if (get-buffer " *mailcrypt stderr temp") | |
259 (kill-buffer " *mailcrypt stderr temp")) | |
260 (if (get-buffer " *mailcrypt status temp") | |
261 (kill-buffer " *mailcrypt status temp")) | |
262 (if (get-buffer mc-gpg-debug-buffer) | |
263 (kill-buffer mc-gpg-debug-buffer))) | |
264 (error | |
265 (mm-set-handle-multipart-parameter | |
266 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
267 nil) | |
268 (quit | |
269 (mm-set-handle-multipart-parameter | |
270 mm-security-handle 'gnus-details "Quit.") | |
271 nil)) | |
272 (mm-set-handle-multipart-parameter | |
273 mm-security-handle 'gnus-info "OK") | |
274 (mm-set-handle-multipart-parameter | |
275 mm-security-handle 'gnus-info "Failed")))) | |
276 | |
277 (defun mml2015-mailcrypt-sign (cont) | |
278 (mc-sign-generic (message-options-get 'message-sender) | |
279 nil nil nil nil) | |
280 (let ((boundary (mml-compute-boundary cont)) | |
281 hash point) | |
282 (goto-char (point-min)) | |
283 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t) | |
284 (error "Cannot find signed begin line")) | |
285 (goto-char (match-beginning 0)) | |
286 (forward-line 1) | |
287 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)") | |
288 (error "Cannot not find PGP hash")) | |
289 (setq hash (match-string 1)) | |
290 (unless (re-search-forward "^$" nil t) | |
291 (error "Cannot not find PGP message")) | |
292 (forward-line 1) | |
293 (delete-region (point-min) (point)) | |
294 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" | |
295 boundary)) | |
296 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n" | |
297 (downcase hash))) | |
298 (insert (format "\n--%s\n" boundary)) | |
299 (setq point (point)) | |
300 (goto-char (point-max)) | |
301 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t) | |
302 (error "Cannot find signature part")) | |
303 (replace-match "-----END PGP MESSAGE-----" t t) | |
304 (goto-char (match-beginning 0)) | |
305 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$" | |
306 nil t) | |
307 (error "Cannot find signature part")) | |
308 (replace-match "-----BEGIN PGP MESSAGE-----" t t) | |
309 (goto-char (match-beginning 0)) | |
310 (save-restriction | |
311 (narrow-to-region point (point)) | |
312 (goto-char point) | |
313 (while (re-search-forward "^- -" nil t) | |
314 (replace-match "-" t t)) | |
315 (goto-char (point-max))) | |
316 (insert (format "--%s\n" boundary)) | |
317 (insert "Content-Type: application/pgp-signature\n\n") | |
318 (goto-char (point-max)) | |
319 (insert (format "--%s--\n" boundary)) | |
320 (goto-char (point-max)))) | |
321 | |
322 (defun mml2015-mailcrypt-encrypt (cont &optional sign) | |
323 (let ((mc-pgp-always-sign | |
324 (or mc-pgp-always-sign | |
325 sign | |
326 (eq t (or (message-options-get 'message-sign-encrypt) | |
327 (message-options-set | |
328 'message-sign-encrypt | |
329 (or (y-or-n-p "Sign the message? ") | |
330 'not)))) | |
331 'never))) | |
332 (mm-with-unibyte-current-buffer | |
333 (mc-encrypt-generic | |
334 (or (message-options-get 'message-recipients) | |
335 (message-options-set 'message-recipients | |
336 (mc-cleanup-recipient-headers | |
337 (read-string "Recipients: ")))) | |
338 nil nil nil | |
339 (message-options-get 'message-sender)))) | |
340 (goto-char (point-min)) | |
341 (unless (looking-at "-----BEGIN PGP MESSAGE-----") | |
342 (error "Fail to encrypt the message")) | |
343 (let ((boundary (mml-compute-boundary cont))) | |
344 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" | |
345 boundary)) | |
346 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") | |
347 (insert (format "--%s\n" boundary)) | |
348 (insert "Content-Type: application/pgp-encrypted\n\n") | |
349 (insert "Version: 1\n\n") | |
350 (insert (format "--%s\n" boundary)) | |
351 (insert "Content-Type: application/octet-stream\n\n") | |
352 (goto-char (point-max)) | |
353 (insert (format "--%s--\n" boundary)) | |
354 (goto-char (point-max)))) | |
355 | |
356 ;;; gpg wrapper | |
357 | |
358 (eval-and-compile | |
359 (autoload 'gpg-decrypt "gpg") | |
360 (autoload 'gpg-verify "gpg") | |
361 (autoload 'gpg-verify-cleartext "gpg") | |
362 (autoload 'gpg-sign-detached "gpg") | |
363 (autoload 'gpg-sign-encrypt "gpg") | |
364 (autoload 'gpg-encrypt "gpg") | |
365 (autoload 'gpg-passphrase-read "gpg")) | |
366 | |
367 (defun mml2015-gpg-passphrase () | |
368 (or (message-options-get 'gpg-passphrase) | |
369 (message-options-set 'gpg-passphrase (gpg-passphrase-read)))) | |
370 | |
371 (defun mml2015-gpg-decrypt-1 () | |
372 (let ((cipher (current-buffer)) plain result) | |
373 (if (with-temp-buffer | |
374 (prog1 | |
375 (gpg-decrypt cipher (setq plain (current-buffer)) | |
376 mml2015-result-buffer nil) | |
377 (mm-set-handle-multipart-parameter | |
378 mm-security-handle 'gnus-details | |
379 (with-current-buffer mml2015-result-buffer | |
380 (buffer-string))) | |
381 (set-buffer cipher) | |
382 (erase-buffer) | |
383 (insert-buffer-substring plain) | |
384 (goto-char (point-min)) | |
385 (while (search-forward "\r\n" nil t) | |
386 (replace-match "\n" t t)))) | |
387 '(t) | |
388 ;; Some wrong with the return value, check plain text buffer. | |
389 (if (> (point-max) (point-min)) | |
390 '(t) | |
391 nil)))) | |
392 | |
393 (defun mml2015-gpg-decrypt (handle ctl) | |
394 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1)) | |
395 (mml2015-mailcrypt-decrypt handle ctl))) | |
396 | |
397 (defun mml2015-gpg-clear-decrypt () | |
398 (let (result) | |
399 (setq result (mml2015-gpg-decrypt-1)) | |
400 (if (car result) | |
401 (mm-set-handle-multipart-parameter | |
402 mm-security-handle 'gnus-info "OK") | |
403 (mm-set-handle-multipart-parameter | |
404 mm-security-handle 'gnus-info "Failed")))) | |
405 | |
406 (defun mml2015-gpg-pretty-print-fpr (fingerprint) | |
407 (let* ((result "") | |
408 (fpr-length (string-width fingerprint)) | |
409 (n-slice 0) | |
410 slice) | |
411 (setq fingerprint (string-to-list fingerprint)) | |
412 (while fingerprint | |
413 (setq fpr-length (- fpr-length 4)) | |
414 (setq slice (butlast fingerprint fpr-length)) | |
415 (setq fingerprint (nthcdr 4 fingerprint)) | |
416 (setq n-slice (1+ n-slice)) | |
417 (setq result | |
418 (concat | |
419 result | |
420 (case n-slice | |
421 (1 slice) | |
422 (otherwise (concat " " slice)))))) | |
423 result)) | |
424 | |
425 (defun mml2015-gpg-extract-signature-details () | |
426 (goto-char (point-min)) | |
427 (let* ((expired (re-search-forward | |
428 "^\\[GNUPG:\\] SIGEXPIRED$" | |
429 nil t)) | |
430 (signer (and (re-search-forward | |
431 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$" | |
432 nil t) | |
433 (cons (match-string 1) (match-string 2)))) | |
434 (fprint (and (re-search-forward | |
435 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) " | |
436 nil t) | |
437 (match-string 1))) | |
438 (trust (and (re-search-forward | |
439 "^\\[GNUPG:\\] \\(TRUST_.*\\)$" | |
440 nil t) | |
441 (match-string 1))) | |
442 (trust-good-enough-p | |
443 (cdr (assoc trust mml2015-unabbrev-trust-alist)))) | |
444 (cond ((and signer fprint) | |
445 (concat (cdr signer) | |
446 (unless trust-good-enough-p | |
447 (concat "\nUntrusted, Fingerprint: " | |
448 (mml2015-gpg-pretty-print-fpr fprint))) | |
449 (when expired | |
450 (format "\nWARNING: Signature from expired key (%s)" | |
451 (car signer))))) | |
452 ((re-search-forward | |
453 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t) | |
454 (match-string 2)) | |
455 (t | |
456 "From unknown user")))) | |
457 | |
458 (defun mml2015-gpg-verify (handle ctl) | |
459 (catch 'error | |
460 (let (part message signature info-is-set-p) | |
461 (unless (setq part (mm-find-raw-part-by-type | |
462 ctl (or (mm-handle-multipart-ctl-parameter | |
463 ctl 'protocol) | |
464 "application/pgp-signature") | |
465 t)) | |
466 (mm-set-handle-multipart-parameter | |
467 mm-security-handle 'gnus-info "Corrupted") | |
468 (throw 'error handle)) | |
469 (with-temp-buffer | |
470 (setq message (current-buffer)) | |
471 (insert part) | |
472 ;; Convert <LF> to <CR><LF> in verify mode. Sign and | |
473 ;; clearsign use --textmode. The conversion is not necessary. | |
474 ;; In clearverify, the conversion is not necessary either. | |
475 (goto-char (point-min)) | |
476 (end-of-line) | |
477 (while (not (eobp)) | |
478 (unless (eq (char-before) ?\r) | |
479 (insert "\r")) | |
480 (forward-line) | |
481 (end-of-line)) | |
482 (with-temp-buffer | |
483 (setq signature (current-buffer)) | |
484 (unless (setq part (mm-find-part-by-type | |
485 (cdr handle) "application/pgp-signature" nil t)) | |
486 (mm-set-handle-multipart-parameter | |
487 mm-security-handle 'gnus-info "Corrupted") | |
488 (throw 'error handle)) | |
489 (mm-insert-part part) | |
490 (unless (condition-case err | |
491 (prog1 | |
492 (gpg-verify message signature mml2015-result-buffer) | |
493 (mm-set-handle-multipart-parameter | |
494 mm-security-handle 'gnus-details | |
495 (with-current-buffer mml2015-result-buffer | |
496 (buffer-string)))) | |
497 (error | |
498 (mm-set-handle-multipart-parameter | |
499 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
500 (mm-set-handle-multipart-parameter | |
501 mm-security-handle 'gnus-info "Error.") | |
502 (setq info-is-set-p t) | |
503 nil) | |
504 (quit | |
505 (mm-set-handle-multipart-parameter | |
506 mm-security-handle 'gnus-details "Quit.") | |
507 (mm-set-handle-multipart-parameter | |
508 mm-security-handle 'gnus-info "Quit.") | |
509 (setq info-is-set-p t) | |
510 nil)) | |
511 (unless info-is-set-p | |
512 (mm-set-handle-multipart-parameter | |
513 mm-security-handle 'gnus-info "Failed")) | |
514 (throw 'error handle))) | |
515 (mm-set-handle-multipart-parameter | |
516 mm-security-handle 'gnus-info | |
517 (with-current-buffer mml2015-result-buffer | |
518 (mml2015-gpg-extract-signature-details)))) | |
519 handle))) | |
520 | |
521 (defun mml2015-gpg-clear-verify () | |
522 (if (condition-case err | |
523 (prog1 | |
524 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer) | |
525 (mm-set-handle-multipart-parameter | |
526 mm-security-handle 'gnus-details | |
527 (with-current-buffer mml2015-result-buffer | |
528 (buffer-string)))) | |
529 (error | |
530 (mm-set-handle-multipart-parameter | |
531 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
532 nil) | |
533 (quit | |
534 (mm-set-handle-multipart-parameter | |
535 mm-security-handle 'gnus-details "Quit.") | |
536 nil)) | |
537 (mm-set-handle-multipart-parameter | |
538 mm-security-handle 'gnus-info | |
539 (with-current-buffer mml2015-result-buffer | |
540 (mml2015-gpg-extract-signature-details))) | |
541 (mm-set-handle-multipart-parameter | |
542 mm-security-handle 'gnus-info "Failed"))) | |
543 | |
544 (defun mml2015-gpg-sign (cont) | |
545 (let ((boundary (mml-compute-boundary cont)) | |
546 (text (current-buffer)) signature) | |
547 (goto-char (point-max)) | |
548 (unless (bolp) | |
549 (insert "\n")) | |
550 (with-temp-buffer | |
551 (unless (gpg-sign-detached text (setq signature (current-buffer)) | |
552 mml2015-result-buffer | |
553 nil | |
554 (message-options-get 'message-sender) | |
555 t t) ; armor & textmode | |
556 (unless (> (point-max) (point-min)) | |
557 (pop-to-buffer mml2015-result-buffer) | |
558 (error "Sign error"))) | |
559 (goto-char (point-min)) | |
560 (while (re-search-forward "\r+$" nil t) | |
561 (replace-match "" t t)) | |
562 (set-buffer text) | |
563 (goto-char (point-min)) | |
564 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" | |
565 boundary)) | |
566 ;;; FIXME: what is the micalg? | |
567 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n") | |
568 (insert (format "\n--%s\n" boundary)) | |
569 (goto-char (point-max)) | |
570 (insert (format "\n--%s\n" boundary)) | |
571 (insert "Content-Type: application/pgp-signature\n\n") | |
572 (insert-buffer-substring signature) | |
573 (goto-char (point-max)) | |
574 (insert (format "--%s--\n" boundary)) | |
575 (goto-char (point-max))))) | |
576 | |
577 (defun mml2015-gpg-encrypt (cont &optional sign) | |
578 (let ((boundary (mml-compute-boundary cont)) | |
579 (text (current-buffer)) | |
580 cipher) | |
581 (mm-with-unibyte-current-buffer | |
582 (with-temp-buffer | |
583 ;; set up a function to call the correct gpg encrypt routine | |
584 ;; with the right arguments. (FIXME: this should be done | |
585 ;; differently.) | |
586 (flet ((gpg-encrypt-func | |
587 (sign plaintext ciphertext result recipients &optional | |
588 passphrase sign-with-key armor textmode) | |
589 (if sign | |
590 (gpg-sign-encrypt | |
591 plaintext ciphertext result recipients passphrase | |
592 sign-with-key armor textmode) | |
593 (gpg-encrypt | |
594 plaintext ciphertext result recipients passphrase | |
595 armor textmode)))) | |
596 (unless (gpg-encrypt-func | |
597 sign ; passed in when using signencrypt | |
598 text (setq cipher (current-buffer)) | |
599 mml2015-result-buffer | |
600 (split-string | |
601 (or | |
602 (message-options-get 'message-recipients) | |
603 (message-options-set 'message-recipients | |
604 (read-string "Recipients: "))) | |
605 "[ \f\t\n\r\v,]+") | |
606 nil | |
607 (message-options-get 'message-sender) | |
608 t t) ; armor & textmode | |
609 (unless (> (point-max) (point-min)) | |
610 (pop-to-buffer mml2015-result-buffer) | |
611 (error "Encrypt error")))) | |
612 (goto-char (point-min)) | |
613 (while (re-search-forward "\r+$" nil t) | |
614 (replace-match "" t t)) | |
615 (set-buffer text) | |
616 (delete-region (point-min) (point-max)) | |
617 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" | |
618 boundary)) | |
619 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") | |
620 (insert (format "--%s\n" boundary)) | |
621 (insert "Content-Type: application/pgp-encrypted\n\n") | |
622 (insert "Version: 1\n\n") | |
623 (insert (format "--%s\n" boundary)) | |
624 (insert "Content-Type: application/octet-stream\n\n") | |
625 (insert-buffer-substring cipher) | |
626 (goto-char (point-max)) | |
627 (insert (format "--%s--\n" boundary)) | |
628 (goto-char (point-max)))))) | |
629 | |
630 ;;; pgg wrapper | |
631 | |
632 (eval-when-compile | |
633 (defvar pgg-errors-buffer) | |
634 (defvar pgg-output-buffer)) | |
635 | |
636 (eval-and-compile | |
637 (autoload 'pgg-decrypt-region "pgg") | |
638 (autoload 'pgg-verify-region "pgg") | |
639 (autoload 'pgg-sign-region "pgg") | |
640 (autoload 'pgg-encrypt-region "pgg")) | |
641 | |
642 (defun mml2015-pgg-decrypt (handle ctl) | |
643 (catch 'error | |
644 (let ((pgg-errors-buffer mml2015-result-buffer) | |
645 child handles result decrypt-status) | |
646 (unless (setq child (mm-find-part-by-type | |
647 (cdr handle) | |
648 "application/octet-stream" nil t)) | |
649 (mm-set-handle-multipart-parameter | |
650 mm-security-handle 'gnus-info "Corrupted") | |
651 (throw 'error handle)) | |
652 (with-temp-buffer | |
653 (mm-insert-part child) | |
654 (if (condition-case err | |
655 (prog1 | |
656 (pgg-decrypt-region (point-min) (point-max)) | |
657 (setq decrypt-status | |
658 (with-current-buffer mml2015-result-buffer | |
659 (buffer-string))) | |
660 (mm-set-handle-multipart-parameter | |
661 mm-security-handle 'gnus-details | |
662 decrypt-status)) | |
663 (error | |
664 (mm-set-handle-multipart-parameter | |
665 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
666 nil) | |
667 (quit | |
668 (mm-set-handle-multipart-parameter | |
669 mm-security-handle 'gnus-details "Quit.") | |
670 nil)) | |
671 (with-current-buffer pgg-output-buffer | |
672 (goto-char (point-min)) | |
673 (while (search-forward "\r\n" nil t) | |
674 (replace-match "\n" t t)) | |
675 (setq handles (mm-dissect-buffer t)) | |
676 (mm-destroy-parts handle) | |
677 (mm-set-handle-multipart-parameter | |
678 mm-security-handle 'gnus-info "OK") | |
679 (mm-set-handle-multipart-parameter | |
680 mm-security-handle 'gnus-details | |
681 (concat decrypt-status | |
682 (when (stringp (car handles)) | |
683 "\n" (mm-handle-multipart-ctl-parameter | |
684 handles 'gnus-details)))) | |
685 (if (listp (car handles)) | |
686 handles | |
687 (list handles))) | |
688 (mm-set-handle-multipart-parameter | |
689 mm-security-handle 'gnus-info "Failed") | |
690 (throw 'error handle)))))) | |
691 | |
692 (defun mml2015-pgg-clear-decrypt () | |
693 (let ((pgg-errors-buffer mml2015-result-buffer)) | |
694 (if (prog1 | |
695 (pgg-decrypt-region (point-min) (point-max)) | |
696 (mm-set-handle-multipart-parameter | |
697 mm-security-handle 'gnus-details | |
698 (with-current-buffer mml2015-result-buffer | |
699 (buffer-string)))) | |
700 (progn | |
701 (erase-buffer) | |
702 (insert-buffer-substring pgg-output-buffer) | |
703 (goto-char (point-min)) | |
704 (while (search-forward "\r\n" nil t) | |
705 (replace-match "\n" t t)) | |
706 (mm-set-handle-multipart-parameter | |
707 mm-security-handle 'gnus-info "OK")) | |
708 (mm-set-handle-multipart-parameter | |
709 mm-security-handle 'gnus-info "Failed")))) | |
710 | |
711 (defun mml2015-pgg-verify (handle ctl) | |
712 (let ((pgg-errors-buffer mml2015-result-buffer) | |
713 signature-file part signature) | |
714 (if (or (null (setq part (mm-find-raw-part-by-type | |
715 ctl (or (mm-handle-multipart-ctl-parameter | |
716 ctl 'protocol) | |
717 "application/pgp-signature") | |
718 t))) | |
719 (null (setq signature (mm-find-part-by-type | |
720 (cdr handle) "application/pgp-signature" nil t)))) | |
721 (progn | |
722 (mm-set-handle-multipart-parameter | |
723 mm-security-handle 'gnus-info "Corrupted") | |
724 handle) | |
725 (with-temp-buffer | |
726 (insert part) | |
727 ;; Convert <LF> to <CR><LF> in verify mode. Sign and | |
728 ;; clearsign use --textmode. The conversion is not necessary. | |
729 ;; In clearverify, the conversion is not necessary either. | |
730 (goto-char (point-min)) | |
731 (end-of-line) | |
732 (while (not (eobp)) | |
733 (unless (eq (char-before) ?\r) | |
734 (insert "\r")) | |
735 (forward-line) | |
736 (end-of-line)) | |
737 (with-temp-file (setq signature-file (mm-make-temp-file "pgg")) | |
738 (mm-insert-part signature)) | |
739 (if (condition-case err | |
740 (prog1 | |
741 (pgg-verify-region (point-min) (point-max) | |
742 signature-file t) | |
743 (goto-char (point-min)) | |
744 (while (search-forward "\r\n" nil t) | |
745 (replace-match "\n" t t)) | |
746 (mm-set-handle-multipart-parameter | |
747 mm-security-handle 'gnus-details | |
748 (concat (with-current-buffer pgg-output-buffer | |
749 (buffer-string)) | |
750 (with-current-buffer pgg-errors-buffer | |
751 (buffer-string))))) | |
752 (error | |
753 (mm-set-handle-multipart-parameter | |
754 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
755 nil) | |
756 (quit | |
757 (mm-set-handle-multipart-parameter | |
758 mm-security-handle 'gnus-details "Quit.") | |
759 nil)) | |
760 (progn | |
761 (delete-file signature-file) | |
762 (mm-set-handle-multipart-parameter | |
763 mm-security-handle 'gnus-info | |
764 (with-current-buffer pgg-errors-buffer | |
765 (mml2015-gpg-extract-signature-details)))) | |
766 (delete-file signature-file) | |
767 (mm-set-handle-multipart-parameter | |
768 mm-security-handle 'gnus-info "Failed"))))) | |
769 handle) | |
770 | |
771 (defun mml2015-pgg-clear-verify () | |
772 (let ((pgg-errors-buffer mml2015-result-buffer) | |
773 (text (buffer-string)) | |
774 (coding-system buffer-file-coding-system)) | |
775 (if (condition-case err | |
776 (prog1 | |
777 (mm-with-unibyte-buffer | |
778 (insert (encode-coding-string text coding-system)) | |
779 (pgg-verify-region (point-min) (point-max) nil t)) | |
780 (goto-char (point-min)) | |
781 (while (search-forward "\r\n" nil t) | |
782 (replace-match "\n" t t)) | |
783 (mm-set-handle-multipart-parameter | |
784 mm-security-handle 'gnus-details | |
785 (concat (with-current-buffer pgg-output-buffer | |
786 (buffer-string)) | |
787 (with-current-buffer pgg-errors-buffer | |
788 (buffer-string))))) | |
789 (error | |
790 (mm-set-handle-multipart-parameter | |
791 mm-security-handle 'gnus-details (mml2015-format-error err)) | |
792 nil) | |
793 (quit | |
794 (mm-set-handle-multipart-parameter | |
795 mm-security-handle 'gnus-details "Quit.") | |
796 nil)) | |
797 (mm-set-handle-multipart-parameter | |
798 mm-security-handle 'gnus-info | |
799 (with-current-buffer pgg-errors-buffer | |
800 (mml2015-gpg-extract-signature-details))) | |
801 (mm-set-handle-multipart-parameter | |
802 mm-security-handle 'gnus-info "Failed")))) | |
803 | |
804 (defun mml2015-pgg-sign (cont) | |
805 (let ((pgg-errors-buffer mml2015-result-buffer) | |
806 (boundary (mml-compute-boundary cont)) | |
807 (pgg-default-user-id (or (message-options-get 'mml-sender) | |
808 pgg-default-user-id))) | |
809 (unless (pgg-sign-region (point-min) (point-max)) | |
810 (pop-to-buffer mml2015-result-buffer) | |
811 (error "Sign error")) | |
812 (goto-char (point-min)) | |
813 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" | |
814 boundary)) | |
815 ;;; FIXME: what is the micalg? | |
816 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n") | |
817 (insert (format "\n--%s\n" boundary)) | |
818 (goto-char (point-max)) | |
819 (insert (format "\n--%s\n" boundary)) | |
820 (insert "Content-Type: application/pgp-signature\n\n") | |
821 (insert-buffer-substring pgg-output-buffer) | |
822 (goto-char (point-max)) | |
823 (insert (format "--%s--\n" boundary)) | |
824 (goto-char (point-max)))) | |
825 | |
826 (defun mml2015-pgg-encrypt (cont &optional sign) | |
827 (let ((pgg-errors-buffer mml2015-result-buffer) | |
828 (boundary (mml-compute-boundary cont))) | |
829 (unless (pgg-encrypt-region (point-min) (point-max) | |
830 (split-string | |
831 (or | |
832 (message-options-get 'message-recipients) | |
833 (message-options-set 'message-recipients | |
834 (read-string "Recipients: "))) | |
835 "[ \f\t\n\r\v,]+") | |
836 sign) | |
837 (pop-to-buffer mml2015-result-buffer) | |
838 (error "Encrypt error")) | |
839 (delete-region (point-min) (point-max)) | |
840 (goto-char (point-min)) | |
841 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" | |
842 boundary)) | |
843 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") | |
844 (insert (format "--%s\n" boundary)) | |
845 (insert "Content-Type: application/pgp-encrypted\n\n") | |
846 (insert "Version: 1\n\n") | |
847 (insert (format "--%s\n" boundary)) | |
848 (insert "Content-Type: application/octet-stream\n\n") | |
849 (insert-buffer-substring pgg-output-buffer) | |
850 (goto-char (point-max)) | |
851 (insert (format "--%s--\n" boundary)) | |
852 (goto-char (point-max)))) | |
853 | |
854 ;;; General wrapper | |
855 | |
856 (defun mml2015-clean-buffer () | |
857 (if (gnus-buffer-live-p mml2015-result-buffer) | |
858 (with-current-buffer mml2015-result-buffer | |
859 (erase-buffer) | |
860 t) | |
861 (setq mml2015-result-buffer | |
862 (gnus-get-buffer-create "*MML2015 Result*")) | |
863 nil)) | |
864 | |
865 (defsubst mml2015-clear-decrypt-function () | |
866 (nth 6 (assq mml2015-use mml2015-function-alist))) | |
867 | |
868 (defsubst mml2015-clear-verify-function () | |
869 (nth 5 (assq mml2015-use mml2015-function-alist))) | |
870 | |
871 ;;;###autoload | |
872 (defun mml2015-decrypt (handle ctl) | |
873 (mml2015-clean-buffer) | |
874 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist)))) | |
875 (if func | |
876 (funcall func handle ctl) | |
877 handle))) | |
878 | |
879 ;;;###autoload | |
880 (defun mml2015-decrypt-test (handle ctl) | |
881 mml2015-use) | |
882 | |
883 ;;;###autoload | |
884 (defun mml2015-verify (handle ctl) | |
885 (mml2015-clean-buffer) | |
886 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist)))) | |
887 (if func | |
888 (funcall func handle ctl) | |
889 handle))) | |
890 | |
891 ;;;###autoload | |
892 (defun mml2015-verify-test (handle ctl) | |
893 mml2015-use) | |
894 | |
895 ;;;###autoload | |
896 (defun mml2015-encrypt (cont &optional sign) | |
897 (mml2015-clean-buffer) | |
898 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist)))) | |
899 (if func | |
900 (funcall func cont sign) | |
901 (error "Cannot find encrypt function")))) | |
902 | |
903 ;;;###autoload | |
904 (defun mml2015-sign (cont) | |
905 (mml2015-clean-buffer) | |
906 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist)))) | |
907 (if func | |
908 (funcall func cont) | |
909 (error "Cannot find sign function")))) | |
910 | |
911 ;;;###autoload | |
912 (defun mml2015-self-encrypt () | |
913 (mml2015-encrypt nil)) | |
914 | |
915 (provide 'mml2015) | |
916 | |
917 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2 | |
918 ;;; mml2015.el ends here |