Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; mml-smime.el --- S/MIME support for MML |
e84b4b86 | 2 | |
ba318903 | 3 | ;; Copyright (C) 2000-2014 Free Software Foundation, Inc. |
23f87bed MB |
4 | |
5 | ;; Author: Simon Josefsson <simon@josefsson.org> | |
6 | ;; Keywords: Gnus, MIME, S/MIME, MML | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
5e809f55 GM |
10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation, either version 3 of the License, or | |
13 | ;; (at your option) any later version. | |
23f87bed | 14 | |
5e809f55 GM |
15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
23f87bed MB |
19 | |
20 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
23f87bed MB |
22 | |
23 | ;;; Commentary: | |
24 | ||
25 | ;;; Code: | |
26 | ||
c1d7d285 MB |
27 | (eval-when-compile (require 'cl)) |
28 | ||
23f87bed MB |
29 | (require 'smime) |
30 | (require 'mm-decode) | |
01c52d31 | 31 | (require 'mml-sec) |
23f87bed | 32 | (autoload 'message-narrow-to-headers "message") |
c1d7d285 | 33 | (autoload 'message-fetch-field "message") |
23f87bed | 34 | |
c5ecc769 G |
35 | (defcustom mml-smime-use (if (featurep 'epg) 'epg 'openssl) |
36 | "Whether to use OpenSSL or EPG to decrypt S/MIME messages. | |
37 | Defaults to EPG if it's loaded." | |
38 | :group 'mime-security | |
39 | :type '(choice (const :tag "EPG" epg) | |
40 | (const :tag "OpenSSL" openssl))) | |
01c52d31 MB |
41 | |
42 | (defvar mml-smime-function-alist | |
43 | '((openssl mml-smime-openssl-sign | |
44 | mml-smime-openssl-encrypt | |
45 | mml-smime-openssl-sign-query | |
46 | mml-smime-openssl-encrypt-query | |
47 | mml-smime-openssl-verify | |
48 | mml-smime-openssl-verify-test) | |
49 | (epg mml-smime-epg-sign | |
50 | mml-smime-epg-encrypt | |
51 | nil | |
52 | nil | |
53 | mml-smime-epg-verify | |
54 | mml-smime-epg-verify-test))) | |
55 | ||
01c52d31 MB |
56 | (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase |
57 | "If t, cache passphrase." | |
58 | :group 'mime-security | |
59 | :type 'boolean) | |
60 | ||
61 | (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry | |
62 | "How many seconds the passphrase is cached. | |
63 | Whether the passphrase is cached at all is controlled by | |
64 | `mml-smime-cache-passphrase'." | |
65 | :group 'mime-security | |
66 | :type 'integer) | |
67 | ||
68 | (defcustom mml-smime-signers nil | |
69 | "A list of your own key ID which will be used to sign a message." | |
70 | :group 'mime-security | |
71 | :type '(repeat (string :tag "Key ID"))) | |
72 | ||
38eba8df DU |
73 | (defcustom mml-smime-sign-with-sender nil |
74 | "If t, use message sender so find a key to sign with." | |
75 | :group 'mime-security | |
83c1803a | 76 | :version "24.4" |
38eba8df DU |
77 | :type 'boolean) |
78 | ||
0b2780df UB |
79 | (defcustom mml-smime-encrypt-to-self nil |
80 | "If t, add your own key ID to recipient list when encryption." | |
81 | :group 'mime-security | |
82 | :version "24.4" | |
83 | :type 'boolean) | |
84 | ||
23f87bed | 85 | (defun mml-smime-sign (cont) |
01c52d31 MB |
86 | (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist)))) |
87 | (if func | |
88 | (funcall func cont) | |
89 | (error "Cannot find sign function")))) | |
90 | ||
91 | (defun mml-smime-encrypt (cont) | |
92 | (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist)))) | |
93 | (if func | |
94 | (funcall func cont) | |
95 | (error "Cannot find encrypt function")))) | |
96 | ||
97 | (defun mml-smime-sign-query () | |
98 | (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist)))) | |
99 | (if func | |
100 | (funcall func)))) | |
101 | ||
102 | (defun mml-smime-encrypt-query () | |
103 | (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist)))) | |
104 | (if func | |
105 | (funcall func)))) | |
106 | ||
107 | (defun mml-smime-verify (handle ctl) | |
108 | (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist)))) | |
109 | (if func | |
110 | (funcall func handle ctl) | |
111 | handle))) | |
112 | ||
113 | (defun mml-smime-verify-test (handle ctl) | |
114 | (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist)))) | |
115 | (if func | |
116 | (funcall func handle ctl)))) | |
117 | ||
118 | (defun mml-smime-openssl-sign (cont) | |
23f87bed MB |
119 | (when (null smime-keys) |
120 | (customize-variable 'smime-keys) | |
121 | (error "No S/MIME keys configured, use customize to add your key")) | |
122 | (smime-sign-buffer (cdr (assq 'keyfile cont))) | |
123 | (goto-char (point-min)) | |
124 | (while (search-forward "\r\n" nil t) | |
125 | (replace-match "\n" t t)) | |
126 | (goto-char (point-max))) | |
127 | ||
01c52d31 | 128 | (defun mml-smime-openssl-encrypt (cont) |
23f87bed MB |
129 | (let (certnames certfiles tmp file tmpfiles) |
130 | ;; xxx tmp files are always an security issue | |
131 | (while (setq tmp (pop cont)) | |
132 | (if (and (consp tmp) (eq (car tmp) 'certfile)) | |
133 | (push (cdr tmp) certnames))) | |
134 | (while (setq tmp (pop certnames)) | |
135 | (if (not (and (not (file-exists-p tmp)) | |
136 | (get-buffer tmp))) | |
137 | (push tmp certfiles) | |
8d1d11d8 | 138 | (setq file (mm-make-temp-file (expand-file-name "mml." |
23f87bed MB |
139 | mm-tmp-directory))) |
140 | (with-current-buffer tmp | |
141 | (write-region (point-min) (point-max) file)) | |
142 | (push file certfiles) | |
143 | (push file tmpfiles))) | |
144 | (if (smime-encrypt-buffer certfiles) | |
145 | (progn | |
146 | (while (setq tmp (pop tmpfiles)) | |
147 | (delete-file tmp)) | |
148 | t) | |
149 | (while (setq tmp (pop tmpfiles)) | |
150 | (delete-file tmp)) | |
151 | nil)) | |
152 | (goto-char (point-max))) | |
153 | ||
ec374c91 GM |
154 | (defvar gnus-extract-address-components) |
155 | ||
01c52d31 | 156 | (defun mml-smime-openssl-sign-query () |
23f87bed MB |
157 | ;; query information (what certificate) from user when MML tag is |
158 | ;; added, for use later by the signing process | |
159 | (when (null smime-keys) | |
160 | (customize-variable 'smime-keys) | |
161 | (error "No S/MIME keys configured, use customize to add your key")) | |
162 | (list 'keyfile | |
163 | (if (= (length smime-keys) 1) | |
164 | (cadar smime-keys) | |
4a2358e9 MB |
165 | (or (let ((from (cadr (funcall (if (boundp |
166 | 'gnus-extract-address-components) | |
167 | gnus-extract-address-components | |
168 | 'mail-extract-address-components) | |
23f87bed MB |
169 | (or (save-excursion |
170 | (save-restriction | |
171 | (message-narrow-to-headers) | |
172 | (message-fetch-field "from"))) | |
173 | ""))))) | |
174 | (and from (smime-get-key-by-email from))) | |
175 | (smime-get-key-by-email | |
229b59da | 176 | (gnus-completing-read "Sign this part with what signature" |
71e691a5 | 177 | (mapcar 'car smime-keys) nil nil nil |
229b59da G |
178 | (and (listp (car-safe smime-keys)) |
179 | (caar smime-keys)))))))) | |
23f87bed MB |
180 | |
181 | (defun mml-smime-get-file-cert () | |
182 | (ignore-errors | |
183 | (list 'certfile (read-file-name | |
184 | "File with recipient's S/MIME certificate: " | |
185 | smime-certificate-directory nil t "")))) | |
186 | ||
187 | (defun mml-smime-get-dns-cert () | |
188 | ;; todo: deal with comma separated multiple recipients | |
189 | (let (result who bad cert) | |
190 | (condition-case () | |
191 | (while (not result) | |
192 | (setq who (read-from-minibuffer | |
193 | (format "%sLookup certificate for: " (or bad "")) | |
4a2358e9 MB |
194 | (cadr (funcall (if (boundp |
195 | 'gnus-extract-address-components) | |
196 | gnus-extract-address-components | |
197 | 'mail-extract-address-components) | |
23f87bed MB |
198 | (or (save-excursion |
199 | (save-restriction | |
200 | (message-narrow-to-headers) | |
201 | (message-fetch-field "to"))) | |
202 | ""))))) | |
203 | (if (setq cert (smime-cert-by-dns who)) | |
204 | (setq result (list 'certfile (buffer-name cert))) | |
205 | (setq bad (format "`%s' not found. " who)))) | |
206 | (quit)) | |
207 | result)) | |
208 | ||
01c52d31 MB |
209 | (defun mml-smime-get-ldap-cert () |
210 | ;; todo: deal with comma separated multiple recipients | |
211 | (let (result who bad cert) | |
212 | (condition-case () | |
213 | (while (not result) | |
214 | (setq who (read-from-minibuffer | |
215 | (format "%sLookup certificate for: " (or bad "")) | |
216 | (cadr (funcall gnus-extract-address-components | |
217 | (or (save-excursion | |
218 | (save-restriction | |
219 | (message-narrow-to-headers) | |
220 | (message-fetch-field "to"))) | |
221 | ""))))) | |
222 | (if (setq cert (smime-cert-by-ldap who)) | |
223 | (setq result (list 'certfile (buffer-name cert))) | |
224 | (setq bad (format "`%s' not found. " who)))) | |
225 | (quit)) | |
226 | result)) | |
227 | ||
229b59da | 228 | (autoload 'gnus-completing-read "gnus-util") |
431e6df6 | 229 | |
01c52d31 | 230 | (defun mml-smime-openssl-encrypt-query () |
23f87bed MB |
231 | ;; todo: try dns/ldap automatically first, before prompting user |
232 | (let (certs done) | |
233 | (while (not done) | |
229b59da G |
234 | (ecase (read (gnus-completing-read |
235 | "Fetch certificate from" | |
71e691a5 | 236 | '("dns" "ldap" "file") t nil nil |
229b59da | 237 | "ldap")) |
23f87bed MB |
238 | (dns (setq certs (append certs |
239 | (mml-smime-get-dns-cert)))) | |
01c52d31 MB |
240 | (ldap (setq certs (append certs |
241 | (mml-smime-get-ldap-cert)))) | |
23f87bed MB |
242 | (file (setq certs (append certs |
243 | (mml-smime-get-file-cert))))) | |
244 | (setq done (not (y-or-n-p "Add more recipients? ")))) | |
245 | certs)) | |
246 | ||
01c52d31 | 247 | (defun mml-smime-openssl-verify (handle ctl) |
23f87bed MB |
248 | (with-temp-buffer |
249 | (insert-buffer-substring (mm-handle-multipart-original-buffer ctl)) | |
250 | (goto-char (point-min)) | |
251 | (insert (format "Content-Type: %s; " (mm-handle-media-type ctl))) | |
252 | (insert (format "protocol=\"%s\"; " | |
253 | (mm-handle-multipart-ctl-parameter ctl 'protocol))) | |
254 | (insert (format "micalg=\"%s\"; " | |
255 | (mm-handle-multipart-ctl-parameter ctl 'micalg))) | |
256 | (insert (format "boundary=\"%s\"\n\n" | |
257 | (mm-handle-multipart-ctl-parameter ctl 'boundary))) | |
258 | (when (get-buffer smime-details-buffer) | |
259 | (kill-buffer smime-details-buffer)) | |
260 | (let ((buf (current-buffer)) | |
261 | (good-signature (smime-noverify-buffer)) | |
262 | (good-certificate (and (or smime-CA-file smime-CA-directory) | |
263 | (smime-verify-buffer))) | |
264 | addresses openssl-output) | |
265 | (setq openssl-output (with-current-buffer smime-details-buffer | |
266 | (buffer-string))) | |
267 | (if (not good-signature) | |
268 | (progn | |
269 | ;; we couldn't verify message, fail with openssl output as message | |
270 | (mm-set-handle-multipart-parameter | |
271 | mm-security-handle 'gnus-info "Failed") | |
272 | (mm-set-handle-multipart-parameter | |
273 | mm-security-handle 'gnus-details | |
274 | (concat "OpenSSL failed to verify message integrity:\n" | |
275 | "-------------------------------------------\n" | |
276 | openssl-output))) | |
277 | ;; verify mail addresses in mail against those in certificate | |
278 | (when (and (smime-pkcs7-region (point-min) (point-max)) | |
279 | (smime-pkcs7-certificates-region (point-min) (point-max))) | |
280 | (with-temp-buffer | |
281 | (insert-buffer-substring buf) | |
282 | (goto-char (point-min)) | |
283 | (while (re-search-forward "-----END CERTIFICATE-----" nil t) | |
284 | (when (smime-pkcs7-email-region (point-min) (point)) | |
285 | (setq addresses (append (smime-buffer-as-string-region | |
286 | (point-min) (point)) addresses))) | |
287 | (delete-region (point-min) (point))) | |
288 | (setq addresses (mapcar 'downcase addresses)))) | |
289 | (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses)) | |
290 | (mm-set-handle-multipart-parameter | |
291 | mm-security-handle 'gnus-info "Sender address forged") | |
292 | (if good-certificate | |
293 | (mm-set-handle-multipart-parameter | |
294 | mm-security-handle 'gnus-info "Ok (sender authenticated)") | |
295 | (mm-set-handle-multipart-parameter | |
296 | mm-security-handle 'gnus-info "Ok (sender not trusted)"))) | |
297 | (mm-set-handle-multipart-parameter | |
298 | mm-security-handle 'gnus-details | |
299 | (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n" | |
300 | (if addresses | |
301 | (concat "Addresses in certificate: " | |
302 | (mapconcat 'identity addresses ", ")) | |
303 | "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)") | |
304 | "\n" "\n" | |
305 | "OpenSSL output:\n" | |
306 | "---------------\n" openssl-output "\n" | |
307 | "Certificate(s) inside S/MIME signature:\n" | |
308 | "---------------------------------------\n" | |
309 | (buffer-string) "\n"))))) | |
310 | handle) | |
311 | ||
01c52d31 | 312 | (defun mml-smime-openssl-verify-test (handle ctl) |
23f87bed MB |
313 | smime-openssl-program) |
314 | ||
9efa445f DN |
315 | (defvar epg-user-id-alist) |
316 | (defvar epg-digest-algorithm-alist) | |
317 | (defvar inhibit-redisplay) | |
318 | (defvar password-cache-expiry) | |
01c52d31 MB |
319 | |
320 | (eval-when-compile | |
9efa445f | 321 | (autoload 'epg-make-context "epg") |
01c52d31 MB |
322 | (autoload 'epg-context-set-armor "epg") |
323 | (autoload 'epg-context-set-signers "epg") | |
324 | (autoload 'epg-context-result-for "epg") | |
325 | (autoload 'epg-new-signature-digest-algorithm "epg") | |
326 | (autoload 'epg-verify-result-to-string "epg") | |
327 | (autoload 'epg-list-keys "epg") | |
328 | (autoload 'epg-decrypt-string "epg") | |
329 | (autoload 'epg-verify-string "epg") | |
330 | (autoload 'epg-sign-string "epg") | |
331 | (autoload 'epg-encrypt-string "epg") | |
332 | (autoload 'epg-passphrase-callback-function "epg") | |
333 | (autoload 'epg-context-set-passphrase-callback "epg") | |
b84e3dda | 334 | (autoload 'epg-sub-key-fingerprint "epg") |
01c52d31 MB |
335 | (autoload 'epg-configuration "epg-config") |
336 | (autoload 'epg-expand-group "epg-config") | |
ec374c91 | 337 | (autoload 'epa-select-keys "epa")) |
01c52d31 MB |
338 | |
339 | (defvar mml-smime-epg-secret-key-id-list nil) | |
340 | ||
341 | (defun mml-smime-epg-passphrase-callback (context key-id ignore) | |
342 | (if (eq key-id 'SYM) | |
343 | (epg-passphrase-callback-function context key-id nil) | |
344 | (let* (entry | |
345 | (passphrase | |
346 | (password-read | |
347 | (if (eq key-id 'PIN) | |
348 | "Passphrase for PIN: " | |
349 | (if (setq entry (assoc key-id epg-user-id-alist)) | |
350 | (format "Passphrase for %s %s: " key-id (cdr entry)) | |
351 | (format "Passphrase for %s: " key-id))) | |
352 | (if (eq key-id 'PIN) | |
353 | "PIN" | |
354 | key-id)))) | |
355 | (when passphrase | |
356 | (let ((password-cache-expiry mml-smime-passphrase-cache-expiry)) | |
357 | (password-cache-add key-id passphrase)) | |
358 | (setq mml-smime-epg-secret-key-id-list | |
359 | (cons key-id mml-smime-epg-secret-key-id-list)) | |
360 | (copy-sequence passphrase))))) | |
361 | ||
431e6df6 GM |
362 | (declare-function epg-key-sub-key-list "ext:epg" (key)) |
363 | (declare-function epg-sub-key-capability "ext:epg" (sub-key)) | |
364 | (declare-function epg-sub-key-validity "ext:epg" (sub-key)) | |
365 | ||
01c52d31 MB |
366 | (defun mml-smime-epg-find-usable-key (keys usage) |
367 | (catch 'found | |
368 | (while keys | |
369 | (let ((pointer (epg-key-sub-key-list (car keys)))) | |
370 | (while pointer | |
371 | (if (and (memq usage (epg-sub-key-capability (car pointer))) | |
372 | (not (memq (epg-sub-key-validity (car pointer)) | |
373 | '(revoked expired)))) | |
374 | (throw 'found (car keys))) | |
375 | (setq pointer (cdr pointer)))) | |
376 | (setq keys (cdr keys))))) | |
377 | ||
38eba8df DU |
378 | ;; XXX: since gpg --list-secret-keys does not return validity of each |
379 | ;; key, `mml-smime-epg-find-usable-key' defined above is not enough for | |
380 | ;; secret keys. The function `mml-smime-epg-find-usable-secret-key' | |
381 | ;; below looks at appropriate public keys to check usability. | |
382 | (defun mml-smime-epg-find-usable-secret-key (context name usage) | |
383 | (let ((secret-keys (epg-list-keys context name t)) | |
384 | secret-key) | |
385 | (while (and (not secret-key) secret-keys) | |
386 | (if (mml-smime-epg-find-usable-key | |
387 | (epg-list-keys context (epg-sub-key-fingerprint | |
388 | (car (epg-key-sub-key-list | |
389 | (car secret-keys))))) | |
390 | usage) | |
391 | (setq secret-key (car secret-keys) | |
392 | secret-keys nil) | |
393 | (setq secret-keys (cdr secret-keys)))) | |
394 | secret-key)) | |
395 | ||
431e6df6 GM |
396 | (autoload 'mml-compute-boundary "mml") |
397 | ||
398 | ;; We require mm-decode, which requires mm-bodies, which autoloads | |
399 | ;; message-options-get (!). | |
400 | (declare-function message-options-set "message" (symbol value)) | |
401 | ||
01c52d31 MB |
402 | (defun mml-smime-epg-sign (cont) |
403 | (let* ((inhibit-redisplay t) | |
404 | (context (epg-make-context 'CMS)) | |
405 | (boundary (mml-compute-boundary cont)) | |
38eba8df DU |
406 | (sender (message-options-get 'message-sender)) |
407 | (signer-names (or mml-smime-signers | |
408 | (if (and mml-smime-sign-with-sender sender) | |
409 | (list (concat "<" sender ">"))))) | |
01c52d31 MB |
410 | signer-key |
411 | (signers | |
412 | (or (message-options-get 'mml-smime-epg-signers) | |
413 | (message-options-set | |
38eba8df DU |
414 | 'mml-smime-epg-signers |
415 | (if (eq mm-sign-option 'guided) | |
416 | (epa-select-keys context "\ | |
01c52d31 MB |
417 | Select keys for signing. |
418 | If no one is selected, default secret key is used. " | |
38eba8df DU |
419 | signer-names |
420 | t) | |
421 | (if (or sender mml-smime-signers) | |
422 | (delq nil | |
423 | (mapcar | |
424 | (lambda (signer) | |
425 | (setq signer-key | |
426 | (mml-smime-epg-find-usable-secret-key | |
427 | context signer 'sign)) | |
428 | (unless (or signer-key | |
429 | (y-or-n-p | |
430 | (format | |
431 | "No secret key for %s; skip it? " | |
01c52d31 | 432 | signer))) |
38eba8df DU |
433 | (error "No secret key for %s" signer)) |
434 | signer-key) | |
435 | signer-names))))))) | |
01c52d31 MB |
436 | signature micalg) |
437 | (epg-context-set-signers context signers) | |
438 | (if mml-smime-cache-passphrase | |
439 | (epg-context-set-passphrase-callback | |
440 | context | |
441 | #'mml-smime-epg-passphrase-callback)) | |
442 | (condition-case error | |
443 | (setq signature (epg-sign-string context | |
444 | (mm-replace-in-string (buffer-string) | |
445 | "\n" "\r\n") | |
446 | t) | |
447 | mml-smime-epg-secret-key-id-list nil) | |
448 | (error | |
449 | (while mml-smime-epg-secret-key-id-list | |
450 | (password-cache-remove (car mml-smime-epg-secret-key-id-list)) | |
451 | (setq mml-smime-epg-secret-key-id-list | |
452 | (cdr mml-smime-epg-secret-key-id-list))) | |
453 | (signal (car error) (cdr error)))) | |
454 | (if (epg-context-result-for context 'sign) | |
455 | (setq micalg (epg-new-signature-digest-algorithm | |
456 | (car (epg-context-result-for context 'sign))))) | |
457 | (goto-char (point-min)) | |
458 | (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" | |
459 | boundary)) | |
460 | (if micalg | |
461 | (insert (format "\tmicalg=%s; " | |
462 | (downcase | |
463 | (cdr (assq micalg | |
464 | epg-digest-algorithm-alist)))))) | |
465 | (insert "protocol=\"application/pkcs7-signature\"\n") | |
466 | (insert (format "\n--%s\n" boundary)) | |
467 | (goto-char (point-max)) | |
468 | (insert (format "\n--%s\n" boundary)) | |
469 | (insert "Content-Type: application/pkcs7-signature; name=smime.p7s | |
470 | Content-Transfer-Encoding: base64 | |
471 | Content-Disposition: attachment; filename=smime.p7s | |
472 | ||
473 | ") | |
474 | (insert (base64-encode-string signature) "\n") | |
475 | (goto-char (point-max)) | |
476 | (insert (format "--%s--\n" boundary)) | |
477 | (goto-char (point-max)))) | |
478 | ||
479 | (defun mml-smime-epg-encrypt (cont) | |
0b2780df UB |
480 | (let* ((inhibit-redisplay t) |
481 | (context (epg-make-context 'CMS)) | |
482 | (config (epg-configuration)) | |
483 | (recipients (message-options-get 'mml-smime-epg-recipients)) | |
484 | cipher signers | |
485 | (sender (message-options-get 'message-sender)) | |
486 | (signer-names (or mml-smime-signers | |
487 | (if (and mml-smime-sign-with-sender sender) | |
488 | (list (concat "<" sender ">"))))) | |
489 | (boundary (mml-compute-boundary cont)) | |
490 | recipient-key) | |
01c52d31 MB |
491 | (unless recipients |
492 | (setq recipients | |
493 | (apply #'nconc | |
494 | (mapcar | |
495 | (lambda (recipient) | |
496 | (or (epg-expand-group config recipient) | |
497 | (list recipient))) | |
498 | (split-string | |
499 | (or (message-options-get 'message-recipients) | |
500 | (message-options-set 'message-recipients | |
501 | (read-string "Recipients: "))) | |
502 | "[ \f\t\n\r\v,]+")))) | |
0b2780df UB |
503 | (when mml-smime-encrypt-to-self |
504 | (unless signer-names | |
505 | (error "Neither message sender nor mml-smime-signers are set")) | |
506 | (setq recipients (nconc recipients signer-names))) | |
54c72c31 | 507 | (if (eq mm-encrypt-option 'guided) |
01c52d31 MB |
508 | (setq recipients |
509 | (epa-select-keys context "\ | |
510 | Select recipients for encryption. | |
511 | If no one is selected, symmetric encryption will be performed. " | |
512 | recipients)) | |
513 | (setq recipients | |
514 | (mapcar | |
515 | (lambda (recipient) | |
516 | (setq recipient-key (mml-smime-epg-find-usable-key | |
517 | (epg-list-keys context recipient) | |
518 | 'encrypt)) | |
519 | (unless (or recipient-key | |
520 | (y-or-n-p | |
521 | (format "No public key for %s; skip it? " | |
522 | recipient))) | |
523 | (error "No public key for %s" recipient)) | |
524 | recipient-key) | |
525 | recipients)) | |
526 | (unless recipients | |
527 | (error "No recipient specified"))) | |
528 | (message-options-set 'mml-smime-epg-recipients recipients)) | |
529 | (if mml-smime-cache-passphrase | |
530 | (epg-context-set-passphrase-callback | |
531 | context | |
532 | #'mml-smime-epg-passphrase-callback)) | |
533 | (condition-case error | |
534 | (setq cipher | |
535 | (epg-encrypt-string context (buffer-string) recipients) | |
536 | mml-smime-epg-secret-key-id-list nil) | |
537 | (error | |
538 | (while mml-smime-epg-secret-key-id-list | |
539 | (password-cache-remove (car mml-smime-epg-secret-key-id-list)) | |
540 | (setq mml-smime-epg-secret-key-id-list | |
541 | (cdr mml-smime-epg-secret-key-id-list))) | |
542 | (signal (car error) (cdr error)))) | |
543 | (delete-region (point-min) (point-max)) | |
544 | (goto-char (point-min)) | |
545 | (insert "\ | |
546 | Content-Type: application/pkcs7-mime; | |
547 | smime-type=enveloped-data; | |
548 | name=smime.p7m | |
549 | Content-Transfer-Encoding: base64 | |
550 | Content-Disposition: attachment; filename=smime.p7m | |
551 | ||
552 | ") | |
553 | (insert (base64-encode-string cipher)) | |
554 | (goto-char (point-max)))) | |
555 | ||
556 | (defun mml-smime-epg-verify (handle ctl) | |
557 | (catch 'error | |
558 | (let ((inhibit-redisplay t) | |
559 | context plain signature-file part signature) | |
560 | (when (or (null (setq part (mm-find-raw-part-by-type | |
561 | ctl (or (mm-handle-multipart-ctl-parameter | |
562 | ctl 'protocol) | |
563 | "application/pkcs7-signature") | |
564 | t))) | |
86fb1061 KY |
565 | (null (setq signature (or (mm-find-part-by-type |
566 | (cdr handle) | |
567 | "application/pkcs7-signature" | |
568 | nil t) | |
569 | (mm-find-part-by-type | |
570 | (cdr handle) | |
571 | "application/x-pkcs7-signature" | |
572 | nil t))))) | |
01c52d31 MB |
573 | (mm-set-handle-multipart-parameter |
574 | mm-security-handle 'gnus-info "Corrupted") | |
575 | (throw 'error handle)) | |
0f3de88f | 576 | (setq part (mm-replace-in-string part "\n" "\r\n") |
01c52d31 MB |
577 | context (epg-make-context 'CMS)) |
578 | (condition-case error | |
579 | (setq plain (epg-verify-string context (mm-get-part signature) part)) | |
580 | (error | |
581 | (mm-set-handle-multipart-parameter | |
582 | mm-security-handle 'gnus-info "Failed") | |
583 | (if (eq (car error) 'quit) | |
584 | (mm-set-handle-multipart-parameter | |
585 | mm-security-handle 'gnus-details "Quit.") | |
586 | (mm-set-handle-multipart-parameter | |
587 | mm-security-handle 'gnus-details (format "%S" error))) | |
588 | (throw 'error handle))) | |
589 | (mm-set-handle-multipart-parameter | |
590 | mm-security-handle 'gnus-info | |
591 | (epg-verify-result-to-string (epg-context-result-for context 'verify))) | |
592 | handle))) | |
593 | ||
594 | (defun mml-smime-epg-verify-test (handle ctl) | |
595 | t) | |
596 | ||
23f87bed MB |
597 | (provide 'mml-smime) |
598 | ||
23f87bed | 599 | ;;; mml-smime.el ends here |