be9981676e6572f8908fb4af59d9b317ee7c6b1f
[gnus] / lisp / mml1991.el
1 ;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
2
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6 ;; Author: Sascha Ldecke <sascha@meta-x.de>,
7 ;;      Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
8 ;; Keywords PGP
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 3, or (at your option)
15 ;; any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
26
27 ;;; Commentary:
28
29 ;;; Code:
30
31 (eval-when-compile
32   (require 'cl)
33   (require 'mm-util))
34
35 (require 'mml-sec)
36
37 (defvar mc-pgp-always-sign)
38
39 (autoload 'quoted-printable-decode-region "qp")
40 (autoload 'quoted-printable-encode-region "qp")
41
42 (defvar mml1991-use mml2015-use
43   "The package used for PGP.")
44
45 (defvar mml1991-function-alist
46   '((mailcrypt mml1991-mailcrypt-sign
47                mml1991-mailcrypt-encrypt)
48     (gpg mml1991-gpg-sign
49          mml1991-gpg-encrypt)
50     (pgg mml1991-pgg-sign
51          mml1991-pgg-encrypt)
52     (epg mml1991-epg-sign
53          mml1991-epg-encrypt))
54   "Alist of PGP functions.")
55
56 (defvar mml1991-verbose mml-secure-verbose
57   "If non-nil, ask the user about the current operation more verbosely.")
58
59 (defvar mml1991-cache-passphrase mml-secure-cache-passphrase
60   "If t, cache passphrase.")
61
62 (defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
63   "How many seconds the passphrase is cached.
64 Whether the passphrase is cached at all is controlled by
65 `mml1991-cache-passphrase'.")
66
67 (defvar mml1991-signers nil
68   "A list of your own key ID which will be used to sign a message.")
69
70 (defvar mml1991-encrypt-to-self nil
71   "If t, add your own key ID to recipient list when encryption.")
72
73 ;;; mailcrypt wrapper
74
75 (eval-and-compile
76   (autoload 'mc-sign-generic "mc-toplev"))
77
78 (defvar mml1991-decrypt-function 'mailcrypt-decrypt)
79 (defvar mml1991-verify-function 'mailcrypt-verify)
80
81 (defun mml1991-mailcrypt-sign (cont)
82   (let ((text (current-buffer))
83         headers signature
84         (result-buffer (get-buffer-create "*GPG Result*")))
85     ;; Save MIME Content[^ ]+: headers from signing
86     (goto-char (point-min))
87     (while (looking-at "^Content[^ ]+:") (forward-line))
88     (unless (bobp)
89       (setq headers (buffer-string))
90       (delete-region (point-min) (point)))
91     (goto-char (point-max))
92     (unless (bolp)
93       (insert "\n"))
94     (quoted-printable-decode-region (point-min) (point-max))
95     (with-temp-buffer
96       (setq signature (current-buffer))
97       (insert-buffer-substring text)
98       (unless (mc-sign-generic (message-options-get 'message-sender)
99                                nil nil nil nil)
100         (unless (> (point-max) (point-min))
101           (pop-to-buffer result-buffer)
102           (error "Sign error")))
103       (goto-char (point-min))
104       (while (re-search-forward "\r+$" nil t)
105         (replace-match "" t t))
106       (quoted-printable-encode-region (point-min) (point-max))
107       (set-buffer text)
108       (delete-region (point-min) (point-max))
109       (if headers (insert headers))
110       (insert "\n")
111       (insert-buffer-substring signature)
112       (goto-char (point-max)))))
113
114 (defun mml1991-mailcrypt-encrypt (cont &optional sign)
115   (let ((text (current-buffer))
116         (mc-pgp-always-sign
117          (or mc-pgp-always-sign
118              sign
119              (eq t (or (message-options-get 'message-sign-encrypt)
120                        (message-options-set
121                         'message-sign-encrypt
122                         (or (y-or-n-p "Sign the message? ")
123                             'not))))
124              'never))
125         cipher
126         (result-buffer (get-buffer-create "*GPG Result*")))
127     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
128     (goto-char (point-min))
129     (while (looking-at "^Content[^ ]+:") (forward-line))
130     (unless (bobp)
131       (delete-region (point-min) (point)))
132     (mm-with-unibyte-current-buffer
133       (with-temp-buffer
134         (setq cipher (current-buffer))
135         (insert-buffer-substring text)
136         (unless (mc-encrypt-generic
137                  (or
138                   (message-options-get 'message-recipients)
139                   (message-options-set 'message-recipients
140                                        (read-string "Recipients: ")))
141                  nil
142                  (point-min) (point-max)
143                  (message-options-get 'message-sender)
144                  'sign)
145           (unless (> (point-max) (point-min))
146             (pop-to-buffer result-buffer)
147             (error "Encrypt error")))
148         (goto-char (point-min))
149         (while (re-search-forward "\r+$" nil t)
150           (replace-match "" t t))
151         (set-buffer text)
152         (delete-region (point-min) (point-max))
153         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
154         ;;(insert "Version: 1\n\n")
155         (insert "\n")
156         (insert-buffer-substring cipher)
157         (goto-char (point-max))))))
158
159 ;;; gpg wrapper
160
161 (eval-and-compile
162   (autoload 'gpg-sign-cleartext "gpg"))
163
164 (defun mml1991-gpg-sign (cont)
165   (let ((text (current-buffer))
166         headers signature
167         (result-buffer (get-buffer-create "*GPG Result*")))
168     ;; Save MIME Content[^ ]+: headers from signing
169     (goto-char (point-min))
170     (while (looking-at "^Content[^ ]+:") (forward-line))
171     (unless (bobp)
172       (setq headers (buffer-string))
173       (delete-region (point-min) (point)))
174     (goto-char (point-max))
175     (unless (bolp)
176       (insert "\n"))
177     (quoted-printable-decode-region (point-min) (point-max))
178     (with-temp-buffer
179       (unless (gpg-sign-cleartext text (setq signature (current-buffer))
180                                   result-buffer
181                                   nil
182                                   (message-options-get 'message-sender))
183         (unless (> (point-max) (point-min))
184           (pop-to-buffer result-buffer)
185           (error "Sign error")))
186       (goto-char (point-min))
187       (while (re-search-forward "\r+$" nil t)
188         (replace-match "" t t))
189       (quoted-printable-encode-region (point-min) (point-max))
190       (set-buffer text)
191       (delete-region (point-min) (point-max))
192       (if headers (insert headers))
193       (insert "\n")
194       (insert-buffer-substring signature)
195       (goto-char (point-max)))))
196
197 (defun mml1991-gpg-encrypt (cont &optional sign)
198   (let ((text (current-buffer))
199         cipher
200         (result-buffer (get-buffer-create "*GPG Result*")))
201     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
202     (goto-char (point-min))
203     (while (looking-at "^Content[^ ]+:") (forward-line))
204     (unless (bobp)
205       (delete-region (point-min) (point)))
206     (mm-with-unibyte-current-buffer
207       (with-temp-buffer
208         (flet ((gpg-encrypt-func
209                 (sign plaintext ciphertext result recipients &optional
210                       passphrase sign-with-key armor textmode)
211                 (if sign
212                     (gpg-sign-encrypt
213                      plaintext ciphertext result recipients passphrase
214                      sign-with-key armor textmode)
215                   (gpg-encrypt
216                    plaintext ciphertext result recipients passphrase
217                    armor textmode))))
218           (unless (gpg-encrypt-func
219                    sign
220                    text (setq cipher (current-buffer))
221                    result-buffer
222                    (split-string
223                     (or
224                      (message-options-get 'message-recipients)
225                      (message-options-set 'message-recipients
226                                           (read-string "Recipients: ")))
227                     "[ \f\t\n\r\v,]+")
228                    nil
229                    (message-options-get 'message-sender)
230                    t t) ; armor & textmode
231             (unless (> (point-max) (point-min))
232               (pop-to-buffer result-buffer)
233               (error "Encrypt error"))))
234         (goto-char (point-min))
235         (while (re-search-forward "\r+$" nil t)
236           (replace-match "" t t))
237         (set-buffer text)
238         (delete-region (point-min) (point-max))
239         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
240         ;;(insert "Version: 1\n\n")
241         (insert "\n")
242         (insert-buffer-substring cipher)
243         (goto-char (point-max))))))
244
245 ;; pgg wrapper
246
247 (defvar pgg-default-user-id)
248 (defvar pgg-errors-buffer)
249 (defvar pgg-output-buffer)
250
251 (defun mml1991-pgg-sign (cont)
252   (let ((pgg-text-mode t)
253         (pgg-default-user-id (or (message-options-get 'mml-sender)
254                                  pgg-default-user-id))
255         headers cte)
256     ;; Don't sign headers.
257     (goto-char (point-min))
258     (when (re-search-forward "^$" nil t)
259       (setq headers (buffer-substring (point-min) (point)))
260       (save-restriction
261         (narrow-to-region (point-min) (point))
262         (setq cte (mail-fetch-field "content-transfer-encoding")))
263       (forward-line 1)
264       (delete-region (point-min) (point))
265       (when cte
266         (setq cte (intern (downcase cte)))
267         (mm-decode-content-transfer-encoding cte)))
268     (unless (pgg-sign-region (point-min) (point-max) t)
269       (pop-to-buffer pgg-errors-buffer)
270       (error "Encrypt error"))
271     (delete-region (point-min) (point-max))
272     (mm-with-unibyte-current-buffer
273       (insert-buffer-substring pgg-output-buffer)
274       (goto-char (point-min))
275       (while (re-search-forward "\r+$" nil t)
276         (replace-match "" t t))
277       (when cte
278         (mm-encode-content-transfer-encoding cte))
279       (goto-char (point-min))
280       (when headers
281         (insert headers))
282       (insert "\n"))
283     t))
284
285 (defun mml1991-pgg-encrypt (cont &optional sign)
286   (goto-char (point-min))
287   (when (re-search-forward "^$" nil t)
288     (let ((cte (save-restriction
289                  (narrow-to-region (point-min) (point))
290                  (mail-fetch-field "content-transfer-encoding"))))
291       ;; Strip MIME headers since it will be ASCII armoured.
292       (forward-line 1)
293       (delete-region (point-min) (point))
294       (when cte
295         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
296   (unless (let ((pgg-text-mode t))
297             (pgg-encrypt-region
298              (point-min) (point-max)
299              (split-string
300               (or
301                (message-options-get 'message-recipients)
302                (message-options-set 'message-recipients
303                                     (read-string "Recipients: ")))
304               "[ \f\t\n\r\v,]+")
305              sign))
306     (pop-to-buffer pgg-errors-buffer)
307     (error "Encrypt error"))
308   (delete-region (point-min) (point-max))
309   (insert "\n")
310   (insert-buffer-substring pgg-output-buffer)
311   t)
312
313 ;; epg wrapper
314
315 (defvar epg-user-id-alist)
316 (defvar password-cache-expiry)
317
318 (eval-and-compile
319   (autoload 'epg-make-context "epg")
320   (autoload 'epg-passphrase-callback-function "epg")
321   (autoload 'epa-select-keys "epa")
322   (autoload 'epg-list-keys "epg")
323   (autoload 'epg-context-set-armor "epg")
324   (autoload 'epg-context-set-textmode "epg")
325   (autoload 'epg-context-set-signers "epg")
326   (autoload 'epg-context-set-passphrase-callback "epg")
327   (autoload 'epg-sign-string "epg")
328   (autoload 'epg-encrypt-string "epg")
329   (autoload 'epg-configuration "epg-config")
330   (autoload 'epg-expand-group "epg-config"))
331
332 (defvar mml1991-epg-secret-key-id-list nil)
333
334 (defun mml1991-epg-passphrase-callback (context key-id ignore)
335   (if (eq key-id 'SYM)
336       (epg-passphrase-callback-function context key-id nil)
337     (let* ((entry (assoc key-id epg-user-id-alist))
338            (passphrase
339             (password-read
340              (format "GnuPG passphrase for %s: "
341                      (if entry
342                          (cdr entry)
343                        key-id))
344              (if (eq key-id 'PIN)
345                  "PIN"
346                key-id))))
347       (when passphrase
348         (let ((password-cache-expiry mml1991-passphrase-cache-expiry))
349           (password-cache-add key-id passphrase))
350         (setq mml1991-epg-secret-key-id-list
351               (cons key-id mml1991-epg-secret-key-id-list))
352         (copy-sequence passphrase)))))
353
354 (defun mml1991-epg-sign (cont)
355   (let ((context (epg-make-context))
356         headers cte signers signature)
357     (if mml1991-verbose
358         (setq signers (epa-select-keys context "Select keys for signing.
359 If no one is selected, default secret key is used.  "
360                                        mml1991-signers t))
361       (if mml1991-signers
362           (setq signers (mapcar (lambda (name)
363                                   (car (epg-list-keys context name t)))
364                                 mml1991-signers))))
365     (epg-context-set-armor context t)
366     (epg-context-set-textmode context t)
367     (epg-context-set-signers context signers)
368     (if mml1991-cache-passphrase
369         (epg-context-set-passphrase-callback
370          context
371          #'mml1991-epg-passphrase-callback))
372     ;; Don't sign headers.
373     (goto-char (point-min))
374     (when (re-search-forward "^$" nil t)
375       (setq headers (buffer-substring (point-min) (point)))
376       (save-restriction
377         (narrow-to-region (point-min) (point))
378         (setq cte (mail-fetch-field "content-transfer-encoding")))
379       (forward-line 1)
380       (delete-region (point-min) (point))
381       (when cte
382         (setq cte (intern (downcase cte)))
383         (mm-decode-content-transfer-encoding cte)))
384     (condition-case error
385         (setq signature (epg-sign-string context (buffer-string) 'clear)
386               mml1991-epg-secret-key-id-list nil)
387       (error
388        (while mml1991-epg-secret-key-id-list
389          (password-cache-remove (car mml1991-epg-secret-key-id-list))
390          (setq mml1991-epg-secret-key-id-list
391                (cdr mml1991-epg-secret-key-id-list)))
392        (signal (car error) (cdr error))))
393     (delete-region (point-min) (point-max))
394     (mm-with-unibyte-current-buffer
395       (insert signature)
396       (goto-char (point-min))
397       (while (re-search-forward "\r+$" nil t)
398         (replace-match "" t t))
399       (when cte
400         (mm-encode-content-transfer-encoding cte))
401       (goto-char (point-min))
402       (when headers
403         (insert headers))
404       (insert "\n"))
405     t))
406
407 (defun mml1991-epg-encrypt (cont &optional sign)
408   (goto-char (point-min))
409   (when (re-search-forward "^$" nil t)
410     (let ((cte (save-restriction
411                  (narrow-to-region (point-min) (point))
412                  (mail-fetch-field "content-transfer-encoding"))))
413       ;; Strip MIME headers since it will be ASCII armoured.
414       (forward-line 1)
415       (delete-region (point-min) (point))
416       (when cte
417         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
418   (let ((context (epg-make-context))
419         (recipients
420          (if (message-options-get 'message-recipients)
421              (split-string
422               (message-options-get 'message-recipients)
423               "[ \f\t\n\r\v,]+")))
424         cipher signers config)
425     ;; We should remove this check if epg-0.0.6 is released.
426     (if (and (condition-case nil
427                  (require 'epg-config)
428                (error))
429              (functionp #'epg-expand-group))
430         (setq config (epg-configuration)
431               recipients
432               (apply #'nconc
433                      (mapcar (lambda (recipient)
434                                (or (epg-expand-group config recipient)
435                                    (list recipient)))
436                              recipients))))
437     (if mml1991-verbose
438         (setq recipients
439               (epa-select-keys context "Select recipients for encryption.
440 If no one is selected, symmetric encryption will be performed.  "
441                                recipients))
442       (setq recipients
443             (delq nil (mapcar (lambda (name)
444                                 (car (epg-list-keys context name)))
445                               recipients))))
446     (if mml1991-encrypt-to-self
447         (if mml1991-signers
448             (setq recipients
449                   (nconc recipients
450                          (mapcar (lambda (name)
451                                    (car (epg-list-keys context name)))
452                                  mml1991-signers)))
453           (error "mml1991-signers not set")))
454     (when sign
455       (if mml1991-verbose
456           (setq signers (epa-select-keys context "Select keys for signing.
457 If no one is selected, default secret key is used.  "
458                                          mml1991-signers t))
459         (if mml1991-signers
460             (setq signers (mapcar (lambda (name)
461                                     (car (epg-list-keys context name t)))
462                                   mml1991-signers))))
463       (epg-context-set-signers context signers))
464     (epg-context-set-armor context t)
465     (epg-context-set-textmode context t)
466     (if mml1991-cache-passphrase
467         (epg-context-set-passphrase-callback
468          context
469          #'mml1991-epg-passphrase-callback))
470     (condition-case error
471         (setq cipher
472               (epg-encrypt-string context (buffer-string) recipients sign)
473               mml1991-epg-secret-key-id-list nil)
474       (error
475        (while mml1991-epg-secret-key-id-list
476          (password-cache-remove (car mml1991-epg-secret-key-id-list))
477          (setq mml1991-epg-secret-key-id-list
478                (cdr mml1991-epg-secret-key-id-list)))
479        (signal (car error) (cdr error))))
480     (delete-region (point-min) (point-max))
481     (insert "\n" cipher))
482   t)
483
484 ;;;###autoload
485 (defun mml1991-encrypt (cont &optional sign)
486   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
487     (if func
488         (funcall func cont sign)
489       (error "Cannot find encrypt function"))))
490
491 ;;;###autoload
492 (defun mml1991-sign (cont)
493   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
494     (if func
495         (funcall func cont)
496       (error "Cannot find sign function"))))
497
498 (provide 'mml1991)
499
500 ;; Local Variables:
501 ;; coding: iso-8859-1
502 ;; End:
503
504 ;;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706
505 ;;; mml1991.el ends here