1 ;;; mml-smime.el --- S/MIME support for MML
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007 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
13 ;; by the Free Software Foundation; either version 2, or (at your
14 ;; option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
30 (eval-when-compile (require 'cl
))
35 (autoload 'message-narrow-to-headers
"message")
36 (autoload 'message-fetch-field
"message")
38 (defvar mml-smime-use
'openssl
)
40 (defvar mml-smime-function-alist
41 '((openssl mml-smime-openssl-sign
42 mml-smime-openssl-encrypt
43 mml-smime-openssl-sign-query
44 mml-smime-openssl-encrypt-query
45 mml-smime-openssl-verify
46 mml-smime-openssl-verify-test
)
47 (epg mml-smime-epg-sign
52 mml-smime-epg-verify-test
)))
54 (defcustom mml-smime-verbose mml-secure-verbose
55 "If non-nil, ask the user about the current operation more verbosely."
59 (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
60 "If t, cache passphrase."
64 (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
65 "How many seconds the passphrase is cached.
66 Whether the passphrase is cached at all is controlled by
67 `mml-smime-cache-passphrase'."
71 (defcustom mml-smime-signers nil
72 "A list of your own key ID which will be used to sign a message."
74 :type
'(repeat (string :tag
"Key ID")))
76 (defun mml-smime-sign (cont)
77 (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist
))))
80 (error "Cannot find sign function"))))
82 (defun mml-smime-encrypt (cont)
83 (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist
))))
86 (error "Cannot find encrypt function"))))
88 (defun mml-smime-sign-query ()
89 (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist
))))
93 (defun mml-smime-encrypt-query ()
94 (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist
))))
98 (defun mml-smime-verify (handle ctl
)
99 (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist
))))
101 (funcall func handle ctl
)
104 (defun mml-smime-verify-test (handle ctl
)
105 (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist
))))
107 (funcall func handle ctl
))))
109 (defun mml-smime-openssl-sign (cont)
110 (when (null smime-keys
)
111 (customize-variable 'smime-keys
)
112 (error "No S/MIME keys configured, use customize to add your key"))
113 (smime-sign-buffer (cdr (assq 'keyfile cont
)))
114 (goto-char (point-min))
115 (while (search-forward "\r\n" nil t
)
116 (replace-match "\n" t t
))
117 (goto-char (point-max)))
119 (defun mml-smime-openssl-encrypt (cont)
120 (let (certnames certfiles tmp file tmpfiles
)
121 ;; xxx tmp files are always an security issue
122 (while (setq tmp
(pop cont
))
123 (if (and (consp tmp
) (eq (car tmp
) 'certfile
))
124 (push (cdr tmp
) certnames
)))
125 (while (setq tmp
(pop certnames
))
126 (if (not (and (not (file-exists-p tmp
))
129 (setq file
(mm-make-temp-file (expand-file-name "mml."
131 (with-current-buffer tmp
132 (write-region (point-min) (point-max) file
))
133 (push file certfiles
)
134 (push file tmpfiles
)))
135 (if (smime-encrypt-buffer certfiles
)
137 (while (setq tmp
(pop tmpfiles
))
140 (while (setq tmp
(pop tmpfiles
))
143 (goto-char (point-max)))
145 (defun mml-smime-openssl-sign-query ()
146 ;; query information (what certificate) from user when MML tag is
147 ;; added, for use later by the signing process
148 (when (null smime-keys
)
149 (customize-variable 'smime-keys
)
150 (error "No S/MIME keys configured, use customize to add your key"))
152 (if (= (length smime-keys
) 1)
154 (or (let ((from (cadr (funcall (if (boundp
155 'gnus-extract-address-components
)
156 gnus-extract-address-components
157 'mail-extract-address-components
)
160 (message-narrow-to-headers)
161 (message-fetch-field "from")))
163 (and from
(smime-get-key-by-email from
)))
164 (smime-get-key-by-email
165 (completing-read "Sign this part with what signature? "
167 (and (listp (car-safe smime-keys
))
168 (caar smime-keys
))))))))
170 (defun mml-smime-get-file-cert ()
172 (list 'certfile
(read-file-name
173 "File with recipient's S/MIME certificate: "
174 smime-certificate-directory nil t
""))))
176 (defun mml-smime-get-dns-cert ()
177 ;; todo: deal with comma separated multiple recipients
178 (let (result who bad cert
)
181 (setq who
(read-from-minibuffer
182 (format "%sLookup certificate for: " (or bad
""))
183 (cadr (funcall (if (boundp
184 'gnus-extract-address-components
)
185 gnus-extract-address-components
186 'mail-extract-address-components
)
189 (message-narrow-to-headers)
190 (message-fetch-field "to")))
192 (if (setq cert
(smime-cert-by-dns who
))
193 (setq result
(list 'certfile
(buffer-name cert
)))
194 (setq bad
(format "`%s' not found. " who
))))
198 (defun mml-smime-get-ldap-cert ()
199 ;; todo: deal with comma separated multiple recipients
200 (let (result who bad cert
)
203 (setq who
(read-from-minibuffer
204 (format "%sLookup certificate for: " (or bad
""))
205 (cadr (funcall gnus-extract-address-components
208 (message-narrow-to-headers)
209 (message-fetch-field "to")))
211 (if (setq cert
(smime-cert-by-ldap who
))
212 (setq result
(list 'certfile
(buffer-name cert
)))
213 (setq bad
(format "`%s' not found. " who
))))
217 (defun mml-smime-openssl-encrypt-query ()
218 ;; todo: try dns/ldap automatically first, before prompting user
221 (ecase (read (gnus-completing-read-with-default
222 "ldap" "Fetch certificate from"
223 '(("dns") ("ldap") ("file")) nil t
))
224 (dns (setq certs
(append certs
225 (mml-smime-get-dns-cert))))
226 (ldap (setq certs
(append certs
227 (mml-smime-get-ldap-cert))))
228 (file (setq certs
(append certs
229 (mml-smime-get-file-cert)))))
230 (setq done
(not (y-or-n-p "Add more recipients? "))))
233 (defun mml-smime-openssl-verify (handle ctl
)
235 (insert-buffer-substring (mm-handle-multipart-original-buffer ctl
))
236 (goto-char (point-min))
237 (insert (format "Content-Type: %s; " (mm-handle-media-type ctl
)))
238 (insert (format "protocol=\"%s\"; "
239 (mm-handle-multipart-ctl-parameter ctl
'protocol
)))
240 (insert (format "micalg=\"%s\"; "
241 (mm-handle-multipart-ctl-parameter ctl
'micalg
)))
242 (insert (format "boundary=\"%s\"\n\n"
243 (mm-handle-multipart-ctl-parameter ctl
'boundary
)))
244 (when (get-buffer smime-details-buffer
)
245 (kill-buffer smime-details-buffer
))
246 (let ((buf (current-buffer))
247 (good-signature (smime-noverify-buffer))
248 (good-certificate (and (or smime-CA-file smime-CA-directory
)
249 (smime-verify-buffer)))
250 addresses openssl-output
)
251 (setq openssl-output
(with-current-buffer smime-details-buffer
253 (if (not good-signature
)
255 ;; we couldn't verify message, fail with openssl output as message
256 (mm-set-handle-multipart-parameter
257 mm-security-handle
'gnus-info
"Failed")
258 (mm-set-handle-multipart-parameter
259 mm-security-handle
'gnus-details
260 (concat "OpenSSL failed to verify message integrity:\n"
261 "-------------------------------------------\n"
263 ;; verify mail addresses in mail against those in certificate
264 (when (and (smime-pkcs7-region (point-min) (point-max))
265 (smime-pkcs7-certificates-region (point-min) (point-max)))
267 (insert-buffer-substring buf
)
268 (goto-char (point-min))
269 (while (re-search-forward "-----END CERTIFICATE-----" nil t
)
270 (when (smime-pkcs7-email-region (point-min) (point))
271 (setq addresses
(append (smime-buffer-as-string-region
272 (point-min) (point)) addresses
)))
273 (delete-region (point-min) (point)))
274 (setq addresses
(mapcar 'downcase addresses
))))
275 (if (not (member (downcase (or (mm-handle-multipart-from ctl
) "")) addresses
))
276 (mm-set-handle-multipart-parameter
277 mm-security-handle
'gnus-info
"Sender address forged")
279 (mm-set-handle-multipart-parameter
280 mm-security-handle
'gnus-info
"Ok (sender authenticated)")
281 (mm-set-handle-multipart-parameter
282 mm-security-handle
'gnus-info
"Ok (sender not trusted)")))
283 (mm-set-handle-multipart-parameter
284 mm-security-handle
'gnus-details
285 (concat "Sender claimed to be: " (mm-handle-multipart-from ctl
) "\n"
287 (concat "Addresses in certificate: "
288 (mapconcat 'identity addresses
", "))
289 "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
292 "---------------\n" openssl-output
"\n"
293 "Certificate(s) inside S/MIME signature:\n"
294 "---------------------------------------\n"
295 (buffer-string) "\n")))))
298 (defun mml-smime-openssl-verify-test (handle ctl
)
299 smime-openssl-program
)
302 (autoload 'epg-make-context
"epg"))
305 (defvar epg-user-id-alist
)
306 (defvar epg-digest-algorithm-alist
)
307 (defvar inhibit-redisplay
)
308 (autoload 'epg-context-set-armor
"epg")
309 (autoload 'epg-context-set-signers
"epg")
310 (autoload 'epg-context-result-for
"epg")
311 (autoload 'epg-new-signature-digest-algorithm
"epg")
312 (autoload 'epg-verify-result-to-string
"epg")
313 (autoload 'epg-list-keys
"epg")
314 (autoload 'epg-decrypt-string
"epg")
315 (autoload 'epg-verify-string
"epg")
316 (autoload 'epg-sign-string
"epg")
317 (autoload 'epg-encrypt-string
"epg")
318 (autoload 'epg-passphrase-callback-function
"epg")
319 (autoload 'epg-context-set-passphrase-callback
"epg")
320 (autoload 'epg-configuration
"epg-config")
321 (autoload 'epg-expand-group
"epg-config")
322 (autoload 'epa-select-keys
"epa"))
325 (defvar password-cache-expiry
)
326 (autoload 'password-read
"password")
327 (autoload 'password-cache-add
"password")
328 (autoload 'password-cache-remove
"password"))
330 (defvar mml-smime-epg-secret-key-id-list nil
)
332 (defun mml-smime-epg-passphrase-callback (context key-id ignore
)
334 (epg-passphrase-callback-function context key-id nil
)
339 "Passphrase for PIN: "
340 (if (setq entry
(assoc key-id epg-user-id-alist
))
341 (format "Passphrase for %s %s: " key-id
(cdr entry
))
342 (format "Passphrase for %s: " key-id
)))
347 (let ((password-cache-expiry mml-smime-passphrase-cache-expiry
))
348 (password-cache-add key-id passphrase
))
349 (setq mml-smime-epg-secret-key-id-list
350 (cons key-id mml-smime-epg-secret-key-id-list
))
351 (copy-sequence passphrase
)))))
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 (defun mml-smime-epg-sign (cont)
366 (let* ((inhibit-redisplay t
)
367 (context (epg-make-context 'CMS
))
368 (boundary (mml-compute-boundary cont
))
371 (or (message-options-get 'mml-smime-epg-signers
)
373 'mml-smime-epg-signers
374 (if mml-smime-verbose
375 (epa-select-keys context
"\
376 Select keys for signing.
377 If no one is selected, default secret key is used. "
379 (if mml-smime-signers
382 (setq signer-key
(mml-smime-epg-find-usable-key
383 (epg-list-keys context signer t
)
385 (unless (or signer-key
387 (format "No secret key for %s; skip it? "
389 (error "No secret key for %s" signer
))
391 mml-smime-signers
))))))
393 (epg-context-set-signers context signers
)
394 (if mml-smime-cache-passphrase
395 (epg-context-set-passphrase-callback
397 #'mml-smime-epg-passphrase-callback
))
398 (condition-case error
399 (setq signature
(epg-sign-string context
400 (mm-replace-in-string (buffer-string)
403 mml-smime-epg-secret-key-id-list nil
)
405 (while mml-smime-epg-secret-key-id-list
406 (password-cache-remove (car mml-smime-epg-secret-key-id-list
))
407 (setq mml-smime-epg-secret-key-id-list
408 (cdr mml-smime-epg-secret-key-id-list
)))
409 (signal (car error
) (cdr error
))))
410 (if (epg-context-result-for context
'sign
)
411 (setq micalg
(epg-new-signature-digest-algorithm
412 (car (epg-context-result-for context
'sign
)))))
413 (goto-char (point-min))
414 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
417 (insert (format "\tmicalg=%s; "
420 epg-digest-algorithm-alist
))))))
421 (insert "protocol=\"application/pkcs7-signature\"\n")
422 (insert (format "\n--%s\n" boundary
))
423 (goto-char (point-max))
424 (insert (format "\n--%s\n" boundary
))
425 (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
426 Content-Transfer-Encoding: base64
427 Content-Disposition: attachment; filename=smime.p7s
430 (insert (base64-encode-string signature
) "\n")
431 (goto-char (point-max))
432 (insert (format "--%s--\n" boundary
))
433 (goto-char (point-max))))
435 (defun mml-smime-epg-encrypt (cont)
436 (let ((inhibit-redisplay t
)
437 (context (epg-make-context 'CMS
))
438 (config (epg-configuration))
439 (recipients (message-options-get 'mml-smime-epg-recipients
))
441 (boundary (mml-compute-boundary cont
))
448 (or (epg-expand-group config recipient
)
451 (or (message-options-get 'message-recipients
)
452 (message-options-set 'message-recipients
453 (read-string "Recipients: ")))
454 "[ \f\t\n\r\v,]+"))))
455 (if mml-smime-verbose
457 (epa-select-keys context
"\
458 Select recipients for encryption.
459 If no one is selected, symmetric encryption will be performed. "
464 (setq recipient-key
(mml-smime-epg-find-usable-key
465 (epg-list-keys context recipient
)
467 (unless (or recipient-key
469 (format "No public key for %s; skip it? "
471 (error "No public key for %s" recipient
))
475 (error "No recipient specified")))
476 (message-options-set 'mml-smime-epg-recipients recipients
))
477 (if mml-smime-cache-passphrase
478 (epg-context-set-passphrase-callback
480 #'mml-smime-epg-passphrase-callback
))
481 (condition-case error
483 (epg-encrypt-string context
(buffer-string) recipients
)
484 mml-smime-epg-secret-key-id-list nil
)
486 (while mml-smime-epg-secret-key-id-list
487 (password-cache-remove (car mml-smime-epg-secret-key-id-list
))
488 (setq mml-smime-epg-secret-key-id-list
489 (cdr mml-smime-epg-secret-key-id-list
)))
490 (signal (car error
) (cdr error
))))
491 (delete-region (point-min) (point-max))
492 (goto-char (point-min))
494 Content-Type: application/pkcs7-mime;
495 smime-type=enveloped-data;
497 Content-Transfer-Encoding: base64
498 Content-Disposition: attachment; filename=smime.p7m
501 (insert (base64-encode-string cipher
))
502 (goto-char (point-max))))
504 (defun mml-smime-epg-verify (handle ctl
)
506 (let ((inhibit-redisplay t
)
507 context plain signature-file part signature
)
508 (when (or (null (setq part
(mm-find-raw-part-by-type
509 ctl
(or (mm-handle-multipart-ctl-parameter
511 "application/pkcs7-signature")
513 (null (setq signature
(mm-find-part-by-type
515 "application/pkcs7-signature"
517 (mm-set-handle-multipart-parameter
518 mm-security-handle
'gnus-info
"Corrupted")
519 (throw 'error handle
))
520 (setq part
(mm-replace-in-string part
"\n" "\r\n" t
)
521 context
(epg-make-context 'CMS
))
522 (condition-case error
523 (setq plain
(epg-verify-string context
(mm-get-part signature
) part
))
525 (mm-set-handle-multipart-parameter
526 mm-security-handle
'gnus-info
"Failed")
527 (if (eq (car error
) 'quit
)
528 (mm-set-handle-multipart-parameter
529 mm-security-handle
'gnus-details
"Quit.")
530 (mm-set-handle-multipart-parameter
531 mm-security-handle
'gnus-details
(format "%S" error
)))
532 (throw 'error handle
)))
533 (mm-set-handle-multipart-parameter
534 mm-security-handle
'gnus-info
535 (epg-verify-result-to-string (epg-context-result-for context
'verify
)))
538 (defun mml-smime-epg-verify-test (handle ctl
)
543 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
544 ;;; mml-smime.el ends here