1 ;;; mml-smime.el --- S/MIME support for MML
3 ;; Copyright (C) 2000-2016 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 ;; Prefer epg over openssl if it is available as epg uses GnuPG's gpgsm,
36 ;; which features full-fledged certificate management, while openssl requires
37 ;; major manual efforts for certificate revocation and expiry and has bugs
38 ;; as documented under man smime(1).
39 (ignore-errors (require 'epg))
41 (defcustom mml-smime-use (if (featurep 'epg) 'epg 'openssl)
42 "Whether to use OpenSSL or EasyPG (EPG) to handle S/MIME messages.
43 Defaults to EPG if it's available.
44 If you think about using OpenSSL, please read the BUGS section in the manual
45 for the `smime' command coming with OpenSSL first. EasyPG is recommended."
47 :type '(choice (const :tag "EPG" epg)
48 (const :tag "OpenSSL" openssl)))
50 (defvar mml-smime-function-alist
51 '((openssl mml-smime-openssl-sign
52 mml-smime-openssl-encrypt
53 mml-smime-openssl-sign-query
54 mml-smime-openssl-encrypt-query
55 mml-smime-openssl-verify
56 mml-smime-openssl-verify-test)
57 (epg mml-smime-epg-sign
62 mml-smime-epg-verify-test)))
64 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
65 "If t, cache passphrase."
68 (make-obsolete-variable 'mml-smime-cache-passphrase
69 'mml-secure-cache-passphrase
72 (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
73 "How many seconds the passphrase is cached.
74 Whether the passphrase is cached at all is controlled by
75 `mml-smime-cache-passphrase'."
78 (make-obsolete-variable 'mml-smime-passphrase-cache-expiry
79 'mml-secure-passphrase-cache-expiry
82 (defcustom mml-smime-signers nil
83 "A list of your own key ID which will be used to sign a message."
85 :type '(repeat (string :tag "Key ID")))
87 (defcustom mml-smime-sign-with-sender nil
88 "If t, use message sender so find a key to sign with."
93 (defcustom mml-smime-encrypt-to-self nil
94 "If t, add your own key ID to recipient list when encryption."
99 (defun mml-smime-sign (cont)
100 (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
103 (error "Cannot find sign function"))))
105 (defun mml-smime-encrypt (cont)
106 (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
109 (error "Cannot find encrypt function"))))
111 (defun mml-smime-sign-query ()
112 (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
116 (defun mml-smime-encrypt-query ()
117 (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
121 (defun mml-smime-verify (handle ctl)
122 (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
124 (funcall func handle ctl)
127 (defun mml-smime-verify-test (handle ctl)
128 (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
130 (funcall func handle ctl))))
132 (defun mml-smime-openssl-sign (cont)
133 (when (null smime-keys)
134 (customize-variable 'smime-keys)
135 (error "No S/MIME keys configured, use customize to add your key"))
136 (smime-sign-buffer (cdr (assq 'keyfile cont)))
137 (goto-char (point-min))
138 (while (search-forward "\r\n" nil t)
139 (replace-match "\n" t t))
140 (goto-char (point-max)))
142 (defun mml-smime-openssl-encrypt (cont)
143 (let (certnames certfiles tmp file tmpfiles)
144 ;; xxx tmp files are always an security issue
145 (while (setq tmp (pop cont))
146 (if (and (consp tmp) (eq (car tmp) 'certfile))
147 (push (cdr tmp) certnames)))
148 (while (setq tmp (pop certnames))
149 (if (not (and (not (file-exists-p tmp))
152 (setq file (make-temp-file (expand-file-name "mml." mm-tmp-directory)))
153 (with-current-buffer tmp
154 (write-region (point-min) (point-max) file))
155 (push file certfiles)
156 (push file tmpfiles)))
157 (if (smime-encrypt-buffer certfiles)
159 (while (setq tmp (pop tmpfiles))
162 (while (setq tmp (pop tmpfiles))
165 (goto-char (point-max)))
167 (defvar gnus-extract-address-components)
169 (defun mml-smime-openssl-sign-query ()
170 ;; query information (what certificate) from user when MML tag is
171 ;; added, for use later by the signing process
172 (when (null smime-keys)
173 (customize-variable 'smime-keys)
174 (error "No S/MIME keys configured, use customize to add your key"))
176 (if (= (length smime-keys) 1)
178 (or (let ((from (cadr (mail-extract-address-components
181 (message-narrow-to-headers)
182 (message-fetch-field "from")))
184 (and from (smime-get-key-by-email from)))
185 (smime-get-key-by-email
186 (gnus-completing-read "Sign this part with what signature"
187 (mapcar 'car smime-keys) nil nil nil
188 (and (listp (car-safe smime-keys))
189 (caar smime-keys))))))))
191 (defun mml-smime-get-file-cert ()
193 (list 'certfile (read-file-name
194 "File with recipient's S/MIME certificate: "
195 smime-certificate-directory nil t ""))))
197 (defun mml-smime-get-dns-cert ()
198 ;; todo: deal with comma separated multiple recipients
199 (let (result who bad cert)
202 (setq who (read-from-minibuffer
203 (format "%sLookup certificate for: " (or bad ""))
204 (cadr (mail-extract-address-components
207 (message-narrow-to-headers)
208 (message-fetch-field "to")))
210 (if (setq cert (smime-cert-by-dns who))
211 (setq result (list 'certfile (buffer-name cert)))
212 (setq bad (format-message "`%s' not found. " who))))
216 (defun mml-smime-get-ldap-cert ()
217 ;; todo: deal with comma separated multiple recipients
218 (let (result who bad cert)
221 (setq who (read-from-minibuffer
222 (format "%sLookup certificate for: " (or bad ""))
223 (cadr (funcall gnus-extract-address-components
226 (message-narrow-to-headers)
227 (message-fetch-field "to")))
229 (if (setq cert (smime-cert-by-ldap who))
230 (setq result (list 'certfile (buffer-name cert)))
231 (setq bad (format-message "`%s' not found. " who))))
235 (autoload 'gnus-completing-read "gnus-util")
237 (defun mml-smime-openssl-encrypt-query ()
238 ;; todo: try dns/ldap automatically first, before prompting user
241 (ecase (read (gnus-completing-read
242 "Fetch certificate from"
243 '("dns" "ldap" "file") t nil nil
245 (dns (setq certs (append certs
246 (mml-smime-get-dns-cert))))
247 (ldap (setq certs (append certs
248 (mml-smime-get-ldap-cert))))
249 (file (setq certs (append certs
250 (mml-smime-get-file-cert)))))
251 (setq done (not (y-or-n-p "Add more recipients? "))))
254 (defun mml-smime-openssl-verify (handle ctl)
256 (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
257 (goto-char (point-min))
258 (insert (format "Content-Type: %s; " (mm-handle-media-type ctl)))
259 (insert (format "protocol=\"%s\"; "
260 (mm-handle-multipart-ctl-parameter ctl 'protocol)))
261 (insert (format "micalg=\"%s\"; "
262 (mm-handle-multipart-ctl-parameter ctl 'micalg)))
263 (insert (format "boundary=\"%s\"\n\n"
264 (mm-handle-multipart-ctl-parameter ctl 'boundary)))
265 (when (get-buffer smime-details-buffer)
266 (kill-buffer smime-details-buffer))
267 (let ((buf (current-buffer))
268 (good-signature (smime-noverify-buffer))
269 (good-certificate (and (or smime-CA-file smime-CA-directory)
270 (smime-verify-buffer)))
271 addresses openssl-output)
272 (setq openssl-output (with-current-buffer smime-details-buffer
274 (if (not good-signature)
276 ;; we couldn't verify message, fail with openssl output as message
277 (mm-set-handle-multipart-parameter
278 mm-security-handle 'gnus-info "Failed")
279 (mm-set-handle-multipart-parameter
280 mm-security-handle 'gnus-details
281 (concat "OpenSSL failed to verify message integrity:\n"
282 "-------------------------------------------\n"
284 ;; verify mail addresses in mail against those in certificate
285 (when (and (smime-pkcs7-region (point-min) (point-max))
286 (smime-pkcs7-certificates-region (point-min) (point-max)))
288 (insert-buffer-substring buf)
289 (goto-char (point-min))
290 (while (re-search-forward "-----END CERTIFICATE-----" nil t)
291 (when (smime-pkcs7-email-region (point-min) (point))
292 (setq addresses (append (smime-buffer-as-string-region
293 (point-min) (point)) addresses)))
294 (delete-region (point-min) (point)))
295 (setq addresses (mapcar 'downcase addresses))))
296 (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses))
297 (mm-set-handle-multipart-parameter
298 mm-security-handle 'gnus-info "Sender address forged")
300 (mm-set-handle-multipart-parameter
301 mm-security-handle 'gnus-info "Ok (sender authenticated)")
302 (mm-set-handle-multipart-parameter
303 mm-security-handle 'gnus-info "Ok (sender not trusted)")))
304 (mm-set-handle-multipart-parameter
305 mm-security-handle 'gnus-details
306 (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
308 (concat "Addresses in certificate: "
309 (mapconcat 'identity addresses ", "))
310 "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
313 "---------------\n" openssl-output "\n"
314 "Certificate(s) inside S/MIME signature:\n"
315 "---------------------------------------\n"
316 (buffer-string) "\n")))))
319 (defun mml-smime-openssl-verify-test (handle ctl)
320 smime-openssl-program)
322 (defvar epg-user-id-alist)
323 (defvar epg-digest-algorithm-alist)
324 (defvar inhibit-redisplay)
325 (defvar password-cache-expiry)
328 (autoload 'epg-make-context "epg")
329 (autoload 'epg-context-set-armor "epg")
330 (autoload 'epg-context-set-signers "epg")
331 (autoload 'epg-context-result-for "epg")
332 (autoload 'epg-new-signature-digest-algorithm "epg")
333 (autoload 'epg-verify-result-to-string "epg")
334 (autoload 'epg-list-keys "epg")
335 (autoload 'epg-decrypt-string "epg")
336 (autoload 'epg-verify-string "epg")
337 (autoload 'epg-sign-string "epg")
338 (autoload 'epg-encrypt-string "epg")
339 (autoload 'epg-passphrase-callback-function "epg")
340 (autoload 'epg-context-set-passphrase-callback "epg")
341 (autoload 'epg-sub-key-fingerprint "epg")
342 (autoload 'epg-configuration "epg-config")
343 (autoload 'epg-expand-group "epg-config")
344 (autoload 'epa-select-keys "epa"))
346 (declare-function epg-key-sub-key-list "epg" (key) t)
347 (declare-function epg-sub-key-capability "epg" (sub-key) t)
348 (declare-function epg-sub-key-validity "epg" (sub-key) t)
350 (autoload 'mml-compute-boundary "mml")
352 ;; We require mm-decode, which requires mm-bodies, which autoloads
353 ;; message-options-get (!).
354 (declare-function message-options-set "message" (symbol value))
356 (defun mml-smime-epg-sign (cont)
357 (let ((inhibit-redisplay t)
358 (boundary (mml-compute-boundary cont)))
359 (goto-char (point-min))
360 (let* ((pair (mml-secure-epg-sign 'CMS cont))
361 (signature (car pair))
363 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
366 (insert (format "\tmicalg=%s; "
369 epg-digest-algorithm-alist))))))
370 (insert "protocol=\"application/pkcs7-signature\"\n")
371 (insert (format "\n--%s\n" boundary))
372 (goto-char (point-max))
373 (insert (format "\n--%s\n" boundary))
374 (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
375 Content-Transfer-Encoding: base64
376 Content-Disposition: attachment; filename=smime.p7s
379 (insert (base64-encode-string signature) "\n")
380 (goto-char (point-max))
381 (insert (format "--%s--\n" boundary))
382 (goto-char (point-max)))))
384 (defun mml-smime-epg-encrypt (cont)
385 (let* ((inhibit-redisplay t)
386 (boundary (mml-compute-boundary cont))
387 (cipher (mml-secure-epg-encrypt 'CMS cont)))
388 (delete-region (point-min) (point-max))
389 (goto-char (point-min))
391 Content-Type: application/pkcs7-mime;
392 smime-type=enveloped-data;
394 Content-Transfer-Encoding: base64
395 Content-Disposition: attachment; filename=smime.p7m
398 (insert (base64-encode-string cipher))
399 (goto-char (point-max))))
401 (defun mml-smime-epg-verify (handle ctl)
403 (let ((inhibit-redisplay t)
404 context plain signature-file part signature)
405 (when (or (null (setq part (mm-find-raw-part-by-type
406 ctl (or (mm-handle-multipart-ctl-parameter
408 "application/pkcs7-signature")
410 (null (setq signature (or (mm-find-part-by-type
412 "application/pkcs7-signature"
414 (mm-find-part-by-type
416 "application/x-pkcs7-signature"
418 (mm-set-handle-multipart-parameter
419 mm-security-handle 'gnus-info "Corrupted")
420 (throw 'error handle))
421 (setq part (replace-regexp-in-string "\n" "\r\n" part)
422 context (epg-make-context 'CMS))
423 (condition-case error
424 (setq plain (epg-verify-string context (mm-get-part signature) part))
426 (mm-set-handle-multipart-parameter
427 mm-security-handle 'gnus-info "Failed")
428 (if (eq (car error) 'quit)
429 (mm-set-handle-multipart-parameter
430 mm-security-handle 'gnus-details "Quit.")
431 (mm-set-handle-multipart-parameter
432 mm-security-handle 'gnus-details (format "%S" error)))
433 (throw 'error handle)))
434 (mm-set-handle-multipart-parameter
435 mm-security-handle 'gnus-info
436 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
439 (defun mml-smime-epg-verify-test (handle ctl)
444 ;;; mml-smime.el ends here