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