b9f4a542f0edfa8f5426fd9f866cfde71b618f11
[gnus] / lisp / mml-smime.el
1 ;;; mml-smime.el --- S/MIME support for MML
2
3 ;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
4
5 ;; Author: Simon Josefsson <simon@josefsson.org>
6 ;; Keywords: Gnus, MIME, S/MIME, MML
7
8 ;; This file is part of GNU Emacs.
9
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.
14
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.
19
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/>.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (eval-when-compile (require 'cl))
28
29 (require 'smime)
30 (require 'mm-decode)
31 (require 'mml-sec)
32 (autoload 'message-narrow-to-headers "message")
33 (autoload 'message-fetch-field "message")
34
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))
40
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."
46   :group 'mime-security
47   :type '(choice (const :tag "EPG" epg)
48                  (const :tag "OpenSSL" openssl)))
49
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
58          mml-smime-epg-encrypt
59          nil
60          nil
61          mml-smime-epg-verify
62          mml-smime-epg-verify-test)))
63
64 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
65   "If t, cache passphrase."
66   :group 'mime-security
67   :type 'boolean)
68 (make-obsolete-variable 'mml-smime-cache-passphrase
69                         'mml-secure-cache-passphrase
70                         "25.0.50")
71
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'."
76   :group 'mime-security
77   :type 'integer)
78 (make-obsolete-variable 'mml-smime-passphrase-cache-expiry
79                         'mml-secure-passphrase-cache-expiry
80                         "25.0.50")
81
82 (defcustom mml-smime-signers nil
83   "A list of your own key ID which will be used to sign a message."
84   :group 'mime-security
85   :type '(repeat (string :tag "Key ID")))
86
87 (defcustom mml-smime-sign-with-sender nil
88   "If t, use message sender so find a key to sign with."
89   :group 'mime-security
90   :version "24.4"
91   :type 'boolean)
92
93 (defcustom mml-smime-encrypt-to-self nil
94   "If t, add your own key ID to recipient list when encryption."
95   :group 'mime-security
96   :version "24.4"
97   :type 'boolean)
98
99 (defun mml-smime-sign (cont)
100   (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
101     (if func
102         (funcall func cont)
103       (error "Cannot find sign function"))))
104
105 (defun mml-smime-encrypt (cont)
106   (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
107     (if func
108         (funcall func cont)
109       (error "Cannot find encrypt function"))))
110
111 (defun mml-smime-sign-query ()
112   (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
113     (if func
114         (funcall func))))
115
116 (defun mml-smime-encrypt-query ()
117   (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
118     (if func
119         (funcall func))))
120
121 (defun mml-smime-verify (handle ctl)
122   (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
123     (if func
124         (funcall func handle ctl)
125       handle)))
126
127 (defun mml-smime-verify-test (handle ctl)
128   (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
129     (if func
130         (funcall func handle ctl))))
131
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)))
141
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))
150                     (get-buffer tmp)))
151           (push tmp certfiles)
152         (setq file (mm-make-temp-file (expand-file-name "mml."
153                                                         mm-tmp-directory)))
154         (with-current-buffer tmp
155           (write-region (point-min) (point-max) file))
156         (push file certfiles)
157         (push file tmpfiles)))
158     (if (smime-encrypt-buffer certfiles)
159         (progn
160           (while (setq tmp (pop tmpfiles))
161             (delete-file tmp))
162           t)
163       (while (setq tmp (pop tmpfiles))
164         (delete-file tmp))
165       nil))
166   (goto-char (point-max)))
167
168 (defvar gnus-extract-address-components)
169
170 (defun mml-smime-openssl-sign-query ()
171   ;; query information (what certificate) from user when MML tag is
172   ;; added, for use later by the signing process
173   (when (null smime-keys)
174     (customize-variable 'smime-keys)
175     (error "No S/MIME keys configured, use customize to add your key"))
176   (list 'keyfile
177         (if (= (length smime-keys) 1)
178             (cadar smime-keys)
179           (or (let ((from (cadr (funcall (if (boundp
180                                               'gnus-extract-address-components)
181                                              gnus-extract-address-components
182                                            'mail-extract-address-components)
183                                          (or (save-excursion
184                                                (save-restriction
185                                                  (message-narrow-to-headers)
186                                                  (message-fetch-field "from")))
187                                              "")))))
188                 (and from (smime-get-key-by-email from)))
189               (smime-get-key-by-email
190                (gnus-completing-read "Sign this part with what signature"
191                                      (mapcar 'car smime-keys) nil nil nil
192                                      (and (listp (car-safe smime-keys))
193                                           (caar smime-keys))))))))
194
195 (defun mml-smime-get-file-cert ()
196   (ignore-errors
197     (list 'certfile (read-file-name
198                      "File with recipient's S/MIME certificate: "
199                      smime-certificate-directory nil t ""))))
200
201 (defun mml-smime-get-dns-cert ()
202   ;; todo: deal with comma separated multiple recipients
203   (let (result who bad cert)
204     (condition-case ()
205         (while (not result)
206           (setq who (read-from-minibuffer
207                      (format "%sLookup certificate for: " (or bad ""))
208                      (cadr (funcall (if (boundp
209                                          'gnus-extract-address-components)
210                                         gnus-extract-address-components
211                                       'mail-extract-address-components)
212                                     (or (save-excursion
213                                           (save-restriction
214                                             (message-narrow-to-headers)
215                                             (message-fetch-field "to")))
216                                         "")))))
217           (if (setq cert (smime-cert-by-dns who))
218               (setq result (list 'certfile (buffer-name cert)))
219             (setq bad (format "`%s' not found. " who))))
220       (quit))
221     result))
222
223 (defun mml-smime-get-ldap-cert ()
224   ;; todo: deal with comma separated multiple recipients
225   (let (result who bad cert)
226     (condition-case ()
227         (while (not result)
228           (setq who (read-from-minibuffer
229                      (format "%sLookup certificate for: " (or bad ""))
230                      (cadr (funcall gnus-extract-address-components
231                                     (or (save-excursion
232                                           (save-restriction
233                                             (message-narrow-to-headers)
234                                             (message-fetch-field "to")))
235                                         "")))))
236           (if (setq cert (smime-cert-by-ldap who))
237               (setq result (list 'certfile (buffer-name cert)))
238             (setq bad (format "`%s' not found. " who))))
239       (quit))
240     result))
241
242 (autoload 'gnus-completing-read "gnus-util")
243
244 (defun mml-smime-openssl-encrypt-query ()
245   ;; todo: try dns/ldap automatically first, before prompting user
246   (let (certs done)
247     (while (not done)
248       (ecase (read (gnus-completing-read
249                     "Fetch certificate from"
250                     '("dns" "ldap" "file") t nil nil
251                     "ldap"))
252         (dns (setq certs (append certs
253                                  (mml-smime-get-dns-cert))))
254         (ldap (setq certs (append certs
255                                   (mml-smime-get-ldap-cert))))
256         (file (setq certs (append certs
257                                   (mml-smime-get-file-cert)))))
258       (setq done (not (y-or-n-p "Add more recipients? "))))
259     certs))
260
261 (defun mml-smime-openssl-verify (handle ctl)
262   (with-temp-buffer
263     (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
264     (goto-char (point-min))
265     (insert (format "Content-Type: %s; " (mm-handle-media-type ctl)))
266     (insert (format "protocol=\"%s\"; "
267                     (mm-handle-multipart-ctl-parameter ctl 'protocol)))
268     (insert (format "micalg=\"%s\"; "
269                     (mm-handle-multipart-ctl-parameter ctl 'micalg)))
270     (insert (format "boundary=\"%s\"\n\n"
271                     (mm-handle-multipart-ctl-parameter ctl 'boundary)))
272     (when (get-buffer smime-details-buffer)
273       (kill-buffer smime-details-buffer))
274     (let ((buf (current-buffer))
275           (good-signature (smime-noverify-buffer))
276           (good-certificate (and (or smime-CA-file smime-CA-directory)
277                                  (smime-verify-buffer)))
278           addresses openssl-output)
279       (setq openssl-output (with-current-buffer smime-details-buffer
280                              (buffer-string)))
281       (if (not good-signature)
282           (progn
283             ;; we couldn't verify message, fail with openssl output as message
284             (mm-set-handle-multipart-parameter
285              mm-security-handle 'gnus-info "Failed")
286             (mm-set-handle-multipart-parameter
287              mm-security-handle 'gnus-details
288              (concat "OpenSSL failed to verify message integrity:\n"
289                      "-------------------------------------------\n"
290                      openssl-output)))
291         ;; verify mail addresses in mail against those in certificate
292         (when (and (smime-pkcs7-region (point-min) (point-max))
293                    (smime-pkcs7-certificates-region (point-min) (point-max)))
294           (with-temp-buffer
295             (insert-buffer-substring buf)
296             (goto-char (point-min))
297             (while (re-search-forward "-----END CERTIFICATE-----" nil t)
298               (when (smime-pkcs7-email-region (point-min) (point))
299                 (setq addresses (append (smime-buffer-as-string-region
300                                          (point-min) (point)) addresses)))
301               (delete-region (point-min) (point)))
302             (setq addresses (mapcar 'downcase addresses))))
303         (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses))
304             (mm-set-handle-multipart-parameter
305              mm-security-handle 'gnus-info "Sender address forged")
306           (if good-certificate
307               (mm-set-handle-multipart-parameter
308                mm-security-handle 'gnus-info "Ok (sender authenticated)")
309             (mm-set-handle-multipart-parameter
310              mm-security-handle 'gnus-info "Ok (sender not trusted)")))
311         (mm-set-handle-multipart-parameter
312          mm-security-handle 'gnus-details
313          (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
314                  (if addresses
315                      (concat "Addresses in certificate: "
316                              (mapconcat 'identity addresses ", "))
317                    "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
318                  "\n" "\n"
319                  "OpenSSL output:\n"
320                  "---------------\n" openssl-output "\n"
321                  "Certificate(s) inside S/MIME signature:\n"
322                  "---------------------------------------\n"
323                  (buffer-string) "\n")))))
324   handle)
325
326 (defun mml-smime-openssl-verify-test (handle ctl)
327   smime-openssl-program)
328
329 (defvar epg-user-id-alist)
330 (defvar epg-digest-algorithm-alist)
331 (defvar inhibit-redisplay)
332 (defvar password-cache-expiry)
333
334 (eval-when-compile
335   (autoload 'epg-make-context "epg")
336   (autoload 'epg-context-set-armor "epg")
337   (autoload 'epg-context-set-signers "epg")
338   (autoload 'epg-context-result-for "epg")
339   (autoload 'epg-new-signature-digest-algorithm "epg")
340   (autoload 'epg-verify-result-to-string "epg")
341   (autoload 'epg-list-keys "epg")
342   (autoload 'epg-decrypt-string "epg")
343   (autoload 'epg-verify-string "epg")
344   (autoload 'epg-sign-string "epg")
345   (autoload 'epg-encrypt-string "epg")
346   (autoload 'epg-passphrase-callback-function "epg")
347   (autoload 'epg-context-set-passphrase-callback "epg")
348   (autoload 'epg-sub-key-fingerprint "epg")
349   (autoload 'epg-configuration "epg-config")
350   (autoload 'epg-expand-group "epg-config")
351   (autoload 'epa-select-keys "epa"))
352
353 (declare-function epg-key-sub-key-list   "ext:epg" (key))
354 (declare-function epg-sub-key-capability "ext:epg" (sub-key))
355 (declare-function epg-sub-key-validity   "ext:epg" (sub-key))
356
357 (autoload 'mml-compute-boundary "mml")
358
359 ;; We require mm-decode, which requires mm-bodies, which autoloads
360 ;; message-options-get (!).
361 (declare-function message-options-set "message" (symbol value))
362
363 (defun mml-smime-epg-sign (cont)
364   (let ((inhibit-redisplay t)
365         (boundary (mml-compute-boundary cont)))
366     (goto-char (point-min))
367     (let* ((pair (mml-secure-epg-sign 'CMS cont))
368            (signature (car pair))
369            (micalg (cdr pair)))
370       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
371                       boundary))
372       (if micalg
373           (insert (format "\tmicalg=%s; "
374                           (downcase
375                            (cdr (assq micalg
376                                       epg-digest-algorithm-alist))))))
377       (insert "protocol=\"application/pkcs7-signature\"\n")
378       (insert (format "\n--%s\n" boundary))
379       (goto-char (point-max))
380       (insert (format "\n--%s\n" boundary))
381       (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
382 Content-Transfer-Encoding: base64
383 Content-Disposition: attachment; filename=smime.p7s
384
385 ")
386       (insert (base64-encode-string signature) "\n")
387       (goto-char (point-max))
388       (insert (format "--%s--\n" boundary))
389       (goto-char (point-max)))))
390
391 (defun mml-smime-epg-encrypt (cont)
392   (let* ((inhibit-redisplay t)
393          (boundary (mml-compute-boundary cont))
394          (cipher (mml-secure-epg-encrypt 'CMS cont)))
395     (delete-region (point-min) (point-max))
396     (goto-char (point-min))
397     (insert "\
398 Content-Type: application/pkcs7-mime;
399  smime-type=enveloped-data;
400  name=smime.p7m
401 Content-Transfer-Encoding: base64
402 Content-Disposition: attachment; filename=smime.p7m
403
404 ")
405     (insert (base64-encode-string cipher))
406     (goto-char (point-max))))
407
408 (defun mml-smime-epg-verify (handle ctl)
409   (catch 'error
410     (let ((inhibit-redisplay t)
411           context plain signature-file part signature)
412       (when (or (null (setq part (mm-find-raw-part-by-type
413                                   ctl (or (mm-handle-multipart-ctl-parameter
414                                            ctl 'protocol)
415                                           "application/pkcs7-signature")
416                                   t)))
417                 (null (setq signature (or (mm-find-part-by-type
418                                            (cdr handle)
419                                            "application/pkcs7-signature"
420                                            nil t)
421                                           (mm-find-part-by-type
422                                            (cdr handle)
423                                            "application/x-pkcs7-signature"
424                                            nil t)))))
425         (mm-set-handle-multipart-parameter
426          mm-security-handle 'gnus-info "Corrupted")
427         (throw 'error handle))
428       (setq part (mm-replace-in-string part "\n" "\r\n")
429             context (epg-make-context 'CMS))
430       (condition-case error
431           (setq plain (epg-verify-string context (mm-get-part signature) part))
432         (error
433          (mm-set-handle-multipart-parameter
434           mm-security-handle 'gnus-info "Failed")
435          (if (eq (car error) 'quit)
436              (mm-set-handle-multipart-parameter
437               mm-security-handle 'gnus-details "Quit.")
438            (mm-set-handle-multipart-parameter
439             mm-security-handle 'gnus-details (format "%S" error)))
440          (throw 'error handle)))
441       (mm-set-handle-multipart-parameter
442        mm-security-handle 'gnus-info
443        (epg-verify-result-to-string (epg-context-result-for context 'verify)))
444       handle)))
445
446 (defun mml-smime-epg-verify-test (handle ctl)
447   t)
448
449 (provide 'mml-smime)
450
451 ;;; mml-smime.el ends here