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