0bcc9c53c48f037b196b072a5ef49025148bea2b
[gnus] / lisp / mml-smime.el
1 ;;; mml-smime.el --- S/MIME support for MML
2
3 ;; Copyright (C) 2000-2015 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 (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."
38   :group 'mime-security
39   :type '(choice (const :tag "EPG" epg)
40                  (const :tag "OpenSSL" openssl)))
41
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
50          mml-smime-epg-encrypt
51          nil
52          nil
53          mml-smime-epg-verify
54          mml-smime-epg-verify-test)))
55
56 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
57   "If t, cache passphrase."
58   :group 'mime-security
59   :type 'boolean)
60
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'."
65   :group 'mime-security
66   :type 'integer)
67
68 (defcustom mml-smime-signers nil
69   "A list of your own key ID which will be used to sign a message."
70   :group 'mime-security
71   :type '(repeat (string :tag "Key ID")))
72
73 (defcustom mml-smime-sign-with-sender nil
74   "If t, use message sender so find a key to sign with."
75   :group 'mime-security
76   :version "24.4"
77   :type 'boolean)
78
79 (defcustom mml-smime-encrypt-to-self nil
80   "If t, add your own key ID to recipient list when encryption."
81   :group 'mime-security
82   :version "24.4"
83   :type 'boolean)
84
85 (defun mml-smime-sign (cont)
86   (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
87     (if func
88         (funcall func cont)
89       (error "Cannot find sign function"))))
90
91 (defun mml-smime-encrypt (cont)
92   (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
93     (if func
94         (funcall func cont)
95       (error "Cannot find encrypt function"))))
96
97 (defun mml-smime-sign-query ()
98   (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
99     (if func
100         (funcall func))))
101
102 (defun mml-smime-encrypt-query ()
103   (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
104     (if func
105         (funcall func))))
106
107 (defun mml-smime-verify (handle ctl)
108   (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
109     (if func
110         (funcall func handle ctl)
111       handle)))
112
113 (defun mml-smime-verify-test (handle ctl)
114   (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
115     (if func
116         (funcall func handle ctl))))
117
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)))
127
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))
136                     (get-buffer tmp)))
137           (push tmp certfiles)
138         (setq file (mm-make-temp-file (expand-file-name "mml."
139                                                         mm-tmp-directory)))
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)
145         (progn
146           (while (setq tmp (pop tmpfiles))
147             (delete-file tmp))
148           t)
149       (while (setq tmp (pop tmpfiles))
150         (delete-file tmp))
151       nil))
152   (goto-char (point-max)))
153
154 (defvar gnus-extract-address-components)
155
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"))
162   (list 'keyfile
163         (if (= (length smime-keys) 1)
164             (cadar smime-keys)
165           (or (let ((from (cadr (funcall (if (boundp
166                                               'gnus-extract-address-components)
167                                              gnus-extract-address-components
168                                            'mail-extract-address-components)
169                                          (or (save-excursion
170                                                (save-restriction
171                                                  (message-narrow-to-headers)
172                                                  (message-fetch-field "from")))
173                                              "")))))
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))))))))
180
181 (defun mml-smime-get-file-cert ()
182   (ignore-errors
183     (list 'certfile (read-file-name
184                      "File with recipient's S/MIME certificate: "
185                      smime-certificate-directory nil t ""))))
186
187 (defun mml-smime-get-dns-cert ()
188   ;; todo: deal with comma separated multiple recipients
189   (let (result who bad cert)
190     (condition-case ()
191         (while (not result)
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)
198                                     (or (save-excursion
199                                           (save-restriction
200                                             (message-narrow-to-headers)
201                                             (message-fetch-field "to")))
202                                         "")))))
203           (if (setq cert (smime-cert-by-dns who))
204               (setq result (list 'certfile (buffer-name cert)))
205             (setq bad (gnus-format-message "`%s' not found. " who))))
206       (quit))
207     result))
208
209 (defun mml-smime-get-ldap-cert ()
210   ;; todo: deal with comma separated multiple recipients
211   (let (result who bad cert)
212     (condition-case ()
213         (while (not result)
214           (setq who (read-from-minibuffer
215                      (format "%sLookup certificate for: " (or bad ""))
216                      (cadr (funcall gnus-extract-address-components
217                                     (or (save-excursion
218                                           (save-restriction
219                                             (message-narrow-to-headers)
220                                             (message-fetch-field "to")))
221                                         "")))))
222           (if (setq cert (smime-cert-by-ldap who))
223               (setq result (list 'certfile (buffer-name cert)))
224             (setq bad (gnus-format-message "`%s' not found. " who))))
225       (quit))
226     result))
227
228 (autoload 'gnus-completing-read "gnus-util")
229
230 (defun mml-smime-openssl-encrypt-query ()
231   ;; todo: try dns/ldap automatically first, before prompting user
232   (let (certs done)
233     (while (not done)
234       (ecase (read (gnus-completing-read
235                     "Fetch certificate from"
236                     '("dns" "ldap" "file") t nil nil
237                     "ldap"))
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? "))))
245     certs))
246
247 (defun mml-smime-openssl-verify (handle ctl)
248   (with-temp-buffer
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
266                              (buffer-string)))
267       (if (not good-signature)
268           (progn
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"
276                      openssl-output)))
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)))
280           (with-temp-buffer
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")
292           (if good-certificate
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"
300                  (if addresses
301                      (concat "Addresses in certificate: "
302                              (mapconcat 'identity addresses ", "))
303                    "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
304                  "\n" "\n"
305                  "OpenSSL output:\n"
306                  "---------------\n" openssl-output "\n"
307                  "Certificate(s) inside S/MIME signature:\n"
308                  "---------------------------------------\n"
309                  (buffer-string) "\n")))))
310   handle)
311
312 (defun mml-smime-openssl-verify-test (handle ctl)
313   smime-openssl-program)
314
315 (defvar epg-user-id-alist)
316 (defvar epg-digest-algorithm-alist)
317 (defvar inhibit-redisplay)
318 (defvar password-cache-expiry)
319
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))
339
340 (defvar mml-smime-epg-secret-key-id-list nil)
341
342 (defun mml-smime-epg-passphrase-callback (context key-id ignore)
343   (if (eq key-id 'SYM)
344       (epg-passphrase-callback-function context key-id nil)
345     (let* (entry
346            (passphrase
347             (password-read
348              (if (eq key-id 'PIN)
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)))
353              (if (eq key-id 'PIN)
354                  "PIN"
355                key-id))))
356       (when passphrase
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)))))
362
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)
366
367 (defun mml-smime-epg-find-usable-key (keys usage)
368   (catch 'found
369     (while keys
370       (let ((pointer (epg-key-sub-key-list (car keys))))
371         (while pointer
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)))))
378
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))
385         secret-key)
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)))))
391            usage)
392           (setq secret-key (car secret-keys)
393                 secret-keys nil)
394         (setq secret-keys (cdr secret-keys))))
395     secret-key))
396
397 (autoload 'mml-compute-boundary "mml")
398
399 ;; We require mm-decode, which requires mm-bodies, which autoloads
400 ;; message-options-get (!).
401 (declare-function message-options-set "message" (symbol value))
402
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 ">")))))
411          signer-key
412          (signers
413           (or (message-options-get 'mml-smime-epg-signers)
414               (message-options-set
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.  "
420                                     signer-names
421                                     t)
422                  (if (or sender mml-smime-signers)
423                      (delq nil
424                            (mapcar
425                             (lambda (signer)
426                               (setq signer-key
427                                     (mml-smime-epg-find-usable-secret-key
428                                      context signer 'sign))
429                               (unless (or signer-key
430                                           (y-or-n-p
431                                            (format
432                                             "No secret key for %s; skip it? "
433                                             signer)))
434                                 (error "No secret key for %s" signer))
435                               signer-key)
436                             signer-names)))))))
437          signature micalg)
438     (epg-context-set-signers context signers)
439     (if mml-smime-cache-passphrase
440         (epg-context-set-passphrase-callback
441          context
442          #'mml-smime-epg-passphrase-callback))
443     (condition-case error
444         (setq signature (epg-sign-string context
445                                          (mm-replace-in-string (buffer-string)
446                                                                "\n" "\r\n")
447                                          t)
448               mml-smime-epg-secret-key-id-list nil)
449       (error
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"
460                     boundary))
461     (if micalg
462         (insert (format "\tmicalg=%s; "
463                         (downcase
464                          (cdr (assq micalg
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
473
474 ")
475     (insert (base64-encode-string signature) "\n")
476     (goto-char (point-max))
477     (insert (format "--%s--\n" boundary))
478     (goto-char (point-max))))
479
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))
485          cipher signers
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))
491          recipient-key)
492     (unless recipients
493       (setq recipients
494             (apply #'nconc
495                    (mapcar
496                     (lambda (recipient)
497                       (or (epg-expand-group config recipient)
498                           (list recipient)))
499                     (split-string
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
505         (unless signer-names
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)
509           (setq recipients
510                 (epa-select-keys context "\
511 Select recipients for encryption.
512 If no one is selected, symmetric encryption will be performed.  "
513                                  recipients))
514         (setq recipients
515               (mapcar
516                (lambda (recipient)
517                  (setq recipient-key (mml-smime-epg-find-usable-key
518                                       (epg-list-keys context recipient)
519                                       'encrypt))
520                  (unless (or recipient-key
521                              (y-or-n-p
522                               (format "No public key for %s; skip it? "
523                                       recipient)))
524                    (error "No public key for %s" recipient))
525                  recipient-key)
526                recipients))
527         (unless recipients
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
532          context
533          #'mml-smime-epg-passphrase-callback))
534     (condition-case error
535         (setq cipher
536               (epg-encrypt-string context (buffer-string) recipients)
537               mml-smime-epg-secret-key-id-list nil)
538       (error
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))
546     (insert "\
547 Content-Type: application/pkcs7-mime;
548  smime-type=enveloped-data;
549  name=smime.p7m
550 Content-Transfer-Encoding: base64
551 Content-Disposition: attachment; filename=smime.p7m
552
553 ")
554     (insert (base64-encode-string cipher))
555     (goto-char (point-max))))
556
557 (defun mml-smime-epg-verify (handle ctl)
558   (catch 'error
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
563                                            ctl 'protocol)
564                                           "application/pkcs7-signature")
565                                   t)))
566                 (null (setq signature (or (mm-find-part-by-type
567                                            (cdr handle)
568                                            "application/pkcs7-signature"
569                                            nil t)
570                                           (mm-find-part-by-type
571                                            (cdr handle)
572                                            "application/x-pkcs7-signature"
573                                            nil t)))))
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))
581         (error
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)))
593       handle)))
594
595 (defun mml-smime-epg-verify-test (handle ctl)
596   t)
597
598 (provide 'mml-smime)
599
600 ;;; mml-smime.el ends here