2001-05-27 Simon Josefsson <simon@josefsson.org>
[gnus] / lisp / mml2015.el
1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
2 ;; Copyright (C) 2000, 2001 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 ;;; Code:
27
28 (eval-when-compile (require 'cl))
29 (require 'mm-decode)
30
31 (defvar mml2015-use (or
32                      (progn
33                        (ignore-errors
34                          (require 'gpg))
35                        (and (fboundp 'gpg-sign-detached)
36                             'gpg))
37                      (progn (ignore-errors
38                               (load "mc-toplev"))
39                             (and (fboundp 'mc-encrypt-generic)
40                                  (fboundp 'mc-sign-generic)
41                                  (fboundp 'mc-cleanup-recipient-headers)
42                                  'mailcrypt)))
43   "The package used for PGP/MIME.")
44
45 ;; Something is not RFC2015.
46 (defvar mml2015-function-alist
47   '((mailcrypt mml2015-mailcrypt-sign
48                mml2015-mailcrypt-encrypt
49                mml2015-mailcrypt-verify
50                mml2015-mailcrypt-decrypt
51                mml2015-mailcrypt-clear-verify
52                mml2015-mailcrypt-clear-decrypt)
53     (gpg mml2015-gpg-sign
54          mml2015-gpg-encrypt
55          mml2015-gpg-verify
56          mml2015-gpg-decrypt
57          mml2015-gpg-clear-verify
58          mml2015-gpg-clear-decrypt))
59   "Alist of PGP/MIME functions.")
60
61 (defvar mml2015-result-buffer nil)
62
63 ;;; mailcrypt wrapper
64
65 (eval-and-compile
66   (autoload 'mailcrypt-decrypt "mailcrypt")
67   (autoload 'mailcrypt-verify "mailcrypt")
68   (autoload 'mc-pgp-always-sign "mailcrypt")
69   (autoload 'mc-encrypt-generic "mc-toplev")
70   (autoload 'mc-cleanup-recipient-headers "mc-toplev")
71   (autoload 'mc-sign-generic "mc-toplev"))
72
73 (eval-when-compile
74   (defvar mc-default-scheme)
75   (defvar mc-schemes))
76
77 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
78 (defvar mml2015-verify-function 'mailcrypt-verify)
79
80 (defun mml2015-mailcrypt-decrypt (handle ctl)
81   (catch 'error
82     (let (child handles result)
83       (unless (setq child (mm-find-part-by-type
84                            (cdr handle)
85                            "application/octet-stream" nil t))
86         (mm-set-handle-multipart-parameter
87          mm-security-handle 'gnus-info "Corrupted")
88         (throw 'error handle))
89       (with-temp-buffer
90         (mm-insert-part child)
91         (setq result
92               (condition-case err
93                   (funcall mml2015-decrypt-function)
94                 (error
95                  (mm-set-handle-multipart-parameter
96                   mm-security-handle 'gnus-details (cadr err))
97                  nil)
98                 (quit
99                  (mm-set-handle-multipart-parameter
100                   mm-security-handle 'gnus-details "Quit.")
101                  nil)))
102         (unless (car result)
103           (mm-set-handle-multipart-parameter
104            mm-security-handle 'gnus-info "Failed")
105           (throw 'error handle))
106         (setq handles (mm-dissect-buffer t)))
107       (mm-destroy-parts handle)
108       (mm-set-handle-multipart-parameter
109        mm-security-handle 'gnus-info "OK")
110       (if (listp (car handles))
111           handles
112         (list handles)))))
113
114 (defun mml2015-mailcrypt-clear-decrypt ()
115   (let (result)
116     (setq result
117           (condition-case err
118               (funcall mml2015-decrypt-function)
119             (error
120              (mm-set-handle-multipart-parameter
121               mm-security-handle 'gnus-details (cadr err))
122              nil)
123             (quit
124              (mm-set-handle-multipart-parameter
125               mm-security-handle 'gnus-details "Quit.")
126              nil)))
127     (if (car result)
128         (mm-set-handle-multipart-parameter
129          mm-security-handle 'gnus-info "OK")
130       (mm-set-handle-multipart-parameter
131        mm-security-handle 'gnus-info "Failed"))))
132
133 (defun mml2015-fix-micalg (alg)
134   (and alg
135        (upcase (if (string-match "^pgp-" alg)
136                    (substring alg (match-end 0))
137                  alg))))
138
139 (defun mml2015-mailcrypt-verify (handle ctl)
140   (catch 'error
141     (let (part)
142       (unless (setq part (mm-find-raw-part-by-type
143                           ctl (or (mm-handle-multipart-ctl-parameter
144                                    ctl 'protocol)
145                                   "application/pgp-signature")
146                           t))
147         (mm-set-handle-multipart-parameter
148          mm-security-handle 'gnus-info "Corrupted")
149         (throw 'error handle))
150       (with-temp-buffer
151         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
152         (insert (format "Hash: %s\n\n"
153                         (or (mml2015-fix-micalg
154                              (mm-handle-multipart-ctl-parameter
155                               ctl 'micalg))
156                             "SHA1")))
157         (save-restriction
158           (narrow-to-region (point) (point))
159           (insert part "\n")
160           (goto-char (point-min))
161           (while (not (eobp))
162             (if (looking-at "^-")
163                 (insert "- "))
164             (forward-line)))
165         (unless (setq part (mm-find-part-by-type
166                             (cdr handle) "application/pgp-signature" nil t))
167           (mm-set-handle-multipart-parameter
168            mm-security-handle 'gnus-info "Corrupted")
169           (throw 'error handle))
170         (save-restriction
171           (narrow-to-region (point) (point))
172           (mm-insert-part part)
173           (goto-char (point-min))
174           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
175               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
176           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
177               (replace-match "-----END PGP SIGNATURE-----" t t)))
178         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
179           (unless (condition-case err
180                       (prog1
181                           (funcall mml2015-verify-function)
182                         (if (get-buffer " *mailcrypt stderr temp")
183                             (mm-set-handle-multipart-parameter
184                              mm-security-handle 'gnus-details
185                              (with-current-buffer " *mailcrypt stderr temp"
186                                (buffer-string))))
187                         (if (get-buffer " *mailcrypt stdout temp")
188                             (kill-buffer " *mailcrypt stdout temp"))
189                         (if (get-buffer " *mailcrypt stderr temp")
190                             (kill-buffer " *mailcrypt stderr temp"))
191                         (if (get-buffer " *mailcrypt status temp")
192                             (kill-buffer " *mailcrypt status temp"))
193                         (if (get-buffer mc-gpg-debug-buffer)
194                             (kill-buffer mc-gpg-debug-buffer)))
195                     (error
196                      (mm-set-handle-multipart-parameter
197                       mm-security-handle 'gnus-details (cadr err))
198                      nil)
199                     (quit
200                      (mm-set-handle-multipart-parameter
201                       mm-security-handle 'gnus-details "Quit.")
202                      nil))
203             (mm-set-handle-multipart-parameter
204              mm-security-handle 'gnus-info "Failed")
205             (throw 'error handle))))
206       (mm-set-handle-multipart-parameter
207        mm-security-handle 'gnus-info "OK")
208       handle)))
209
210 (defun mml2015-mailcrypt-clear-verify ()
211   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
212     (if (condition-case err
213             (prog1
214                 (funcall mml2015-verify-function)
215               (if (get-buffer " *mailcrypt stderr temp")
216                   (mm-set-handle-multipart-parameter
217                    mm-security-handle 'gnus-details
218                    (with-current-buffer " *mailcrypt stderr temp"
219                      (buffer-string))))
220               (if (get-buffer " *mailcrypt stdout temp")
221                   (kill-buffer " *mailcrypt stdout temp"))
222               (if (get-buffer " *mailcrypt stderr temp")
223                   (kill-buffer " *mailcrypt stderr temp"))
224               (if (get-buffer " *mailcrypt status temp")
225                   (kill-buffer " *mailcrypt status temp"))
226               (if (get-buffer mc-gpg-debug-buffer)
227                   (kill-buffer mc-gpg-debug-buffer)))
228           (error
229            (mm-set-handle-multipart-parameter
230             mm-security-handle 'gnus-details (cadr err))
231            nil)
232           (quit
233            (mm-set-handle-multipart-parameter
234             mm-security-handle 'gnus-details "Quit.")
235            nil))
236         (mm-set-handle-multipart-parameter
237          mm-security-handle 'gnus-info "OK")
238       (mm-set-handle-multipart-parameter
239        mm-security-handle 'gnus-info "Failed"))))
240
241 (defun mml2015-mailcrypt-sign (cont)
242   (mc-sign-generic (message-options-get 'message-sender)
243                    nil nil nil nil)
244   (let ((boundary
245          (funcall mml-boundary-function (incf mml-multipart-number)))
246         hash point)
247     (goto-char (point-min))
248     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
249       (error "Cannot find signed begin line." ))
250     (goto-char (match-beginning 0))
251     (forward-line 1)
252     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
253       (error "Cannot not find PGP hash." ))
254     (setq hash (match-string 1))
255     (unless (re-search-forward "^$" nil t)
256       (error "Cannot not find PGP message." ))
257     (forward-line 1)
258     (delete-region (point-min) (point))
259     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
260                     boundary))
261     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
262                     (downcase hash)))
263     (insert (format "\n--%s\n" boundary))
264     (setq point (point))
265     (goto-char (point-max))
266     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
267       (error "Cannot find signature part." ))
268     (replace-match "-----END PGP MESSAGE-----" t t)
269     (goto-char (match-beginning 0))
270     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
271                                 nil t)
272       (error "Cannot find signature part." ))
273     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
274     (goto-char (match-beginning 0))
275     (save-restriction
276       (narrow-to-region point (point))
277       (goto-char point)
278       (while (re-search-forward "^- -" nil t)
279         (replace-match "-" t t))
280       (goto-char (point-max)))
281     (insert (format "--%s\n" boundary))
282     (insert "Content-Type: application/pgp-signature\n\n")
283     (goto-char (point-max))
284     (insert (format "--%s--\n" boundary))
285     (goto-char (point-max))))
286
287 (defun mml2015-mailcrypt-encrypt (cont)
288   (let ((mc-pgp-always-sign
289          (or mc-pgp-always-sign
290              (eq t (or (message-options-get 'message-sign-encrypt)
291                        (message-options-set
292                         'message-sign-encrypt
293                         (or (y-or-n-p "Sign the message? ")
294                             'not))))
295              'never)))
296     (mm-with-unibyte-current-buffer-mule4
297       (mc-encrypt-generic
298        (or (message-options-get 'message-recipients)
299            (message-options-set 'message-recipients
300                               (mc-cleanup-recipient-headers
301                                (read-string "Recipients: "))))
302        nil nil nil
303        (message-options-get 'message-sender))))
304   (goto-char (point-min))
305   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
306     (error "Fail to encrypt the message."))
307   (let ((boundary
308          (funcall mml-boundary-function (incf mml-multipart-number))))
309     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
310                     boundary))
311     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
312     (insert (format "--%s\n" boundary))
313     (insert "Content-Type: application/pgp-encrypted\n\n")
314     (insert "Version: 1\n\n")
315     (insert (format "--%s\n" boundary))
316     (insert "Content-Type: application/octet-stream\n\n")
317     (goto-char (point-max))
318     (insert (format "--%s--\n" boundary))
319     (goto-char (point-max))))
320
321 ;;; gpg wrapper
322
323 (eval-and-compile
324   (autoload 'gpg-decrypt "gpg")
325   (autoload 'gpg-verify "gpg")
326   (autoload 'gpg-verify-cleartext "gpg")
327   (autoload 'gpg-sign-detached "gpg")
328   (autoload 'gpg-sign-encrypt "gpg")
329   (autoload 'gpg-passphrase-read "gpg"))
330
331 (defun mml2015-gpg-passphrase ()
332   (or (message-options-get 'gpg-passphrase)
333       (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
334
335 (defun mml2015-gpg-decrypt-1 ()
336   (let ((cipher (current-buffer)) plain result)
337     (if (with-temp-buffer
338           (prog1
339               (gpg-decrypt cipher (setq plain (current-buffer))
340                            mml2015-result-buffer nil)
341             (mm-set-handle-multipart-parameter
342              mm-security-handle 'gnus-details
343              (with-current-buffer mml2015-result-buffer
344                (buffer-string)))
345             (set-buffer cipher)
346             (erase-buffer)
347             (insert-buffer plain)))
348         '(t)
349       ;; Some wrong with the return value, check plain text buffer.
350       (if (> (point-max) (point-min))
351           '(t)
352         nil))))
353
354 (defun mml2015-gpg-decrypt (handle ctl)
355   (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
356     (mml2015-mailcrypt-decrypt handle ctl)))
357
358 (defun mml2015-gpg-clear-decrypt ()
359   (let (result)
360     (setq result (mml2015-gpg-decrypt-1))
361     (if (car result)
362         (mm-set-handle-multipart-parameter
363          mm-security-handle 'gnus-info "OK")
364       (mm-set-handle-multipart-parameter
365        mm-security-handle 'gnus-info "Failed"))))
366
367 (defun mml2015-gpg-extract-from ()
368   (goto-char (point-min))
369   (if (re-search-forward "^gpg: Good signature from \"\\(.*\\)\"$" nil t)
370       (match-string 1)
371     "From unknown user"))
372
373 (defun mml2015-gpg-verify (handle ctl)
374   (catch 'error
375     (let (part message signature)
376       (unless (setq part (mm-find-raw-part-by-type
377                           ctl (or (mm-handle-multipart-ctl-parameter
378                                    ctl 'protocol)
379                                   "application/pgp-signature")
380                           t))
381         (mm-set-handle-multipart-parameter
382          mm-security-handle 'gnus-info "Corrupted")
383         (throw 'error handle))
384       (with-temp-buffer
385         (setq message (current-buffer))
386         (insert part)
387         (with-temp-buffer
388           (setq signature (current-buffer))
389           (unless (setq part (mm-find-part-by-type
390                               (cdr handle) "application/pgp-signature" nil t))
391             (mm-set-handle-multipart-parameter
392              mm-security-handle 'gnus-info "Corrupted")
393             (throw 'error handle))
394           (mm-insert-part part)
395           (unless (condition-case err
396                       (prog1
397                           (gpg-verify message signature mml2015-result-buffer)
398                         (mm-set-handle-multipart-parameter
399                          mm-security-handle 'gnus-details
400                          (with-current-buffer mml2015-result-buffer
401                            (buffer-string))))
402                     (error
403                      (mm-set-handle-multipart-parameter
404                       mm-security-handle 'gnus-details (cadr err))
405                      nil)
406                     (quit
407                      (mm-set-handle-multipart-parameter
408                       mm-security-handle 'gnus-details "Quit.")
409                      nil))
410             (mm-set-handle-multipart-parameter
411              mm-security-handle 'gnus-info "Failed")
412             (throw 'error handle)))
413         (mm-set-handle-multipart-parameter
414          mm-security-handle 'gnus-info 
415          (with-current-buffer mml2015-result-buffer 
416            (mml2015-gpg-extract-from))))
417       handle)))
418
419 (defun mml2015-gpg-clear-verify ()
420   (if (condition-case err
421           (prog1
422               (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
423             (mm-set-handle-multipart-parameter
424              mm-security-handle 'gnus-details
425              (with-current-buffer mml2015-result-buffer
426                (buffer-string))))
427         (error
428          (mm-set-handle-multipart-parameter
429           mm-security-handle 'gnus-details (cadr err))
430          nil)
431         (quit
432          (mm-set-handle-multipart-parameter
433           mm-security-handle 'gnus-details "Quit.")
434          nil))
435       (mm-set-handle-multipart-parameter
436        mm-security-handle 'gnus-info 
437        (with-current-buffer mml2015-result-buffer 
438          (mml2015-gpg-extract-from)))
439     (mm-set-handle-multipart-parameter
440      mm-security-handle 'gnus-info "Failed")))
441
442 (defun mml2015-gpg-sign (cont)
443   (let ((boundary
444          (funcall mml-boundary-function (incf mml-multipart-number)))
445         (text (current-buffer)) signature)
446     (goto-char (point-max))
447     (unless (bolp)
448       (insert "\n"))
449     (with-temp-buffer
450       (unless (gpg-sign-detached text (setq signature (current-buffer))
451                                  mml2015-result-buffer
452                                  nil
453                                  (message-options-get 'message-sender)
454                                  t t) ; armor & textmode
455         (unless (> (point-max) (point-min))
456           (pop-to-buffer mml2015-result-buffer)
457           (error "Sign error.")))
458       (goto-char (point-min))
459       (while (re-search-forward "\r+$" nil t)
460         (replace-match "" t t))
461       (set-buffer text)
462       (goto-char (point-min))
463       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
464                       boundary))
465       ;;; FIXME: what is the micalg?
466       (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
467       (insert (format "\n--%s\n" boundary))
468       (goto-char (point-max))
469       (insert (format "\n--%s\n" boundary))
470       (insert "Content-Type: application/pgp-signature\n\n")
471       (insert-buffer signature)
472       (goto-char (point-max))
473       (insert (format "--%s--\n" boundary))
474       (goto-char (point-max)))))
475
476 (defun mml2015-gpg-encrypt (cont)
477   (let ((boundary
478          (funcall mml-boundary-function (incf mml-multipart-number)))
479         (text (current-buffer))
480         cipher)
481     (mm-with-unibyte-current-buffer-mule4
482       (with-temp-buffer
483         (unless (gpg-sign-encrypt
484                  text (setq cipher (current-buffer))
485                  mml2015-result-buffer
486                  (split-string
487                   (or
488                    (message-options-get 'message-recipients)
489                    (message-options-set 'message-recipients
490                                         (read-string "Recipients: ")))
491                   "[ \f\t\n\r\v,]+")
492                  nil
493                  (message-options-get 'message-sender)
494                  t t) ; armor & textmode
495           (unless (> (point-max) (point-min))
496             (pop-to-buffer mml2015-result-buffer)
497             (error "Encrypt error.")))
498         (goto-char (point-min))
499         (while (re-search-forward "\r+$" nil t)
500           (replace-match "" t t))
501         (set-buffer text)
502         (delete-region (point-min) (point-max))
503         (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
504                         boundary))
505         (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
506         (insert (format "--%s\n" boundary))
507         (insert "Content-Type: application/pgp-encrypted\n\n")
508         (insert "Version: 1\n\n")
509         (insert (format "--%s\n" boundary))
510         (insert "Content-Type: application/octet-stream\n\n")
511         (insert-buffer cipher)
512         (goto-char (point-max))
513         (insert (format "--%s--\n" boundary))
514         (goto-char (point-max))))))
515
516 ;;; General wrapper
517
518 (defun mml2015-clean-buffer ()
519   (if (gnus-buffer-live-p mml2015-result-buffer)
520       (with-current-buffer mml2015-result-buffer
521         (erase-buffer)
522         t)
523     (setq mml2015-result-buffer
524           (gnus-get-buffer-create "*MML2015 Result*"))
525     nil))
526
527 (defsubst mml2015-clear-decrypt-function ()
528   (nth 6 (assq mml2015-use mml2015-function-alist)))
529
530 (defsubst mml2015-clear-verify-function ()
531   (nth 5 (assq mml2015-use mml2015-function-alist)))
532
533 ;;;###autoload
534 (defun mml2015-decrypt (handle ctl)
535   (mml2015-clean-buffer)
536   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
537     (if func
538         (funcall func handle ctl)
539       handle)))
540
541 ;;;###autoload
542 (defun mml2015-decrypt-test (handle ctl)
543   mml2015-use)
544
545 ;;;###autoload
546 (defun mml2015-verify (handle ctl)
547   (mml2015-clean-buffer)
548   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
549     (if func
550         (funcall func handle ctl)
551       handle)))
552
553 ;;;###autoload
554 (defun mml2015-verify-test (handle ctl)
555   mml2015-use)
556
557 ;;;###autoload
558 (defun mml2015-encrypt (cont)
559   (mml2015-clean-buffer)
560   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
561     (if func
562         (funcall func cont)
563       (error "Cannot find encrypt function."))))
564
565 ;;;###autoload
566 (defun mml2015-sign (cont)
567   (mml2015-clean-buffer)
568   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
569     (if func
570         (funcall func cont)
571       (error "Cannot find sign function."))))
572
573 ;;;###autoload
574 (defun mml2015-self-encrypt ()
575   (mml2015-encrypt nil))
576
577 (provide 'mml2015)
578
579 ;;; mml2015.el ends here