1 ;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4 ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Sascha Lüdecke <sascha@meta-x.de>,
7 ;; Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
10 ;; This file is part of GNU Emacs.
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 of the License, or
15 ;; (at your option) any later version.
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
33 (if (locate-library "password-cache")
34 (require 'password-cache)
44 (defvar mc-pgp-always-sign)
46 (autoload 'quoted-printable-decode-region "qp")
47 (autoload 'quoted-printable-encode-region "qp")
49 (autoload 'mm-decode-content-transfer-encoding "mm-bodies")
50 (autoload 'mm-encode-content-transfer-encoding "mm-bodies")
51 (autoload 'message-options-get "message")
52 (autoload 'message-options-set "message")
54 (defvar mml1991-use mml2015-use
55 "The package used for PGP.")
57 (defvar mml1991-function-alist
58 '((mailcrypt mml1991-mailcrypt-sign
59 mml1991-mailcrypt-encrypt)
66 "Alist of PGP functions.")
68 (defvar mml1991-verbose mml-secure-verbose
69 "If non-nil, ask the user about the current operation more verbosely.")
71 (defvar mml1991-cache-passphrase mml-secure-cache-passphrase
72 "If t, cache passphrase.")
74 (defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
75 "How many seconds the passphrase is cached.
76 Whether the passphrase is cached at all is controlled by
77 `mml1991-cache-passphrase'.")
79 (defvar mml1991-signers nil
80 "A list of your own key ID which will be used to sign a message.")
82 (defvar mml1991-encrypt-to-self nil
83 "If t, add your own key ID to recipient list when encryption.")
87 (autoload 'mc-sign-generic "mc-toplev")
89 (defvar mml1991-decrypt-function 'mailcrypt-decrypt)
90 (defvar mml1991-verify-function 'mailcrypt-verify)
92 (defun mml1991-mailcrypt-sign (cont)
93 (let ((text (current-buffer))
95 (result-buffer (get-buffer-create "*GPG Result*")))
96 ;; Save MIME Content[^ ]+: headers from signing
97 (goto-char (point-min))
98 (while (looking-at "^Content[^ ]+:") (forward-line))
100 (setq headers (buffer-string))
101 (delete-region (point-min) (point)))
102 (goto-char (point-max))
105 (quoted-printable-decode-region (point-min) (point-max))
107 (setq signature (current-buffer))
108 (insert-buffer-substring text)
109 (unless (mc-sign-generic (message-options-get 'message-sender)
111 (unless (> (point-max) (point-min))
112 (pop-to-buffer result-buffer)
113 (error "Sign error")))
114 (goto-char (point-min))
115 (while (re-search-forward "\r+$" nil t)
116 (replace-match "" t t))
117 (quoted-printable-encode-region (point-min) (point-max))
119 (delete-region (point-min) (point-max))
120 (if headers (insert headers))
122 (insert-buffer-substring signature)
123 (goto-char (point-max)))))
125 (declare-function mc-encrypt-generic "ext:mc-toplev"
126 (&optional recipients scheme start end from sign))
128 (defun mml1991-mailcrypt-encrypt (cont &optional sign)
129 (let ((text (current-buffer))
131 (or mc-pgp-always-sign
133 (eq t (or (message-options-get 'message-sign-encrypt)
135 'message-sign-encrypt
136 (or (y-or-n-p "Sign the message? ")
140 (result-buffer (get-buffer-create "*GPG Result*")))
141 ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
142 (goto-char (point-min))
143 (while (looking-at "^Content[^ ]+:") (forward-line))
145 (delete-region (point-min) (point)))
146 (mm-with-unibyte-current-buffer
148 (inline (mm-disable-multibyte))
149 (setq cipher (current-buffer))
150 (insert-buffer-substring text)
151 (unless (mc-encrypt-generic
153 (message-options-get 'message-recipients)
154 (message-options-set 'message-recipients
155 (read-string "Recipients: ")))
157 (point-min) (point-max)
158 (message-options-get 'message-sender)
160 (unless (> (point-max) (point-min))
161 (pop-to-buffer result-buffer)
162 (error "Encrypt error")))
163 (goto-char (point-min))
164 (while (re-search-forward "\r+$" nil t)
165 (replace-match "" t t))
167 (delete-region (point-min) (point-max))
168 ;;(insert "Content-Type: application/pgp-encrypted\n\n")
169 ;;(insert "Version: 1\n\n")
171 (insert-buffer-substring cipher)
172 (goto-char (point-max))))))
176 (autoload 'gpg-sign-cleartext "gpg")
178 (declare-function gpg-sign-encrypt "ext:gpg"
179 (plaintext ciphertext result recipients &optional
180 passphrase sign-with-key armor textmode))
181 (declare-function gpg-encrypt "ext:gpg"
182 (plaintext ciphertext result recipients &optional
183 passphrase armor textmode))
185 (defun mml1991-gpg-sign (cont)
186 (let ((text (current-buffer))
188 (result-buffer (get-buffer-create "*GPG Result*")))
189 ;; Save MIME Content[^ ]+: headers from signing
190 (goto-char (point-min))
191 (while (looking-at "^Content[^ ]+:") (forward-line))
193 (setq headers (buffer-string))
194 (delete-region (point-min) (point)))
195 (goto-char (point-max))
198 (quoted-printable-decode-region (point-min) (point-max))
200 (unless (gpg-sign-cleartext text (setq signature (current-buffer))
203 (message-options-get 'message-sender))
204 (unless (> (point-max) (point-min))
205 (pop-to-buffer result-buffer)
206 (error "Sign error")))
207 (goto-char (point-min))
208 (while (re-search-forward "\r+$" nil t)
209 (replace-match "" t t))
210 (quoted-printable-encode-region (point-min) (point-max))
212 (delete-region (point-min) (point-max))
213 (if headers (insert headers))
215 (insert-buffer-substring signature)
216 (goto-char (point-max)))))
218 (defun mml1991-gpg-encrypt (cont &optional sign)
219 (let ((text (current-buffer))
221 (result-buffer (get-buffer-create "*GPG Result*")))
222 ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
223 (goto-char (point-min))
224 (while (looking-at "^Content[^ ]+:") (forward-line))
226 (delete-region (point-min) (point)))
227 (mm-with-unibyte-current-buffer
229 (inline (mm-disable-multibyte))
230 (flet ((gpg-encrypt-func
231 (sign plaintext ciphertext result recipients &optional
232 passphrase sign-with-key armor textmode)
235 plaintext ciphertext result recipients passphrase
236 sign-with-key armor textmode)
238 plaintext ciphertext result recipients passphrase
240 (unless (gpg-encrypt-func
242 text (setq cipher (current-buffer))
246 (message-options-get 'message-recipients)
247 (message-options-set 'message-recipients
248 (read-string "Recipients: ")))
251 (message-options-get 'message-sender)
252 t t) ; armor & textmode
253 (unless (> (point-max) (point-min))
254 (pop-to-buffer result-buffer)
255 (error "Encrypt error"))))
256 (goto-char (point-min))
257 (while (re-search-forward "\r+$" nil t)
258 (replace-match "" t t))
260 (delete-region (point-min) (point-max))
261 ;;(insert "Content-Type: application/pgp-encrypted\n\n")
262 ;;(insert "Version: 1\n\n")
264 (insert-buffer-substring cipher)
265 (goto-char (point-max))))))
269 (defvar pgg-default-user-id)
270 (defvar pgg-errors-buffer)
271 (defvar pgg-output-buffer)
273 (defun mml1991-pgg-sign (cont)
274 (let ((pgg-text-mode t)
275 (pgg-default-user-id (or (message-options-get 'mml-sender)
276 pgg-default-user-id))
278 ;; Don't sign headers.
279 (goto-char (point-min))
280 (when (re-search-forward "^$" nil t)
281 (setq headers (buffer-substring (point-min) (point)))
283 (narrow-to-region (point-min) (point))
284 (setq cte (mail-fetch-field "content-transfer-encoding")))
286 (delete-region (point-min) (point))
288 (setq cte (intern (downcase cte)))
289 (mm-decode-content-transfer-encoding cte)))
290 (unless (pgg-sign-region (point-min) (point-max) t)
291 (pop-to-buffer pgg-errors-buffer)
292 (error "Encrypt error"))
293 (delete-region (point-min) (point-max))
294 (mm-with-unibyte-current-buffer
295 (insert-buffer-substring pgg-output-buffer)
296 (goto-char (point-min))
297 (while (re-search-forward "\r+$" nil t)
298 (replace-match "" t t))
300 (mm-encode-content-transfer-encoding cte))
301 (goto-char (point-min))
307 (defun mml1991-pgg-encrypt (cont &optional sign)
308 (goto-char (point-min))
309 (when (re-search-forward "^$" nil t)
310 (let ((cte (save-restriction
311 (narrow-to-region (point-min) (point))
312 (mail-fetch-field "content-transfer-encoding"))))
313 ;; Strip MIME headers since it will be ASCII armored.
315 (delete-region (point-min) (point))
317 (mm-decode-content-transfer-encoding (intern (downcase cte))))))
318 (unless (let ((pgg-text-mode t))
320 (point-min) (point-max)
323 (message-options-get 'message-recipients)
324 (message-options-set 'message-recipients
325 (read-string "Recipients: ")))
328 (pop-to-buffer pgg-errors-buffer)
329 (error "Encrypt error"))
330 (delete-region (point-min) (point-max))
332 (insert-buffer-substring pgg-output-buffer)
337 (defvar epg-user-id-alist)
339 (autoload 'epg-make-context "epg")
340 (autoload 'epg-passphrase-callback-function "epg")
341 (autoload 'epa-select-keys "epa")
342 (autoload 'epg-list-keys "epg")
343 (autoload 'epg-context-set-armor "epg")
344 (autoload 'epg-context-set-textmode "epg")
345 (autoload 'epg-context-set-signers "epg")
346 (autoload 'epg-context-set-passphrase-callback "epg")
347 (autoload 'epg-sign-string "epg")
348 (autoload 'epg-encrypt-string "epg")
349 (autoload 'epg-configuration "epg-config")
350 (autoload 'epg-expand-group "epg-config")
352 (defvar mml1991-epg-secret-key-id-list nil)
354 (defun mml1991-epg-passphrase-callback (context key-id ignore)
356 (epg-passphrase-callback-function context key-id nil)
357 (let* ((entry (assoc key-id epg-user-id-alist))
360 (format "GnuPG passphrase for %s: "
368 (let ((password-cache-expiry mml1991-passphrase-cache-expiry))
369 (password-cache-add key-id passphrase))
370 (setq mml1991-epg-secret-key-id-list
371 (cons key-id mml1991-epg-secret-key-id-list))
372 (copy-sequence passphrase)))))
374 (defun mml1991-epg-sign (cont)
375 (let ((context (epg-make-context))
376 headers cte signers signature)
377 (if (eq mm-sign-option 'guided)
378 (setq signers (epa-select-keys context "Select keys for signing.
379 If no one is selected, default secret key is used. "
382 (setq signers (mapcar (lambda (name)
383 (car (epg-list-keys context name t)))
385 (epg-context-set-armor context t)
386 (epg-context-set-textmode context t)
387 (epg-context-set-signers context signers)
388 (if mml1991-cache-passphrase
389 (epg-context-set-passphrase-callback
391 #'mml1991-epg-passphrase-callback))
392 ;; Don't sign headers.
393 (goto-char (point-min))
394 (when (re-search-forward "^$" nil t)
395 (setq headers (buffer-substring (point-min) (point)))
397 (narrow-to-region (point-min) (point))
398 (setq cte (mail-fetch-field "content-transfer-encoding")))
400 (delete-region (point-min) (point))
402 (setq cte (intern (downcase cte)))
403 (mm-decode-content-transfer-encoding cte)))
404 (condition-case error
405 (setq signature (epg-sign-string context (buffer-string) 'clear)
406 mml1991-epg-secret-key-id-list nil)
408 (while mml1991-epg-secret-key-id-list
409 (password-cache-remove (car mml1991-epg-secret-key-id-list))
410 (setq mml1991-epg-secret-key-id-list
411 (cdr mml1991-epg-secret-key-id-list)))
412 (signal (car error) (cdr error))))
413 (delete-region (point-min) (point-max))
414 (mm-with-unibyte-current-buffer
416 (goto-char (point-min))
417 (while (re-search-forward "\r+$" nil t)
418 (replace-match "" t t))
420 (mm-encode-content-transfer-encoding cte))
421 (goto-char (point-min))
427 (defun mml1991-epg-encrypt (cont &optional sign)
428 (goto-char (point-min))
429 (when (re-search-forward "^$" nil t)
430 (let ((cte (save-restriction
431 (narrow-to-region (point-min) (point))
432 (mail-fetch-field "content-transfer-encoding"))))
433 ;; Strip MIME headers since it will be ASCII armored.
435 (delete-region (point-min) (point))
437 (mm-decode-content-transfer-encoding (intern (downcase cte))))))
438 (let ((context (epg-make-context))
440 (if (message-options-get 'message-recipients)
442 (message-options-get 'message-recipients)
444 cipher signers config)
445 ;; We should remove this check if epg-0.0.6 is released.
446 (if (and (condition-case nil
447 (require 'epg-config)
449 (functionp #'epg-expand-group))
450 (setq config (epg-configuration)
453 (mapcar (lambda (recipient)
454 (or (epg-expand-group config recipient)
457 (if (eq mm-encrypt-option 'guided)
459 (epa-select-keys context "Select recipients for encryption.
460 If no one is selected, symmetric encryption will be performed. "
463 (delq nil (mapcar (lambda (name)
464 (car (epg-list-keys context name)))
466 (if mml1991-encrypt-to-self
470 (mapcar (lambda (name)
471 (car (epg-list-keys context name)))
473 (error "mml1991-signers not set")))
475 (if (eq mm-sign-option 'guided)
476 (setq signers (epa-select-keys context "Select keys for signing.
477 If no one is selected, default secret key is used. "
480 (setq signers (mapcar (lambda (name)
481 (car (epg-list-keys context name t)))
483 (epg-context-set-signers context signers))
484 (epg-context-set-armor context t)
485 (epg-context-set-textmode context t)
486 (if mml1991-cache-passphrase
487 (epg-context-set-passphrase-callback
489 #'mml1991-epg-passphrase-callback))
490 (condition-case error
492 (epg-encrypt-string context (buffer-string) recipients sign)
493 mml1991-epg-secret-key-id-list nil)
495 (while mml1991-epg-secret-key-id-list
496 (password-cache-remove (car mml1991-epg-secret-key-id-list))
497 (setq mml1991-epg-secret-key-id-list
498 (cdr mml1991-epg-secret-key-id-list)))
499 (signal (car error) (cdr error))))
500 (delete-region (point-min) (point-max))
501 (insert "\n" cipher))
505 (defun mml1991-encrypt (cont &optional sign)
506 (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
508 (funcall func cont sign)
509 (error "Cannot find encrypt function"))))
512 (defun mml1991-sign (cont)
513 (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
516 (error "Cannot find sign function"))))
521 ;; coding: iso-8859-1
524 ;;; mml1991.el ends here