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
(format "`%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
(format "`%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