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