Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; mml-smime.el --- S/MIME support for MML |
e84b4b86 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 2000-2011 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 | ||
f0b7f5a8 | 27 | ;; For Emacs <22.2 and XEmacs. |
431e6df6 GM |
28 | (eval-and-compile |
29 | (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) | |
30 | ||
c1d7d285 MB |
31 | (eval-when-compile (require 'cl)) |
32 | ||
23f87bed MB |
33 | (require 'smime) |
34 | (require 'mm-decode) | |
01c52d31 | 35 | (require 'mml-sec) |
23f87bed | 36 | (autoload 'message-narrow-to-headers "message") |
c1d7d285 | 37 | (autoload 'message-fetch-field "message") |
23f87bed | 38 | |
c5ecc769 G |
39 | (defcustom mml-smime-use (if (featurep 'epg) 'epg 'openssl) |
40 | "Whether to use OpenSSL or EPG to decrypt S/MIME messages. | |
41 | Defaults to EPG if it's loaded." | |
42 | :group 'mime-security | |
43 | :type '(choice (const :tag "EPG" epg) | |
44 | (const :tag "OpenSSL" openssl))) | |
01c52d31 MB |
45 | |
46 | (defvar mml-smime-function-alist | |
47 | '((openssl mml-smime-openssl-sign | |
48 | mml-smime-openssl-encrypt | |
49 | mml-smime-openssl-sign-query | |
50 | mml-smime-openssl-encrypt-query | |
51 | mml-smime-openssl-verify | |
52 | mml-smime-openssl-verify-test) | |
53 | (epg mml-smime-epg-sign | |
54 | mml-smime-epg-encrypt | |
55 | nil | |
56 | nil | |
57 | mml-smime-epg-verify | |
58 | mml-smime-epg-verify-test))) | |
59 | ||
01c52d31 MB |
60 | (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase |
61 | "If t, cache passphrase." | |
62 | :group 'mime-security | |
63 | :type 'boolean) | |
64 | ||
65 | (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry | |
66 | "How many seconds the passphrase is cached. | |
67 | Whether the passphrase is cached at all is controlled by | |
68 | `mml-smime-cache-passphrase'." | |
69 | :group 'mime-security | |
70 | :type 'integer) | |
71 | ||
72 | (defcustom mml-smime-signers nil | |
73 | "A list of your own key ID which will be used to sign a message." | |
74 | :group 'mime-security | |
75 | :type '(repeat (string :tag "Key ID"))) | |
76 | ||
23f87bed | 77 | (defun mml-smime-sign (cont) |
01c52d31 MB |
78 | (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist)))) |
79 | (if func | |
80 | (funcall func cont) | |
81 | (error "Cannot find sign function")))) | |
82 | ||
83 | (defun mml-smime-encrypt (cont) | |
84 | (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist)))) | |
85 | (if func | |
86 | (funcall func cont) | |
87 | (error "Cannot find encrypt function")))) | |
88 | ||
89 | (defun mml-smime-sign-query () | |
90 | (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist)))) | |
91 | (if func | |
92 | (funcall func)))) | |
93 | ||
94 | (defun mml-smime-encrypt-query () | |
95 | (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist)))) | |
96 | (if func | |
97 | (funcall func)))) | |
98 | ||
99 | (defun mml-smime-verify (handle ctl) | |
100 | (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist)))) | |
101 | (if func | |
102 | (funcall func handle ctl) | |
103 | handle))) | |
104 | ||
105 | (defun mml-smime-verify-test (handle ctl) | |
106 | (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist)))) | |
107 | (if func | |
108 | (funcall func handle ctl)))) | |
109 | ||
110 | (defun mml-smime-openssl-sign (cont) | |
23f87bed MB |
111 | (when (null smime-keys) |
112 | (customize-variable 'smime-keys) | |
113 | (error "No S/MIME keys configured, use customize to add your key")) | |
114 | (smime-sign-buffer (cdr (assq 'keyfile cont))) | |
115 | (goto-char (point-min)) | |
116 | (while (search-forward "\r\n" nil t) | |
117 | (replace-match "\n" t t)) | |
118 | (goto-char (point-max))) | |
119 | ||
01c52d31 | 120 | (defun mml-smime-openssl-encrypt (cont) |
23f87bed MB |
121 | (let (certnames certfiles tmp file tmpfiles) |
122 | ;; xxx tmp files are always an security issue | |
123 | (while (setq tmp (pop cont)) | |
124 | (if (and (consp tmp) (eq (car tmp) 'certfile)) | |
125 | (push (cdr tmp) certnames))) | |
126 | (while (setq tmp (pop certnames)) | |
127 | (if (not (and (not (file-exists-p tmp)) | |
128 | (get-buffer tmp))) | |
129 | (push tmp certfiles) | |
8d1d11d8 | 130 | (setq file (mm-make-temp-file (expand-file-name "mml." |
23f87bed MB |
131 | mm-tmp-directory))) |
132 | (with-current-buffer tmp | |
133 | (write-region (point-min) (point-max) file)) | |
134 | (push file certfiles) | |
135 | (push file tmpfiles))) | |
136 | (if (smime-encrypt-buffer certfiles) | |
137 | (progn | |
138 | (while (setq tmp (pop tmpfiles)) | |
139 | (delete-file tmp)) | |
140 | t) | |
141 | (while (setq tmp (pop tmpfiles)) | |
142 | (delete-file tmp)) | |
143 | nil)) | |
144 | (goto-char (point-max))) | |
145 | ||
ec374c91 GM |
146 | (defvar gnus-extract-address-components) |
147 | ||
01c52d31 | 148 | (defun mml-smime-openssl-sign-query () |
23f87bed MB |
149 | ;; query information (what certificate) from user when MML tag is |
150 | ;; added, for use later by the signing process | |
151 | (when (null smime-keys) | |
152 | (customize-variable 'smime-keys) | |
153 | (error "No S/MIME keys configured, use customize to add your key")) | |
154 | (list 'keyfile | |
155 | (if (= (length smime-keys) 1) | |
156 | (cadar smime-keys) | |
4a2358e9 MB |
157 | (or (let ((from (cadr (funcall (if (boundp |
158 | 'gnus-extract-address-components) | |
159 | gnus-extract-address-components | |
160 | 'mail-extract-address-components) | |
23f87bed MB |
161 | (or (save-excursion |
162 | (save-restriction | |
163 | (message-narrow-to-headers) | |
164 | (message-fetch-field "from"))) | |
165 | ""))))) | |
166 | (and from (smime-get-key-by-email from))) | |
167 | (smime-get-key-by-email | |
229b59da | 168 | (gnus-completing-read "Sign this part with what signature" |
71e691a5 | 169 | (mapcar 'car smime-keys) nil nil nil |
229b59da G |
170 | (and (listp (car-safe smime-keys)) |
171 | (caar smime-keys)))))))) | |
23f87bed MB |
172 | |
173 | (defun mml-smime-get-file-cert () | |
174 | (ignore-errors | |
175 | (list 'certfile (read-file-name | |
176 | "File with recipient's S/MIME certificate: " | |
177 | smime-certificate-directory nil t "")))) | |
178 | ||
179 | (defun mml-smime-get-dns-cert () | |
180 | ;; todo: deal with comma separated multiple recipients | |
181 | (let (result who bad cert) | |
182 | (condition-case () | |
183 | (while (not result) | |
184 | (setq who (read-from-minibuffer | |
185 | (format "%sLookup certificate for: " (or bad "")) | |
4a2358e9 MB |
186 | (cadr (funcall (if (boundp |
187 | 'gnus-extract-address-components) | |
188 | gnus-extract-address-components | |
189 | 'mail-extract-address-components) | |
23f87bed MB |
190 | (or (save-excursion |
191 | (save-restriction | |
192 | (message-narrow-to-headers) | |
193 | (message-fetch-field "to"))) | |
194 | ""))))) | |
195 | (if (setq cert (smime-cert-by-dns who)) | |
196 | (setq result (list 'certfile (buffer-name cert))) | |
197 | (setq bad (format "`%s' not found. " who)))) | |
198 | (quit)) | |
199 | result)) | |
200 | ||
01c52d31 MB |
201 | (defun mml-smime-get-ldap-cert () |
202 | ;; todo: deal with comma separated multiple recipients | |
203 | (let (result who bad cert) | |
204 | (condition-case () | |
205 | (while (not result) | |
206 | (setq who (read-from-minibuffer | |
207 | (format "%sLookup certificate for: " (or bad "")) | |
208 | (cadr (funcall gnus-extract-address-components | |
209 | (or (save-excursion | |
210 | (save-restriction | |
211 | (message-narrow-to-headers) | |
212 | (message-fetch-field "to"))) | |
213 | ""))))) | |
214 | (if (setq cert (smime-cert-by-ldap who)) | |
215 | (setq result (list 'certfile (buffer-name cert))) | |
216 | (setq bad (format "`%s' not found. " who)))) | |
217 | (quit)) | |
218 | result)) | |
219 | ||
229b59da | 220 | (autoload 'gnus-completing-read "gnus-util") |
431e6df6 | 221 | |
01c52d31 | 222 | (defun mml-smime-openssl-encrypt-query () |
23f87bed MB |
223 | ;; todo: try dns/ldap automatically first, before prompting user |
224 | (let (certs done) | |
225 | (while (not done) | |
229b59da G |
226 | (ecase (read (gnus-completing-read |
227 | "Fetch certificate from" | |
71e691a5 | 228 | '("dns" "ldap" "file") t nil nil |
229b59da | 229 | "ldap")) |
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))) | |
86fb1061 KY |
523 | (null (setq signature (or (mm-find-part-by-type |
524 | (cdr handle) | |
525 | "application/pkcs7-signature" | |
526 | nil t) | |
527 | (mm-find-part-by-type | |
528 | (cdr handle) | |
529 | "application/x-pkcs7-signature" | |
530 | nil t))))) | |
01c52d31 MB |
531 | (mm-set-handle-multipart-parameter |
532 | mm-security-handle 'gnus-info "Corrupted") | |
533 | (throw 'error handle)) | |
534 | (setq part (mm-replace-in-string part "\n" "\r\n" t) | |
535 | context (epg-make-context 'CMS)) | |
536 | (condition-case error | |
537 | (setq plain (epg-verify-string context (mm-get-part signature) part)) | |
538 | (error | |
539 | (mm-set-handle-multipart-parameter | |
540 | mm-security-handle 'gnus-info "Failed") | |
541 | (if (eq (car error) 'quit) | |
542 | (mm-set-handle-multipart-parameter | |
543 | mm-security-handle 'gnus-details "Quit.") | |
544 | (mm-set-handle-multipart-parameter | |
545 | mm-security-handle 'gnus-details (format "%S" error))) | |
546 | (throw 'error handle))) | |
547 | (mm-set-handle-multipart-parameter | |
548 | mm-security-handle 'gnus-info | |
549 | (epg-verify-result-to-string (epg-context-result-for context 'verify))) | |
550 | handle))) | |
551 | ||
552 | (defun mml-smime-epg-verify-test (handle ctl) | |
553 | t) | |
554 | ||
23f87bed MB |
555 | (provide 'mml-smime) |
556 | ||
23f87bed | 557 | ;;; mml-smime.el ends here |