1 ;;; mml-smime.el --- S/MIME support for MML
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
6 ;; Author: Simon Josefsson <simon@josefsson.org>
7 ;; Keywords: Gnus, MIME, S/MIME, MML
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; For Emacs <22.2 and XEmacs.
30 (unless (fboundp 'declare-function
) (defmacro declare-function
(&rest r
))))
32 (eval-when-compile (require 'cl
))
37 (autoload 'message-narrow-to-headers
"message")
38 (autoload 'message-fetch-field
"message")
40 (defvar mml-smime-use
'openssl
)
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
54 mml-smime-epg-verify-test
)))
56 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
57 "If t, cache passphrase."
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'."
68 (defcustom mml-smime-signers nil
69 "A list of your own key ID which will be used to sign a message."
71 :type
'(repeat (string :tag
"Key ID")))
73 (defun mml-smime-sign (cont)
74 (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist
))))
77 (error "Cannot find sign function"))))
79 (defun mml-smime-encrypt (cont)
80 (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist
))))
83 (error "Cannot find encrypt function"))))
85 (defun mml-smime-sign-query ()
86 (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist
))))
90 (defun mml-smime-encrypt-query ()
91 (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist
))))
95 (defun mml-smime-verify (handle ctl
)
96 (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist
))))
98 (funcall func handle ctl
)
101 (defun mml-smime-verify-test (handle ctl
)
102 (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist
))))
104 (funcall func handle ctl
))))
106 (defun mml-smime-openssl-sign (cont)
107 (when (null smime-keys
)
108 (customize-variable 'smime-keys
)
109 (error "No S/MIME keys configured, use customize to add your key"))
110 (smime-sign-buffer (cdr (assq 'keyfile cont
)))
111 (goto-char (point-min))
112 (while (search-forward "\r\n" nil t
)
113 (replace-match "\n" t t
))
114 (goto-char (point-max)))
116 (defun mml-smime-openssl-encrypt (cont)
117 (let (certnames certfiles tmp file tmpfiles
)
118 ;; xxx tmp files are always an security issue
119 (while (setq tmp
(pop cont
))
120 (if (and (consp tmp
) (eq (car tmp
) 'certfile
))
121 (push (cdr tmp
) certnames
)))
122 (while (setq tmp
(pop certnames
))
123 (if (not (and (not (file-exists-p tmp
))
126 (setq file
(mm-make-temp-file (expand-file-name "mml."
128 (with-current-buffer tmp
129 (write-region (point-min) (point-max) file
))
130 (push file certfiles
)
131 (push file tmpfiles
)))
132 (if (smime-encrypt-buffer certfiles
)
134 (while (setq tmp
(pop tmpfiles
))
137 (while (setq tmp
(pop tmpfiles
))
140 (goto-char (point-max)))
142 (defvar gnus-extract-address-components
)
144 (defun mml-smime-openssl-sign-query ()
145 ;; query information (what certificate) from user when MML tag is
146 ;; added, for use later by the signing process
147 (when (null smime-keys
)
148 (customize-variable 'smime-keys
)
149 (error "No S/MIME keys configured, use customize to add your key"))
151 (if (= (length smime-keys
) 1)
153 (or (let ((from (cadr (funcall (if (boundp
154 'gnus-extract-address-components
)
155 gnus-extract-address-components
156 'mail-extract-address-components
)
159 (message-narrow-to-headers)
160 (message-fetch-field "from")))
162 (and from
(smime-get-key-by-email from
)))
163 (smime-get-key-by-email
164 (gnus-completing-read "Sign this part with what signature"
165 (mapcar 'car smime-keys
) nil nil nil
166 (and (listp (car-safe smime-keys
))
167 (caar smime-keys
))))))))
169 (defun mml-smime-get-file-cert ()
171 (list 'certfile
(read-file-name
172 "File with recipient's S/MIME certificate: "
173 smime-certificate-directory nil t
""))))
175 (defun mml-smime-get-dns-cert ()
176 ;; todo: deal with comma separated multiple recipients
177 (let (result who bad cert
)
180 (setq who
(read-from-minibuffer
181 (format "%sLookup certificate for: " (or bad
""))
182 (cadr (funcall (if (boundp
183 'gnus-extract-address-components
)
184 gnus-extract-address-components
185 'mail-extract-address-components
)
188 (message-narrow-to-headers)
189 (message-fetch-field "to")))
191 (if (setq cert
(smime-cert-by-dns who
))
192 (setq result
(list 'certfile
(buffer-name cert
)))
193 (setq bad
(format "`%s' not found. " who
))))
197 (defun mml-smime-get-ldap-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 (funcall gnus-extract-address-components
207 (message-narrow-to-headers)
208 (message-fetch-field "to")))
210 (if (setq cert
(smime-cert-by-ldap who
))
211 (setq result
(list 'certfile
(buffer-name cert
)))
212 (setq bad
(format "`%s' not found. " who
))))
216 (autoload 'gnus-completing-read
"gnus-util")
218 (defun mml-smime-openssl-encrypt-query ()
219 ;; todo: try dns/ldap automatically first, before prompting user
222 (ecase (read (gnus-completing-read
223 "Fetch certificate from"
224 '("dns" "ldap" "file") t nil nil
226 (dns (setq certs
(append certs
227 (mml-smime-get-dns-cert))))
228 (ldap (setq certs
(append certs
229 (mml-smime-get-ldap-cert))))
230 (file (setq certs
(append certs
231 (mml-smime-get-file-cert)))))
232 (setq done
(not (y-or-n-p "Add more recipients? "))))
235 (defun mml-smime-openssl-verify (handle ctl
)
237 (insert-buffer-substring (mm-handle-multipart-original-buffer ctl
))
238 (goto-char (point-min))
239 (insert (format "Content-Type: %s; " (mm-handle-media-type ctl
)))
240 (insert (format "protocol=\"%s\"; "
241 (mm-handle-multipart-ctl-parameter ctl
'protocol
)))
242 (insert (format "micalg=\"%s\"; "
243 (mm-handle-multipart-ctl-parameter ctl
'micalg
)))
244 (insert (format "boundary=\"%s\"\n\n"
245 (mm-handle-multipart-ctl-parameter ctl
'boundary
)))
246 (when (get-buffer smime-details-buffer
)
247 (kill-buffer smime-details-buffer
))
248 (let ((buf (current-buffer))
249 (good-signature (smime-noverify-buffer))
250 (good-certificate (and (or smime-CA-file smime-CA-directory
)
251 (smime-verify-buffer)))
252 addresses openssl-output
)
253 (setq openssl-output
(with-current-buffer smime-details-buffer
255 (if (not good-signature
)
257 ;; we couldn't verify message, fail with openssl output as message
258 (mm-set-handle-multipart-parameter
259 mm-security-handle
'gnus-info
"Failed")
260 (mm-set-handle-multipart-parameter
261 mm-security-handle
'gnus-details
262 (concat "OpenSSL failed to verify message integrity:\n"
263 "-------------------------------------------\n"
265 ;; verify mail addresses in mail against those in certificate
266 (when (and (smime-pkcs7-region (point-min) (point-max))
267 (smime-pkcs7-certificates-region (point-min) (point-max)))
269 (insert-buffer-substring buf
)
270 (goto-char (point-min))
271 (while (re-search-forward "-----END CERTIFICATE-----" nil t
)
272 (when (smime-pkcs7-email-region (point-min) (point))
273 (setq addresses
(append (smime-buffer-as-string-region
274 (point-min) (point)) addresses
)))
275 (delete-region (point-min) (point)))
276 (setq addresses
(mapcar 'downcase addresses
))))
277 (if (not (member (downcase (or (mm-handle-multipart-from ctl
) "")) addresses
))
278 (mm-set-handle-multipart-parameter
279 mm-security-handle
'gnus-info
"Sender address forged")
281 (mm-set-handle-multipart-parameter
282 mm-security-handle
'gnus-info
"Ok (sender authenticated)")
283 (mm-set-handle-multipart-parameter
284 mm-security-handle
'gnus-info
"Ok (sender not trusted)")))
285 (mm-set-handle-multipart-parameter
286 mm-security-handle
'gnus-details
287 (concat "Sender claimed to be: " (mm-handle-multipart-from ctl
) "\n"
289 (concat "Addresses in certificate: "
290 (mapconcat 'identity addresses
", "))
291 "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
294 "---------------\n" openssl-output
"\n"
295 "Certificate(s) inside S/MIME signature:\n"
296 "---------------------------------------\n"
297 (buffer-string) "\n")))))
300 (defun mml-smime-openssl-verify-test (handle ctl
)
301 smime-openssl-program
)
303 (defvar epg-user-id-alist
)
304 (defvar epg-digest-algorithm-alist
)
305 (defvar inhibit-redisplay
)
306 (defvar password-cache-expiry
)
309 (autoload 'epg-make-context
"epg")
310 (autoload 'epg-context-set-armor
"epg")
311 (autoload 'epg-context-set-signers
"epg")
312 (autoload 'epg-context-result-for
"epg")
313 (autoload 'epg-new-signature-digest-algorithm
"epg")
314 (autoload 'epg-verify-result-to-string
"epg")
315 (autoload 'epg-list-keys
"epg")
316 (autoload 'epg-decrypt-string
"epg")
317 (autoload 'epg-verify-string
"epg")
318 (autoload 'epg-sign-string
"epg")
319 (autoload 'epg-encrypt-string
"epg")
320 (autoload 'epg-passphrase-callback-function
"epg")
321 (autoload 'epg-context-set-passphrase-callback
"epg")
322 (autoload 'epg-configuration
"epg-config")
323 (autoload 'epg-expand-group
"epg-config")
324 (autoload 'epa-select-keys
"epa"))
326 (defvar mml-smime-epg-secret-key-id-list nil
)
328 (defun mml-smime-epg-passphrase-callback (context key-id ignore
)
330 (epg-passphrase-callback-function context key-id nil
)
335 "Passphrase for PIN: "
336 (if (setq entry
(assoc key-id epg-user-id-alist
))
337 (format "Passphrase for %s %s: " key-id
(cdr entry
))
338 (format "Passphrase for %s: " key-id
)))
343 (let ((password-cache-expiry mml-smime-passphrase-cache-expiry
))
344 (password-cache-add key-id passphrase
))
345 (setq mml-smime-epg-secret-key-id-list
346 (cons key-id mml-smime-epg-secret-key-id-list
))
347 (copy-sequence passphrase
)))))
349 (declare-function epg-key-sub-key-list
"ext:epg" (key))
350 (declare-function epg-sub-key-capability
"ext:epg" (sub-key))
351 (declare-function epg-sub-key-validity
"ext:epg" (sub-key))
353 (defun mml-smime-epg-find-usable-key (keys usage
)
356 (let ((pointer (epg-key-sub-key-list (car keys
))))
358 (if (and (memq usage
(epg-sub-key-capability (car pointer
)))
359 (not (memq (epg-sub-key-validity (car pointer
))
360 '(revoked expired
))))
361 (throw 'found
(car keys
)))
362 (setq pointer
(cdr pointer
))))
363 (setq keys
(cdr keys
)))))
365 (autoload 'mml-compute-boundary
"mml")
367 ;; We require mm-decode, which requires mm-bodies, which autoloads
368 ;; message-options-get (!).
369 (declare-function message-options-set
"message" (symbol value
))
371 (defun mml-smime-epg-sign (cont)
372 (let* ((inhibit-redisplay t
)
373 (context (epg-make-context 'CMS
))
374 (boundary (mml-compute-boundary cont
))
377 (or (message-options-get 'mml-smime-epg-signers
)
379 'mml-smime-epg-signers
380 (if (eq mm-sign-option
'guided
)
381 (epa-select-keys context
"\
382 Select keys for signing.
383 If no one is selected, default secret key is used. "
385 (if mml-smime-signers
388 (setq signer-key
(mml-smime-epg-find-usable-key
389 (epg-list-keys context signer t
)
391 (unless (or signer-key
393 (format "No secret key for %s; skip it? "
395 (error "No secret key for %s" signer
))
397 mml-smime-signers
))))))
399 (epg-context-set-signers context signers
)
400 (if mml-smime-cache-passphrase
401 (epg-context-set-passphrase-callback
403 #'mml-smime-epg-passphrase-callback
))
404 (condition-case error
405 (setq signature
(epg-sign-string context
406 (mm-replace-in-string (buffer-string)
409 mml-smime-epg-secret-key-id-list nil
)
411 (while mml-smime-epg-secret-key-id-list
412 (password-cache-remove (car mml-smime-epg-secret-key-id-list
))
413 (setq mml-smime-epg-secret-key-id-list
414 (cdr mml-smime-epg-secret-key-id-list
)))
415 (signal (car error
) (cdr error
))))
416 (if (epg-context-result-for context
'sign
)
417 (setq micalg
(epg-new-signature-digest-algorithm
418 (car (epg-context-result-for context
'sign
)))))
419 (goto-char (point-min))
420 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
423 (insert (format "\tmicalg=%s; "
426 epg-digest-algorithm-alist
))))))
427 (insert "protocol=\"application/pkcs7-signature\"\n")
428 (insert (format "\n--%s\n" boundary
))
429 (goto-char (point-max))
430 (insert (format "\n--%s\n" boundary
))
431 (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
432 Content-Transfer-Encoding: base64
433 Content-Disposition: attachment; filename=smime.p7s
436 (insert (base64-encode-string signature
) "\n")
437 (goto-char (point-max))
438 (insert (format "--%s--\n" boundary
))
439 (goto-char (point-max))))
441 (defun mml-smime-epg-encrypt (cont)
442 (let ((inhibit-redisplay t
)
443 (context (epg-make-context 'CMS
))
444 (config (epg-configuration))
445 (recipients (message-options-get 'mml-smime-epg-recipients
))
447 (boundary (mml-compute-boundary cont
))
454 (or (epg-expand-group config recipient
)
457 (or (message-options-get 'message-recipients
)
458 (message-options-set 'message-recipients
459 (read-string "Recipients: ")))
460 "[ \f\t\n\r\v,]+"))))
461 (if (eq mm-encrypt-option
'guided
)
463 (epa-select-keys context
"\
464 Select recipients for encryption.
465 If no one is selected, symmetric encryption will be performed. "
470 (setq recipient-key
(mml-smime-epg-find-usable-key
471 (epg-list-keys context recipient
)
473 (unless (or recipient-key
475 (format "No public key for %s; skip it? "
477 (error "No public key for %s" recipient
))
481 (error "No recipient specified")))
482 (message-options-set 'mml-smime-epg-recipients recipients
))
483 (if mml-smime-cache-passphrase
484 (epg-context-set-passphrase-callback
486 #'mml-smime-epg-passphrase-callback
))
487 (condition-case error
489 (epg-encrypt-string context
(buffer-string) recipients
)
490 mml-smime-epg-secret-key-id-list nil
)
492 (while mml-smime-epg-secret-key-id-list
493 (password-cache-remove (car mml-smime-epg-secret-key-id-list
))
494 (setq mml-smime-epg-secret-key-id-list
495 (cdr mml-smime-epg-secret-key-id-list
)))
496 (signal (car error
) (cdr error
))))
497 (delete-region (point-min) (point-max))
498 (goto-char (point-min))
500 Content-Type: application/pkcs7-mime;
501 smime-type=enveloped-data;
503 Content-Transfer-Encoding: base64
504 Content-Disposition: attachment; filename=smime.p7m
507 (insert (base64-encode-string cipher
))
508 (goto-char (point-max))))
510 (defun mml-smime-epg-verify (handle ctl
)
512 (let ((inhibit-redisplay t
)
513 context plain signature-file part signature
)
514 (when (or (null (setq part
(mm-find-raw-part-by-type
515 ctl
(or (mm-handle-multipart-ctl-parameter
517 "application/pkcs7-signature")
519 (null (setq signature
(or (mm-find-part-by-type
521 "application/pkcs7-signature"
523 (mm-find-part-by-type
525 "application/x-pkcs7-signature"
527 (mm-set-handle-multipart-parameter
528 mm-security-handle
'gnus-info
"Corrupted")
529 (throw 'error handle
))
530 (setq part
(mm-replace-in-string part
"\n" "\r\n" t
)
531 context
(epg-make-context 'CMS
))
532 (condition-case error
533 (setq plain
(epg-verify-string context
(mm-get-part signature
) part
))
535 (mm-set-handle-multipart-parameter
536 mm-security-handle
'gnus-info
"Failed")
537 (if (eq (car error
) 'quit
)
538 (mm-set-handle-multipart-parameter
539 mm-security-handle
'gnus-details
"Quit.")
540 (mm-set-handle-multipart-parameter
541 mm-security-handle
'gnus-details
(format "%S" error
)))
542 (throw 'error handle
)))
543 (mm-set-handle-multipart-parameter
544 mm-security-handle
'gnus-info
545 (epg-verify-result-to-string (epg-context-result-for context
'verify
)))
548 (defun mml-smime-epg-verify-test (handle ctl
)
553 ;;; mml-smime.el ends here