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