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 3, 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 (defvar gnus-extract-address-components
)
147 (defun mml-smime-openssl-sign-query ()
148 ;; query information (what certificate) from user when MML tag is
149 ;; added, for use later by the signing process
150 (when (null smime-keys
)
151 (customize-variable 'smime-keys
)
152 (error "No S/MIME keys configured, use customize to add your key"))
154 (if (= (length smime-keys
) 1)
156 (or (let ((from (cadr (funcall (if (boundp
157 'gnus-extract-address-components
)
158 gnus-extract-address-components
159 'mail-extract-address-components
)
162 (message-narrow-to-headers)
163 (message-fetch-field "from")))
165 (and from
(smime-get-key-by-email from
)))
166 (smime-get-key-by-email
167 (completing-read "Sign this part with what signature? "
169 (and (listp (car-safe smime-keys
))
170 (caar smime-keys
))))))))
172 (defun mml-smime-get-file-cert ()
174 (list 'certfile
(read-file-name
175 "File with recipient's S/MIME certificate: "
176 smime-certificate-directory nil t
""))))
178 (defun mml-smime-get-dns-cert ()
179 ;; todo: deal with comma separated multiple recipients
180 (let (result who bad cert
)
183 (setq who
(read-from-minibuffer
184 (format "%sLookup certificate for: " (or bad
""))
185 (cadr (funcall (if (boundp
186 'gnus-extract-address-components
)
187 gnus-extract-address-components
188 'mail-extract-address-components
)
191 (message-narrow-to-headers)
192 (message-fetch-field "to")))
194 (if (setq cert
(smime-cert-by-dns who
))
195 (setq result
(list 'certfile
(buffer-name cert
)))
196 (setq bad
(format "`%s' not found. " who
))))
200 (defun mml-smime-get-ldap-cert ()
201 ;; todo: deal with comma separated multiple recipients
202 (let (result who bad cert
)
205 (setq who
(read-from-minibuffer
206 (format "%sLookup certificate for: " (or bad
""))
207 (cadr (funcall gnus-extract-address-components
210 (message-narrow-to-headers)
211 (message-fetch-field "to")))
213 (if (setq cert
(smime-cert-by-ldap who
))
214 (setq result
(list 'certfile
(buffer-name cert
)))
215 (setq bad
(format "`%s' not found. " who
))))
219 (defun mml-smime-openssl-encrypt-query ()
220 ;; todo: try dns/ldap automatically first, before prompting user
223 (ecase (read (gnus-completing-read-with-default
224 "ldap" "Fetch certificate from"
225 '(("dns") ("ldap") ("file")) nil t
))
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 (defun mml-smime-epg-find-usable-key (keys usage
)
352 (let ((pointer (epg-key-sub-key-list (car keys
))))
354 (if (and (memq usage
(epg-sub-key-capability (car pointer
)))
355 (not (memq (epg-sub-key-validity (car pointer
))
356 '(revoked expired
))))
357 (throw 'found
(car keys
)))
358 (setq pointer
(cdr pointer
))))
359 (setq keys
(cdr keys
)))))
361 (defun mml-smime-epg-sign (cont)
362 (let* ((inhibit-redisplay t
)
363 (context (epg-make-context 'CMS
))
364 (boundary (mml-compute-boundary cont
))
367 (or (message-options-get 'mml-smime-epg-signers
)
369 'mml-smime-epg-signers
370 (if mml-smime-verbose
371 (epa-select-keys context
"\
372 Select keys for signing.
373 If no one is selected, default secret key is used. "
375 (if mml-smime-signers
378 (setq signer-key
(mml-smime-epg-find-usable-key
379 (epg-list-keys context signer t
)
381 (unless (or signer-key
383 (format "No secret key for %s; skip it? "
385 (error "No secret key for %s" signer
))
387 mml-smime-signers
))))))
389 (epg-context-set-signers context signers
)
390 (if mml-smime-cache-passphrase
391 (epg-context-set-passphrase-callback
393 #'mml-smime-epg-passphrase-callback
))
394 (condition-case error
395 (setq signature
(epg-sign-string context
396 (mm-replace-in-string (buffer-string)
399 mml-smime-epg-secret-key-id-list nil
)
401 (while mml-smime-epg-secret-key-id-list
402 (password-cache-remove (car mml-smime-epg-secret-key-id-list
))
403 (setq mml-smime-epg-secret-key-id-list
404 (cdr mml-smime-epg-secret-key-id-list
)))
405 (signal (car error
) (cdr error
))))
406 (if (epg-context-result-for context
'sign
)
407 (setq micalg
(epg-new-signature-digest-algorithm
408 (car (epg-context-result-for context
'sign
)))))
409 (goto-char (point-min))
410 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
413 (insert (format "\tmicalg=%s; "
416 epg-digest-algorithm-alist
))))))
417 (insert "protocol=\"application/pkcs7-signature\"\n")
418 (insert (format "\n--%s\n" boundary
))
419 (goto-char (point-max))
420 (insert (format "\n--%s\n" boundary
))
421 (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
422 Content-Transfer-Encoding: base64
423 Content-Disposition: attachment; filename=smime.p7s
426 (insert (base64-encode-string signature
) "\n")
427 (goto-char (point-max))
428 (insert (format "--%s--\n" boundary
))
429 (goto-char (point-max))))
431 (defun mml-smime-epg-encrypt (cont)
432 (let ((inhibit-redisplay t
)
433 (context (epg-make-context 'CMS
))
434 (config (epg-configuration))
435 (recipients (message-options-get 'mml-smime-epg-recipients
))
437 (boundary (mml-compute-boundary cont
))
444 (or (epg-expand-group config recipient
)
447 (or (message-options-get 'message-recipients
)
448 (message-options-set 'message-recipients
449 (read-string "Recipients: ")))
450 "[ \f\t\n\r\v,]+"))))
451 (if mml-smime-verbose
453 (epa-select-keys context
"\
454 Select recipients for encryption.
455 If no one is selected, symmetric encryption will be performed. "
460 (setq recipient-key
(mml-smime-epg-find-usable-key
461 (epg-list-keys context recipient
)
463 (unless (or recipient-key
465 (format "No public key for %s; skip it? "
467 (error "No public key for %s" recipient
))
471 (error "No recipient specified")))
472 (message-options-set 'mml-smime-epg-recipients recipients
))
473 (if mml-smime-cache-passphrase
474 (epg-context-set-passphrase-callback
476 #'mml-smime-epg-passphrase-callback
))
477 (condition-case error
479 (epg-encrypt-string context
(buffer-string) recipients
)
480 mml-smime-epg-secret-key-id-list nil
)
482 (while mml-smime-epg-secret-key-id-list
483 (password-cache-remove (car mml-smime-epg-secret-key-id-list
))
484 (setq mml-smime-epg-secret-key-id-list
485 (cdr mml-smime-epg-secret-key-id-list
)))
486 (signal (car error
) (cdr error
))))
487 (delete-region (point-min) (point-max))
488 (goto-char (point-min))
490 Content-Type: application/pkcs7-mime;
491 smime-type=enveloped-data;
493 Content-Transfer-Encoding: base64
494 Content-Disposition: attachment; filename=smime.p7m
497 (insert (base64-encode-string cipher
))
498 (goto-char (point-max))))
500 (defun mml-smime-epg-verify (handle ctl
)
502 (let ((inhibit-redisplay t
)
503 context plain signature-file part signature
)
504 (when (or (null (setq part
(mm-find-raw-part-by-type
505 ctl
(or (mm-handle-multipart-ctl-parameter
507 "application/pkcs7-signature")
509 (null (setq signature
(mm-find-part-by-type
511 "application/pkcs7-signature"
513 (mm-set-handle-multipart-parameter
514 mm-security-handle
'gnus-info
"Corrupted")
515 (throw 'error handle
))
516 (setq part
(mm-replace-in-string part
"\n" "\r\n" t
)
517 context
(epg-make-context 'CMS
))
518 (condition-case error
519 (setq plain
(epg-verify-string context
(mm-get-part signature
) part
))
521 (mm-set-handle-multipart-parameter
522 mm-security-handle
'gnus-info
"Failed")
523 (if (eq (car error
) 'quit
)
524 (mm-set-handle-multipart-parameter
525 mm-security-handle
'gnus-details
"Quit.")
526 (mm-set-handle-multipart-parameter
527 mm-security-handle
'gnus-details
(format "%S" error
)))
528 (throw 'error handle
)))
529 (mm-set-handle-multipart-parameter
530 mm-security-handle
'gnus-info
531 (epg-verify-result-to-string (epg-context-result-for context
'verify
)))
534 (defun mml-smime-epg-verify-test (handle ctl
)
539 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
540 ;;; mml-smime.el ends here