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