1 ;;; mml-smime.el --- S/MIME support for MML
3 ;; Copyright (C) 2000-2017 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