1 ;;; mml-smime.el --- S/MIME support for MML
3 ;; Copyright (C) 2000-2015 Free Software Foundation, Inc.
5 ;; Author: Simon Josefsson <simon@josefsson.org>
6 ;; Keywords: Gnus, MIME, S/MIME, MML
8 ;; This file is part of GNU Emacs.
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.
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 (eval-when-compile (require 'cl))
32 (autoload 'message-narrow-to-headers "message")
33 (autoload 'message-fetch-field "message")
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."
39 :type '(choice (const :tag "EPG" epg)
40 (const :tag "OpenSSL" openssl)))
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
54 mml-smime-epg-verify-test)))
56 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
57 "If t, cache passphrase."
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'."
68 (defcustom mml-smime-signers nil
69 "A list of your own key ID which will be used to sign a message."
71 :type '(repeat (string :tag "Key ID")))
73 (defcustom mml-smime-sign-with-sender nil
74 "If t, use message sender so find a key to sign with."
79 (defcustom mml-smime-encrypt-to-self nil
80 "If t, add your own key ID to recipient list when encryption."
85 (defun mml-smime-sign (cont)
86 (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
89 (error "Cannot find sign function"))))
91 (defun mml-smime-encrypt (cont)
92 (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
95 (error "Cannot find encrypt function"))))
97 (defun mml-smime-sign-query ()
98 (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
102 (defun mml-smime-encrypt-query ()
103 (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
107 (defun mml-smime-verify (handle ctl)
108 (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
110 (funcall func handle ctl)
113 (defun mml-smime-verify-test (handle ctl)
114 (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
116 (funcall func handle ctl))))
118 (defun mml-smime-openssl-sign (cont)
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)))
128 (defun mml-smime-openssl-encrypt (cont)
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))
138 (setq file (mm-make-temp-file (expand-file-name "mml."
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)
146 (while (setq tmp (pop tmpfiles))
149 (while (setq tmp (pop tmpfiles))
152 (goto-char (point-max)))
154 (defvar gnus-extract-address-components)
156 (defun mml-smime-openssl-sign-query ()
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"))
163 (if (= (length smime-keys) 1)
165 (or (let ((from (cadr (funcall (if (boundp
166 'gnus-extract-address-components)
167 gnus-extract-address-components
168 'mail-extract-address-components)
171 (message-narrow-to-headers)
172 (message-fetch-field "from")))
174 (and from (smime-get-key-by-email from)))
175 (smime-get-key-by-email
176 (gnus-completing-read "Sign this part with what signature"
177 (mapcar 'car smime-keys) nil nil nil
178 (and (listp (car-safe smime-keys))
179 (caar smime-keys))))))))
181 (defun mml-smime-get-file-cert ()
183 (list 'certfile (read-file-name
184 "File with recipient's S/MIME certificate: "
185 smime-certificate-directory nil t ""))))
187 (defun mml-smime-get-dns-cert ()
188 ;; todo: deal with comma separated multiple recipients
189 (let (result who bad cert)
192 (setq who (read-from-minibuffer
193 (format "%sLookup certificate for: " (or bad ""))
194 (cadr (funcall (if (boundp
195 'gnus-extract-address-components)
196 gnus-extract-address-components
197 'mail-extract-address-components)
200 (message-narrow-to-headers)
201 (message-fetch-field "to")))
203 (if (setq cert (smime-cert-by-dns who))
204 (setq result (list 'certfile (buffer-name cert)))
205 (setq bad (gnus-format-message "`%s' not found. " who))))
209 (defun mml-smime-get-ldap-cert ()
210 ;; todo: deal with comma separated multiple recipients
211 (let (result who bad cert)
214 (setq who (read-from-minibuffer
215 (format "%sLookup certificate for: " (or bad ""))
216 (cadr (funcall gnus-extract-address-components
219 (message-narrow-to-headers)
220 (message-fetch-field "to")))
222 (if (setq cert (smime-cert-by-ldap who))
223 (setq result (list 'certfile (buffer-name cert)))
224 (setq bad (gnus-format-message "`%s' not found. " who))))
228 (autoload 'gnus-completing-read "gnus-util")
230 (defun mml-smime-openssl-encrypt-query ()
231 ;; todo: try dns/ldap automatically first, before prompting user
234 (ecase (read (gnus-completing-read
235 "Fetch certificate from"
236 '("dns" "ldap" "file") t nil nil
238 (dns (setq certs (append certs
239 (mml-smime-get-dns-cert))))
240 (ldap (setq certs (append certs
241 (mml-smime-get-ldap-cert))))
242 (file (setq certs (append certs
243 (mml-smime-get-file-cert)))))
244 (setq done (not (y-or-n-p "Add more recipients? "))))
247 (defun mml-smime-openssl-verify (handle ctl)
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
267 (if (not good-signature)
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"
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)))
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")
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"
301 (concat "Addresses in certificate: "
302 (mapconcat 'identity addresses ", "))
303 "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
306 "---------------\n" openssl-output "\n"
307 "Certificate(s) inside S/MIME signature:\n"
308 "---------------------------------------\n"
309 (buffer-string) "\n")))))
312 (defun mml-smime-openssl-verify-test (handle ctl)
313 smime-openssl-program)
315 (defvar epg-user-id-alist)
316 (defvar epg-digest-algorithm-alist)
317 (defvar inhibit-redisplay)
318 (defvar password-cache-expiry)
320 (autoload 'epg-make-context "epg")
321 (autoload 'epg-passphrase-callback-function "epg")
322 (declare-function epg-context-set-signers "epg" (context signers))
323 (declare-function epg-context-result-for "epg" (context name))
324 (declare-function epg-new-signature-digest-algorithm "epg" (cl-x) t)
325 (declare-function epg-verify-result-to-string "epg" (verify-result))
326 (declare-function epg-list-keys "epg" (context &optional name mode))
327 (declare-function epg-verify-string "epg"
328 (context signature &optional signed-text))
329 (declare-function epg-sign-string "epg" (context plain &optional mode))
330 (declare-function epg-encrypt-string "epg"
331 (context plain recipients &optional sign always-trust))
332 (declare-function epg-context-set-passphrase-callback "epg"
333 (context passphrase-callback))
334 (declare-function epg-sub-key-fingerprint "epg" (cl-x) t)
335 (declare-function epg-configuration "epg-config" ())
336 (declare-function epg-expand-group "epg-config" (config group))
337 (declare-function epa-select-keys "epa"
338 (context prompt &optional names secret))
340 (defvar mml-smime-epg-secret-key-id-list nil)
342 (defun mml-smime-epg-passphrase-callback (context key-id ignore)
344 (epg-passphrase-callback-function context key-id nil)
349 "Passphrase for PIN: "
350 (if (setq entry (assoc key-id epg-user-id-alist))
351 (format "Passphrase for %s %s: " key-id (cdr entry))
352 (format "Passphrase for %s: " key-id)))
357 (let ((password-cache-expiry mml-smime-passphrase-cache-expiry))
358 (password-cache-add key-id passphrase))
359 (setq mml-smime-epg-secret-key-id-list
360 (cons key-id mml-smime-epg-secret-key-id-list))
361 (copy-sequence passphrase)))))
363 (declare-function epg-key-sub-key-list "epg" (key) t)
364 (declare-function epg-sub-key-capability "epg" (sub-key) t)
365 (declare-function epg-sub-key-validity "epg" (sub-key) t)
367 (defun mml-smime-epg-find-usable-key (keys usage)
370 (let ((pointer (epg-key-sub-key-list (car keys))))
372 (if (and (memq usage (epg-sub-key-capability (car pointer)))
373 (not (memq (epg-sub-key-validity (car pointer))
374 '(revoked expired))))
375 (throw 'found (car keys)))
376 (setq pointer (cdr pointer))))
377 (setq keys (cdr keys)))))
379 ;; XXX: since gpg --list-secret-keys does not return validity of each
380 ;; key, `mml-smime-epg-find-usable-key' defined above is not enough for
381 ;; secret keys. The function `mml-smime-epg-find-usable-secret-key'
382 ;; below looks at appropriate public keys to check usability.
383 (defun mml-smime-epg-find-usable-secret-key (context name usage)
384 (let ((secret-keys (epg-list-keys context name t))
386 (while (and (not secret-key) secret-keys)
387 (if (mml-smime-epg-find-usable-key
388 (epg-list-keys context (epg-sub-key-fingerprint
389 (car (epg-key-sub-key-list
390 (car secret-keys)))))
392 (setq secret-key (car secret-keys)
394 (setq secret-keys (cdr secret-keys))))
397 (autoload 'mml-compute-boundary "mml")
399 ;; We require mm-decode, which requires mm-bodies, which autoloads
400 ;; message-options-get (!).
401 (declare-function message-options-set "message" (symbol value))
403 (defun mml-smime-epg-sign (cont)
404 (let* ((inhibit-redisplay t)
405 (context (epg-make-context 'CMS))
406 (boundary (mml-compute-boundary cont))
407 (sender (message-options-get 'message-sender))
408 (signer-names (or mml-smime-signers
409 (if (and mml-smime-sign-with-sender sender)
410 (list (concat "<" sender ">")))))
413 (or (message-options-get 'mml-smime-epg-signers)
415 'mml-smime-epg-signers
416 (if (eq mm-sign-option 'guided)
417 (epa-select-keys context "\
418 Select keys for signing.
419 If no one is selected, default secret key is used. "
422 (if (or sender mml-smime-signers)
427 (mml-smime-epg-find-usable-secret-key
428 context signer 'sign))
429 (unless (or signer-key
432 "No secret key for %s; skip it? "
434 (error "No secret key for %s" signer))
438 (epg-context-set-signers context signers)
439 (if mml-smime-cache-passphrase
440 (epg-context-set-passphrase-callback
442 #'mml-smime-epg-passphrase-callback))
443 (condition-case error
444 (setq signature (epg-sign-string context
445 (mm-replace-in-string (buffer-string)
448 mml-smime-epg-secret-key-id-list nil)
450 (while mml-smime-epg-secret-key-id-list
451 (password-cache-remove (car mml-smime-epg-secret-key-id-list))
452 (setq mml-smime-epg-secret-key-id-list
453 (cdr mml-smime-epg-secret-key-id-list)))
454 (signal (car error) (cdr error))))
455 (if (epg-context-result-for context 'sign)
456 (setq micalg (epg-new-signature-digest-algorithm
457 (car (epg-context-result-for context 'sign)))))
458 (goto-char (point-min))
459 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
462 (insert (format "\tmicalg=%s; "
465 epg-digest-algorithm-alist))))))
466 (insert "protocol=\"application/pkcs7-signature\"\n")
467 (insert (format "\n--%s\n" boundary))
468 (goto-char (point-max))
469 (insert (format "\n--%s\n" boundary))
470 (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
471 Content-Transfer-Encoding: base64
472 Content-Disposition: attachment; filename=smime.p7s
475 (insert (base64-encode-string signature) "\n")
476 (goto-char (point-max))
477 (insert (format "--%s--\n" boundary))
478 (goto-char (point-max))))
480 (defun mml-smime-epg-encrypt (cont)
481 (let* ((inhibit-redisplay t)
482 (context (epg-make-context 'CMS))
483 (config (epg-configuration))
484 (recipients (message-options-get 'mml-smime-epg-recipients))
486 (sender (message-options-get 'message-sender))
487 (signer-names (or mml-smime-signers
488 (if (and mml-smime-sign-with-sender sender)
489 (list (concat "<" sender ">")))))
490 (boundary (mml-compute-boundary cont))
497 (or (epg-expand-group config recipient)
500 (or (message-options-get 'message-recipients)
501 (message-options-set 'message-recipients
502 (read-string "Recipients: ")))
503 "[ \f\t\n\r\v,]+"))))
504 (when mml-smime-encrypt-to-self
506 (error "Neither message sender nor mml-smime-signers are set"))
507 (setq recipients (nconc recipients signer-names)))
508 (if (eq mm-encrypt-option 'guided)
510 (epa-select-keys context "\
511 Select recipients for encryption.
512 If no one is selected, symmetric encryption will be performed. "
517 (setq recipient-key (mml-smime-epg-find-usable-key
518 (epg-list-keys context recipient)
520 (unless (or recipient-key
522 (format "No public key for %s; skip it? "
524 (error "No public key for %s" recipient))
528 (error "No recipient specified")))
529 (message-options-set 'mml-smime-epg-recipients recipients))
530 (if mml-smime-cache-passphrase
531 (epg-context-set-passphrase-callback
533 #'mml-smime-epg-passphrase-callback))
534 (condition-case error
536 (epg-encrypt-string context (buffer-string) recipients)
537 mml-smime-epg-secret-key-id-list nil)
539 (while mml-smime-epg-secret-key-id-list
540 (password-cache-remove (car mml-smime-epg-secret-key-id-list))
541 (setq mml-smime-epg-secret-key-id-list
542 (cdr mml-smime-epg-secret-key-id-list)))
543 (signal (car error) (cdr error))))
544 (delete-region (point-min) (point-max))
545 (goto-char (point-min))
547 Content-Type: application/pkcs7-mime;
548 smime-type=enveloped-data;
550 Content-Transfer-Encoding: base64
551 Content-Disposition: attachment; filename=smime.p7m
554 (insert (base64-encode-string cipher))
555 (goto-char (point-max))))
557 (defun mml-smime-epg-verify (handle ctl)
559 (let ((inhibit-redisplay t)
560 context plain signature-file part signature)
561 (when (or (null (setq part (mm-find-raw-part-by-type
562 ctl (or (mm-handle-multipart-ctl-parameter
564 "application/pkcs7-signature")
566 (null (setq signature (or (mm-find-part-by-type
568 "application/pkcs7-signature"
570 (mm-find-part-by-type
572 "application/x-pkcs7-signature"
574 (mm-set-handle-multipart-parameter
575 mm-security-handle 'gnus-info "Corrupted")
576 (throw 'error handle))
577 (setq part (mm-replace-in-string part "\n" "\r\n")
578 context (epg-make-context 'CMS))
579 (condition-case error
580 (setq plain (epg-verify-string context (mm-get-part signature) part))
582 (mm-set-handle-multipart-parameter
583 mm-security-handle 'gnus-info "Failed")
584 (if (eq (car error) 'quit)
585 (mm-set-handle-multipart-parameter
586 mm-security-handle 'gnus-details "Quit.")
587 (mm-set-handle-multipart-parameter
588 mm-security-handle 'gnus-details (format "%S" error)))
589 (throw 'error handle)))
590 (mm-set-handle-multipart-parameter
591 mm-security-handle 'gnus-info
592 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
595 (defun mml-smime-epg-verify-test (handle ctl)
600 ;;; mml-smime.el ends here