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 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).
41 (defcustom mml-smime-use 'epg
42 "Whether to use OpenSSL or EasyPG (EPG) to handle S/MIME messages.
43 If you're thinking about using OpenSSL, please first read the BUGS section
44 in the manual for the `smime' command that comes with OpenSSL.
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 (defun mml-smime-epg-sign (cont)
353 (let ((inhibit-redisplay t)
354 (boundary (mml-compute-boundary cont)))
355 (goto-char (point-min))
356 (let* ((pair (mml-secure-epg-sign 'CMS cont))
357 (signature (car pair))
359 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
362 (insert (format "\tmicalg=%s; "
365 epg-digest-algorithm-alist))))))
366 (insert "protocol=\"application/pkcs7-signature\"\n")
367 (insert (format "\n--%s\n" boundary))
368 (goto-char (point-max))
369 (insert (format "\n--%s\n" boundary))
370 (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
371 Content-Transfer-Encoding: base64
372 Content-Disposition: attachment; filename=smime.p7s
375 (insert (base64-encode-string signature) "\n")
376 (goto-char (point-max))
377 (insert (format "--%s--\n" boundary))
378 (goto-char (point-max)))))
380 (defun mml-smime-epg-encrypt (cont)
381 (let* ((inhibit-redisplay t)
382 (boundary (mml-compute-boundary cont))
383 (cipher (mml-secure-epg-encrypt 'CMS cont)))
384 (delete-region (point-min) (point-max))
385 (goto-char (point-min))
387 Content-Type: application/pkcs7-mime;
388 smime-type=enveloped-data;
390 Content-Transfer-Encoding: base64
391 Content-Disposition: attachment; filename=smime.p7m
394 (insert (base64-encode-string cipher))
395 (goto-char (point-max))))
397 (defun mml-smime-epg-verify (handle ctl)
399 (let ((inhibit-redisplay t)
400 context plain signature-file part signature)
401 (when (or (null (setq part (mm-find-raw-part-by-type
402 ctl (or (mm-handle-multipart-ctl-parameter
404 "application/pkcs7-signature")
406 (null (setq signature (or (mm-find-part-by-type
408 "application/pkcs7-signature"
410 (mm-find-part-by-type
412 "application/x-pkcs7-signature"
414 (mm-set-handle-multipart-parameter
415 mm-security-handle 'gnus-info "Corrupted")
416 (throw 'error handle))
417 (setq part (replace-regexp-in-string "\n" "\r\n" part)
418 context (epg-make-context 'CMS))
419 (condition-case error
420 (setq plain (epg-verify-string context (mm-get-part signature) part))
422 (mm-set-handle-multipart-parameter
423 mm-security-handle 'gnus-info "Failed")
424 (if (eq (car error) 'quit)
425 (mm-set-handle-multipart-parameter
426 mm-security-handle 'gnus-details "Quit.")
427 (mm-set-handle-multipart-parameter
428 mm-security-handle 'gnus-details (format "%S" error)))
429 (throw 'error handle)))
430 (mm-set-handle-multipart-parameter
431 mm-security-handle 'gnus-info
432 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
435 (defun mml-smime-epg-verify-test (handle ctl)
440 ;;; mml-smime.el ends here