1;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
2
3;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
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
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
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
38(defvar mc-pgp-always-sign)
39
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."
90  :version "22.1"
91  :group 'mime-security
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.)
592	(flet ((gpg-encrypt-func
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
639  (defvar pgg-default-user-id)
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")
647  (autoload 'pgg-encrypt-region "pgg")
648  (autoload 'pgg-parse-armor "pgg-parse"))
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))
665		  (setq decrypt-status
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	  ;; Treat data which pgg returns as a unibyte string.
711	  (mm-disable-multibyte)
712	  (insert-buffer-substring pgg-output-buffer)
713	  (goto-char (point-min))
714	  (while (search-forward "\r\n" nil t)
715	    (replace-match "\n" t t))
716	  (mm-set-handle-multipart-parameter
717	   mm-security-handle 'gnus-info "OK"))
718      (mm-set-handle-multipart-parameter
719       mm-security-handle 'gnus-info "Failed"))))
720
721(defun mml2015-pgg-verify (handle ctl)
722  (let ((pgg-errors-buffer mml2015-result-buffer)
723	signature-file part signature)
724    (if (or (null (setq part (mm-find-raw-part-by-type
725			      ctl (or (mm-handle-multipart-ctl-parameter
726				       ctl 'protocol)
727				      "application/pgp-signature")
728			      t)))
729	    (null (setq signature (mm-find-part-by-type
730				   (cdr handle) "application/pgp-signature" nil t))))
731	(progn
732	  (mm-set-handle-multipart-parameter
733	   mm-security-handle 'gnus-info "Corrupted")
734	  handle)
735      (with-temp-buffer
736	(insert part)
737	;; Convert <LF> to <CR><LF> in verify mode.  Sign and
738	;; clearsign use --textmode. The conversion is not necessary.
739	;; In clearverify, the conversion is not necessary either.
740	(goto-char (point-min))
741	(end-of-line)
742	(while (not (eobp))
743	  (unless (eq (char-before) ?\r)
744	    (insert "\r"))
745	  (forward-line)
746	  (end-of-line))
747	(with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
748	  (mm-insert-part signature))
749	(if (condition-case err
750		(prog1
751		    (pgg-verify-region (point-min) (point-max)
752				       signature-file t)
753		  (goto-char (point-min))
754		  (while (search-forward "\r\n" nil t)
755		    (replace-match "\n" t t))
756		  (mm-set-handle-multipart-parameter
757		   mm-security-handle 'gnus-details
758		   (concat (with-current-buffer pgg-output-buffer
759			     (buffer-string))
760			   (with-current-buffer pgg-errors-buffer
761			     (buffer-string)))))
762	      (error
763	       (mm-set-handle-multipart-parameter
764		mm-security-handle 'gnus-details (mml2015-format-error err))
765	       nil)
766	      (quit
767	       (mm-set-handle-multipart-parameter
768		mm-security-handle 'gnus-details "Quit.")
769	       nil))
770	    (progn
771	      (delete-file signature-file)
772	      (mm-set-handle-multipart-parameter
773	       mm-security-handle 'gnus-info
774	       (with-current-buffer pgg-errors-buffer
775		 (mml2015-gpg-extract-signature-details))))
776	  (delete-file signature-file)
777	  (mm-set-handle-multipart-parameter
778	   mm-security-handle 'gnus-info "Failed")))))
779  handle)
780
781(defun mml2015-pgg-clear-verify ()
782  (let ((pgg-errors-buffer mml2015-result-buffer)
783	(text (buffer-string))
784	(coding-system buffer-file-coding-system))
785    (if (condition-case err
786	    (prog1
787		(mm-with-unibyte-buffer
788		  (insert (mm-encode-coding-string text coding-system))
789		  (pgg-verify-region (point-min) (point-max) nil t))
790	      (goto-char (point-min))
791	      (while (search-forward "\r\n" nil t)
792		(replace-match "\n" t t))
793	      (mm-set-handle-multipart-parameter
794	       mm-security-handle 'gnus-details
795	       (concat (with-current-buffer pgg-output-buffer
796			 (buffer-string))
797		       (with-current-buffer pgg-errors-buffer
798			 (buffer-string)))))
799	  (error
800	   (mm-set-handle-multipart-parameter
801	    mm-security-handle 'gnus-details (mml2015-format-error err))
802	   nil)
803	  (quit
804	   (mm-set-handle-multipart-parameter
805	    mm-security-handle 'gnus-details "Quit.")
806	   nil))
807	(mm-set-handle-multipart-parameter
808	 mm-security-handle 'gnus-info
809	 (with-current-buffer pgg-errors-buffer
810	   (mml2015-gpg-extract-signature-details)))
811      (mm-set-handle-multipart-parameter
812       mm-security-handle 'gnus-info "Failed"))))
813
814(defun mml2015-pgg-sign (cont)
815  (let ((pgg-errors-buffer mml2015-result-buffer)
816	(boundary (mml-compute-boundary cont))
817	(pgg-default-user-id (or (message-options-get 'mml-sender)
818				 pgg-default-user-id))
819	(pgg-text-mode t)
820	entry)
821    (unless (pgg-sign-region (point-min) (point-max))
822      (pop-to-buffer mml2015-result-buffer)
823      (error "Sign error"))
824    (goto-char (point-min))
825    (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
826		    boundary))
827    (if (setq entry (assq 2 (pgg-parse-armor
828			     (with-current-buffer pgg-output-buffer
829			       (buffer-string)))))
830	(setq entry (assq 'hash-algorithm (cdr entry))))
831    (insert (format "\tmicalg=%s; "
832		    (if (cdr entry)
833			(downcase (format "pgp-%s" (cdr entry)))
834		      "pgp-sha1")))
835    (insert "protocol=\"application/pgp-signature\"\n")
836    (insert (format "\n--%s\n" boundary))
837    (goto-char (point-max))
838    (insert (format "\n--%s\n" boundary))
839    (insert "Content-Type: application/pgp-signature\n\n")
840    (insert-buffer-substring pgg-output-buffer)
841    (goto-char (point-max))
842    (insert (format "--%s--\n" boundary))
843    (goto-char (point-max))))
844
845(defun mml2015-pgg-encrypt (cont &optional sign)
846  (let ((pgg-errors-buffer mml2015-result-buffer)
847	(pgg-text-mode t)
848	(boundary (mml-compute-boundary cont)))
849    (unless (pgg-encrypt-region (point-min) (point-max)
850				(split-string
851				 (or
852				  (message-options-get 'message-recipients)
853				  (message-options-set 'message-recipients
854						       (read-string "Recipients: ")))
855				 "[ \f\t\n\r\v,]+")
856				sign)
857      (pop-to-buffer mml2015-result-buffer)
858      (error "Encrypt error"))
859    (delete-region (point-min) (point-max))
860    (goto-char (point-min))
861    (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
862		    boundary))
863    (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
864    (insert (format "--%s\n" boundary))
865    (insert "Content-Type: application/pgp-encrypted\n\n")
866    (insert "Version: 1\n\n")
867    (insert (format "--%s\n" boundary))
868    (insert "Content-Type: application/octet-stream\n\n")
869    (insert-buffer-substring pgg-output-buffer)
870    (goto-char (point-max))
871    (insert (format "--%s--\n" boundary))
872    (goto-char (point-max))))
873
874;;; General wrapper
875
876(defun mml2015-clean-buffer ()
877  (if (gnus-buffer-live-p mml2015-result-buffer)
878      (with-current-buffer mml2015-result-buffer
879	(erase-buffer)
880	t)
881    (setq mml2015-result-buffer
882	  (gnus-get-buffer-create "*MML2015 Result*"))
883    nil))
884
885(defsubst mml2015-clear-decrypt-function ()
886  (nth 6 (assq mml2015-use mml2015-function-alist)))
887
888(defsubst mml2015-clear-verify-function ()
889  (nth 5 (assq mml2015-use mml2015-function-alist)))
890
891;;;###autoload
892(defun mml2015-decrypt (handle ctl)
893  (mml2015-clean-buffer)
894  (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
895    (if func
896	(funcall func handle ctl)
897      handle)))
898
899;;;###autoload
900(defun mml2015-decrypt-test (handle ctl)
901  mml2015-use)
902
903;;;###autoload
904(defun mml2015-verify (handle ctl)
905  (mml2015-clean-buffer)
906  (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
907    (if func
908	(funcall func handle ctl)
909      handle)))
910
911;;;###autoload
912(defun mml2015-verify-test (handle ctl)
913  mml2015-use)
914
915;;;###autoload
916(defun mml2015-encrypt (cont &optional sign)
917  (mml2015-clean-buffer)
918  (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
919    (if func
920	(funcall func cont sign)
921      (error "Cannot find encrypt function"))))
922
923;;;###autoload
924(defun mml2015-sign (cont)
925  (mml2015-clean-buffer)
926  (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
927    (if func
928	(funcall func cont)
929      (error "Cannot find sign function"))))
930
931;;;###autoload
932(defun mml2015-self-encrypt ()
933  (mml2015-encrypt nil))
934
935(provide 'mml2015)
936
937;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
938;;; mml2015.el ends here
939