1 ;;; mml-smime.el --- S/MIME support for MML
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: Simon Josefsson <simon@josefsson.org>
7 ;; Keywords: Gnus, MIME, S/MIME, MML
9 ;; This file is part of GNU Emacs.
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
13 ;; by the Free Software Foundation; either version 3, or (at your
14 ;; option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
32 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
34 (eval-when-compile (require 'cl))
39 (autoload 'message-narrow-to-headers "message")
40 (autoload 'message-fetch-field "message")
42 (defvar mml-smime-use 'openssl)
44 (defvar mml-smime-function-alist
45 '((openssl mml-smime-openssl-sign
46 mml-smime-openssl-encrypt
47 mml-smime-openssl-sign-query
48 mml-smime-openssl-encrypt-query
49 mml-smime-openssl-verify
50 mml-smime-openssl-verify-test)
51 (epg mml-smime-epg-sign
56 mml-smime-epg-verify-test)))
58 (defcustom mml-smime-verbose mml-secure-verbose
59 "If non-nil, ask the user about the current operation more verbosely."
63 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
64 "If t, cache passphrase."
68 (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
69 "How many seconds the passphrase is cached.
70 Whether the passphrase is cached at all is controlled by
71 `mml-smime-cache-passphrase'."
75 (defcustom mml-smime-signers nil
76 "A list of your own key ID which will be used to sign a message."
78 :type '(repeat (string :tag "Key ID")))
80 (defun mml-smime-sign (cont)
81 (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
84 (error "Cannot find sign function"))))
86 (defun mml-smime-encrypt (cont)
87 (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
90 (error "Cannot find encrypt function"))))
92 (defun mml-smime-sign-query ()
93 (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
97 (defun mml-smime-encrypt-query ()
98 (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
102 (defun mml-smime-verify (handle ctl)
103 (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
105 (funcall func handle ctl)
108 (defun mml-smime-verify-test (handle ctl)
109 (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
111 (funcall func handle ctl))))
113 (defun mml-smime-openssl-sign (cont)
114 (when (null smime-keys)
115 (customize-variable 'smime-keys)
116 (error "No S/MIME keys configured, use customize to add your key"))
117 (smime-sign-buffer (cdr (assq 'keyfile cont)))
118 (goto-char (point-min))
119 (while (search-forward "\r\n" nil t)
120 (replace-match "\n" t t))
121 (goto-char (point-max)))
123 (defun mml-smime-openssl-encrypt (cont)
124 (let (certnames certfiles tmp file tmpfiles)
125 ;; xxx tmp files are always an security issue
126 (while (setq tmp (pop cont))
127 (if (and (consp tmp) (eq (car tmp) 'certfile))
128 (push (cdr tmp) certnames)))
129 (while (setq tmp (pop certnames))
130 (if (not (and (not (file-exists-p tmp))
133 (setq file (mm-make-temp-file (expand-file-name "mml."
135 (with-current-buffer tmp
136 (write-region (point-min) (point-max) file))
137 (push file certfiles)
138 (push file tmpfiles)))
139 (if (smime-encrypt-buffer certfiles)
141 (while (setq tmp (pop tmpfiles))
144 (while (setq tmp (pop tmpfiles))
147 (goto-char (point-max)))
149 (defvar gnus-extract-address-components)
151 (defun mml-smime-openssl-sign-query ()
152 ;; query information (what certificate) from user when MML tag is
153 ;; added, for use later by the signing process
154 (when (null smime-keys)
155 (customize-variable 'smime-keys)
156 (error "No S/MIME keys configured, use customize to add your key"))
158 (if (= (length smime-keys) 1)
160 (or (let ((from (cadr (funcall (if (boundp
161 'gnus-extract-address-components)
162 gnus-extract-address-components
163 'mail-extract-address-components)
166 (message-narrow-to-headers)
167 (message-fetch-field "from")))
169 (and from (smime-get-key-by-email from)))
170 (smime-get-key-by-email
171 (completing-read "Sign this part with what signature? "
173 (and (listp (car-safe smime-keys))
174 (caar smime-keys))))))))
176 (defun mml-smime-get-file-cert ()
178 (list 'certfile (read-file-name
179 "File with recipient's S/MIME certificate: "
180 smime-certificate-directory nil t ""))))
182 (defun mml-smime-get-dns-cert ()
183 ;; todo: deal with comma separated multiple recipients
184 (let (result who bad cert)
187 (setq who (read-from-minibuffer
188 (format "%sLookup certificate for: " (or bad ""))
189 (cadr (funcall (if (boundp
190 'gnus-extract-address-components)
191 gnus-extract-address-components
192 'mail-extract-address-components)
195 (message-narrow-to-headers)
196 (message-fetch-field "to")))
198 (if (setq cert (smime-cert-by-dns who))
199 (setq result (list 'certfile (buffer-name cert)))
200 (setq bad (format "`%s' not found. " who))))
204 (defun mml-smime-get-ldap-cert ()
205 ;; todo: deal with comma separated multiple recipients
206 (let (result who bad cert)
209 (setq who (read-from-minibuffer
210 (format "%sLookup certificate for: " (or bad ""))
211 (cadr (funcall gnus-extract-address-components
214 (message-narrow-to-headers)
215 (message-fetch-field "to")))
217 (if (setq cert (smime-cert-by-ldap who))
218 (setq result (list 'certfile (buffer-name cert)))
219 (setq bad (format "`%s' not found. " who))))
223 (autoload 'gnus-completing-read-with-default "gnus-util")
225 (defun mml-smime-openssl-encrypt-query ()
226 ;; todo: try dns/ldap automatically first, before prompting user
229 (ecase (read (gnus-completing-read-with-default
230 "ldap" "Fetch certificate from"
231 '(("dns") ("ldap") ("file")) nil t))
232 (dns (setq certs (append certs
233 (mml-smime-get-dns-cert))))
234 (ldap (setq certs (append certs
235 (mml-smime-get-ldap-cert))))
236 (file (setq certs (append certs
237 (mml-smime-get-file-cert)))))
238 (setq done (not (y-or-n-p "Add more recipients? "))))
241 (defun mml-smime-openssl-verify (handle ctl)
243 (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
244 (goto-char (point-min))
245 (insert (format "Content-Type: %s; " (mm-handle-media-type ctl)))
246 (insert (format "protocol=\"%s\"; "
247 (mm-handle-multipart-ctl-parameter ctl 'protocol)))
248 (insert (format "micalg=\"%s\"; "
249 (mm-handle-multipart-ctl-parameter ctl 'micalg)))
250 (insert (format "boundary=\"%s\"\n\n"
251 (mm-handle-multipart-ctl-parameter ctl 'boundary)))
252 (when (get-buffer smime-details-buffer)
253 (kill-buffer smime-details-buffer))
254 (let ((buf (current-buffer))
255 (good-signature (smime-noverify-buffer))
256 (good-certificate (and (or smime-CA-file smime-CA-directory)
257 (smime-verify-buffer)))
258 addresses openssl-output)
259 (setq openssl-output (with-current-buffer smime-details-buffer
261 (if (not good-signature)
263 ;; we couldn't verify message, fail with openssl output as message
264 (mm-set-handle-multipart-parameter
265 mm-security-handle 'gnus-info "Failed")
266 (mm-set-handle-multipart-parameter
267 mm-security-handle 'gnus-details
268 (concat "OpenSSL failed to verify message integrity:\n"
269 "-------------------------------------------\n"
271 ;; verify mail addresses in mail against those in certificate
272 (when (and (smime-pkcs7-region (point-min) (point-max))
273 (smime-pkcs7-certificates-region (point-min) (point-max)))
275 (insert-buffer-substring buf)
276 (goto-char (point-min))
277 (while (re-search-forward "-----END CERTIFICATE-----" nil t)
278 (when (smime-pkcs7-email-region (point-min) (point))
279 (setq addresses (append (smime-buffer-as-string-region
280 (point-min) (point)) addresses)))
281 (delete-region (point-min) (point)))
282 (setq addresses (mapcar 'downcase addresses))))
283 (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses))
284 (mm-set-handle-multipart-parameter
285 mm-security-handle 'gnus-info "Sender address forged")
287 (mm-set-handle-multipart-parameter
288 mm-security-handle 'gnus-info "Ok (sender authenticated)")
289 (mm-set-handle-multipart-parameter
290 mm-security-handle 'gnus-info "Ok (sender not trusted)")))
291 (mm-set-handle-multipart-parameter
292 mm-security-handle 'gnus-details
293 (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
295 (concat "Addresses in certificate: "
296 (mapconcat 'identity addresses ", "))
297 "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
300 "---------------\n" openssl-output "\n"
301 "Certificate(s) inside S/MIME signature:\n"
302 "---------------------------------------\n"
303 (buffer-string) "\n")))))
306 (defun mml-smime-openssl-verify-test (handle ctl)
307 smime-openssl-program)
309 (defvar epg-user-id-alist)
310 (defvar epg-digest-algorithm-alist)
311 (defvar inhibit-redisplay)
312 (defvar password-cache-expiry)
315 (autoload 'epg-make-context "epg")
316 (autoload 'epg-context-set-armor "epg")
317 (autoload 'epg-context-set-signers "epg")
318 (autoload 'epg-context-result-for "epg")
319 (autoload 'epg-new-signature-digest-algorithm "epg")
320 (autoload 'epg-verify-result-to-string "epg")
321 (autoload 'epg-list-keys "epg")
322 (autoload 'epg-decrypt-string "epg")
323 (autoload 'epg-verify-string "epg")
324 (autoload 'epg-sign-string "epg")
325 (autoload 'epg-encrypt-string "epg")
326 (autoload 'epg-passphrase-callback-function "epg")
327 (autoload 'epg-context-set-passphrase-callback "epg")
328 (autoload 'epg-configuration "epg-config")
329 (autoload 'epg-expand-group "epg-config")
330 (autoload 'epa-select-keys "epa"))
332 (defvar mml-smime-epg-secret-key-id-list nil)
334 (defun mml-smime-epg-passphrase-callback (context key-id ignore)
336 (epg-passphrase-callback-function context key-id nil)
341 "Passphrase for PIN: "
342 (if (setq entry (assoc key-id epg-user-id-alist))
343 (format "Passphrase for %s %s: " key-id (cdr entry))
344 (format "Passphrase for %s: " key-id)))
349 (let ((password-cache-expiry mml-smime-passphrase-cache-expiry))
350 (password-cache-add key-id passphrase))
351 (setq mml-smime-epg-secret-key-id-list
352 (cons key-id mml-smime-epg-secret-key-id-list))
353 (copy-sequence passphrase)))))
355 (declare-function epg-key-sub-key-list "ext:epg" (key))
356 (declare-function epg-sub-key-capability "ext:epg" (sub-key))
357 (declare-function epg-sub-key-validity "ext:epg" (sub-key))
359 (defun mml-smime-epg-find-usable-key (keys usage)
362 (let ((pointer (epg-key-sub-key-list (car keys))))
364 (if (and (memq usage (epg-sub-key-capability (car pointer)))
365 (not (memq (epg-sub-key-validity (car pointer))
366 '(revoked expired))))
367 (throw 'found (car keys)))
368 (setq pointer (cdr pointer))))
369 (setq keys (cdr keys)))))
371 (autoload 'mml-compute-boundary "mml")
373 ;; We require mm-decode, which requires mm-bodies, which autoloads
374 ;; message-options-get (!).
375 (declare-function message-options-set "message" (symbol value))
377 (defun mml-smime-epg-sign (cont)
378 (let* ((inhibit-redisplay t)
379 (context (epg-make-context 'CMS))
380 (boundary (mml-compute-boundary cont))
383 (or (message-options-get 'mml-smime-epg-signers)
385 'mml-smime-epg-signers
386 (if mml-smime-verbose
387 (epa-select-keys context "\
388 Select keys for signing.
389 If no one is selected, default secret key is used. "
391 (if mml-smime-signers
394 (setq signer-key (mml-smime-epg-find-usable-key
395 (epg-list-keys context signer t)
397 (unless (or signer-key
399 (format "No secret key for %s; skip it? "
401 (error "No secret key for %s" signer))
403 mml-smime-signers))))))
405 (epg-context-set-signers context signers)
406 (if mml-smime-cache-passphrase
407 (epg-context-set-passphrase-callback
409 #'mml-smime-epg-passphrase-callback))
410 (condition-case error
411 (setq signature (epg-sign-string context
412 (mm-replace-in-string (buffer-string)
415 mml-smime-epg-secret-key-id-list nil)
417 (while mml-smime-epg-secret-key-id-list
418 (password-cache-remove (car mml-smime-epg-secret-key-id-list))
419 (setq mml-smime-epg-secret-key-id-list
420 (cdr mml-smime-epg-secret-key-id-list)))
421 (signal (car error) (cdr error))))
422 (if (epg-context-result-for context 'sign)
423 (setq micalg (epg-new-signature-digest-algorithm
424 (car (epg-context-result-for context 'sign)))))
425 (goto-char (point-min))
426 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
429 (insert (format "\tmicalg=%s; "
432 epg-digest-algorithm-alist))))))
433 (insert "protocol=\"application/pkcs7-signature\"\n")
434 (insert (format "\n--%s\n" boundary))
435 (goto-char (point-max))
436 (insert (format "\n--%s\n" boundary))
437 (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
438 Content-Transfer-Encoding: base64
439 Content-Disposition: attachment; filename=smime.p7s
442 (insert (base64-encode-string signature) "\n")
443 (goto-char (point-max))
444 (insert (format "--%s--\n" boundary))
445 (goto-char (point-max))))
447 (defun mml-smime-epg-encrypt (cont)
448 (let ((inhibit-redisplay t)
449 (context (epg-make-context 'CMS))
450 (config (epg-configuration))
451 (recipients (message-options-get 'mml-smime-epg-recipients))
453 (boundary (mml-compute-boundary cont))
460 (or (epg-expand-group config recipient)
463 (or (message-options-get 'message-recipients)
464 (message-options-set 'message-recipients
465 (read-string "Recipients: ")))
466 "[ \f\t\n\r\v,]+"))))
467 (if mml-smime-verbose
469 (epa-select-keys context "\
470 Select recipients for encryption.
471 If no one is selected, symmetric encryption will be performed. "
476 (setq recipient-key (mml-smime-epg-find-usable-key
477 (epg-list-keys context recipient)
479 (unless (or recipient-key
481 (format "No public key for %s; skip it? "
483 (error "No public key for %s" recipient))
487 (error "No recipient specified")))
488 (message-options-set 'mml-smime-epg-recipients recipients))
489 (if mml-smime-cache-passphrase
490 (epg-context-set-passphrase-callback
492 #'mml-smime-epg-passphrase-callback))
493 (condition-case error
495 (epg-encrypt-string context (buffer-string) recipients)
496 mml-smime-epg-secret-key-id-list nil)
498 (while mml-smime-epg-secret-key-id-list
499 (password-cache-remove (car mml-smime-epg-secret-key-id-list))
500 (setq mml-smime-epg-secret-key-id-list
501 (cdr mml-smime-epg-secret-key-id-list)))
502 (signal (car error) (cdr error))))
503 (delete-region (point-min) (point-max))
504 (goto-char (point-min))
506 Content-Type: application/pkcs7-mime;
507 smime-type=enveloped-data;
509 Content-Transfer-Encoding: base64
510 Content-Disposition: attachment; filename=smime.p7m
513 (insert (base64-encode-string cipher))
514 (goto-char (point-max))))
516 (defun mml-smime-epg-verify (handle ctl)
518 (let ((inhibit-redisplay t)
519 context plain signature-file part signature)
520 (when (or (null (setq part (mm-find-raw-part-by-type
521 ctl (or (mm-handle-multipart-ctl-parameter
523 "application/pkcs7-signature")
525 (null (setq signature (mm-find-part-by-type
527 "application/pkcs7-signature"
529 (mm-set-handle-multipart-parameter
530 mm-security-handle 'gnus-info "Corrupted")
531 (throw 'error handle))
532 (setq part (mm-replace-in-string part "\n" "\r\n" t)
533 context (epg-make-context 'CMS))
534 (condition-case error
535 (setq plain (epg-verify-string context (mm-get-part signature) part))
537 (mm-set-handle-multipart-parameter
538 mm-security-handle 'gnus-info "Failed")
539 (if (eq (car error) 'quit)
540 (mm-set-handle-multipart-parameter
541 mm-security-handle 'gnus-details "Quit.")
542 (mm-set-handle-multipart-parameter
543 mm-security-handle 'gnus-details (format "%S" error)))
544 (throw 'error handle)))
545 (mm-set-handle-multipart-parameter
546 mm-security-handle 'gnus-info
547 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
550 (defun mml-smime-epg-verify-test (handle ctl)
555 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
556 ;;; mml-smime.el ends here