1 ;;; mml-smime.el --- S/MIME support for MML
2 ;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
4 ;; Author: Simon Josefsson <simon@josefsson.org>
5 ;; Keywords: Gnus, MIME, S/MIME, MML
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published
11 ;; by the Free Software Foundation; either version 2, or (at your
12 ;; option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
28 (eval-when-compile (require 'cl
))
32 (autoload 'message-narrow-to-headers
"message")
33 (autoload 'message-fetch-field
"message")
35 (defun mml-smime-sign (cont)
36 (when (null smime-keys
)
37 (customize-variable 'smime-keys
)
38 (error "No S/MIME keys configured, use customize to add your key"))
39 (smime-sign-buffer (cdr (assq 'keyfile cont
)))
40 (goto-char (point-min))
41 (while (search-forward "\r\n" nil t
)
42 (replace-match "\n" t t
))
43 (goto-char (point-max)))
45 (defun mml-smime-encrypt (cont)
46 (let (certnames certfiles tmp file tmpfiles
)
47 ;; xxx tmp files are always an security issue
48 (while (setq tmp
(pop cont
))
49 (if (and (consp tmp
) (eq (car tmp
) 'certfile
))
50 (push (cdr tmp
) certnames
)))
51 (while (setq tmp
(pop certnames
))
52 (if (not (and (not (file-exists-p tmp
))
55 (setq file
(mm-make-temp-file (expand-file-name "mml."
57 (with-current-buffer tmp
58 (write-region (point-min) (point-max) file
))
60 (push file tmpfiles
)))
61 (if (smime-encrypt-buffer certfiles
)
63 (while (setq tmp
(pop tmpfiles
))
66 (while (setq tmp
(pop tmpfiles
))
69 (goto-char (point-max)))
71 (defun mml-smime-sign-query ()
72 ;; query information (what certificate) from user when MML tag is
73 ;; added, for use later by the signing process
74 (when (null smime-keys
)
75 (customize-variable 'smime-keys
)
76 (error "No S/MIME keys configured, use customize to add your key"))
78 (if (= (length smime-keys
) 1)
80 (or (let ((from (cadr (funcall gnus-extract-address-components
83 (message-narrow-to-headers)
84 (message-fetch-field "from")))
86 (and from
(smime-get-key-by-email from
)))
87 (smime-get-key-by-email
88 (completing-read "Sign this part with what signature? "
90 (and (listp (car-safe smime-keys
))
91 (caar smime-keys
))))))))
93 (defun mml-smime-get-file-cert ()
95 (list 'certfile
(read-file-name
96 "File with recipient's S/MIME certificate: "
97 smime-certificate-directory nil t
""))))
99 (defun mml-smime-get-dns-cert ()
100 ;; todo: deal with comma separated multiple recipients
101 (let (result who bad cert
)
104 (setq who
(read-from-minibuffer
105 (format "%sLookup certificate for: " (or bad
""))
106 (cadr (funcall gnus-extract-address-components
109 (message-narrow-to-headers)
110 (message-fetch-field "to")))
112 (if (setq cert
(smime-cert-by-dns who
))
113 (setq result
(list 'certfile
(buffer-name cert
)))
114 (setq bad
(format "`%s' not found. " who
))))
118 (defun mml-smime-encrypt-query ()
119 ;; todo: add ldap support (xemacs ldap api?)
120 ;; todo: try dns/ldap automatically first, before prompting user
123 (ecase (read (gnus-completing-read-with-default
124 "dns" "Fetch certificate from"
125 '(("dns") ("file")) nil t
))
126 (dns (setq certs
(append certs
127 (mml-smime-get-dns-cert))))
128 (file (setq certs
(append certs
129 (mml-smime-get-file-cert)))))
130 (setq done
(not (y-or-n-p "Add more recipients? "))))
133 (defun mml-smime-verify (handle ctl
)
135 (insert-buffer-substring (mm-handle-multipart-original-buffer ctl
))
136 (goto-char (point-min))
137 (insert (format "Content-Type: %s; " (mm-handle-media-type ctl
)))
138 (insert (format "protocol=\"%s\"; "
139 (mm-handle-multipart-ctl-parameter ctl
'protocol
)))
140 (insert (format "micalg=\"%s\"; "
141 (mm-handle-multipart-ctl-parameter ctl
'micalg
)))
142 (insert (format "boundary=\"%s\"\n\n"
143 (mm-handle-multipart-ctl-parameter ctl
'boundary
)))
144 (when (get-buffer smime-details-buffer
)
145 (kill-buffer smime-details-buffer
))
146 (let ((buf (current-buffer))
147 (good-signature (smime-noverify-buffer))
148 (good-certificate (and (or smime-CA-file smime-CA-directory
)
149 (smime-verify-buffer)))
150 addresses openssl-output
)
151 (setq openssl-output
(with-current-buffer smime-details-buffer
153 (if (not good-signature
)
155 ;; we couldn't verify message, fail with openssl output as message
156 (mm-set-handle-multipart-parameter
157 mm-security-handle
'gnus-info
"Failed")
158 (mm-set-handle-multipart-parameter
159 mm-security-handle
'gnus-details
160 (concat "OpenSSL failed to verify message integrity:\n"
161 "-------------------------------------------\n"
163 ;; verify mail addresses in mail against those in certificate
164 (when (and (smime-pkcs7-region (point-min) (point-max))
165 (smime-pkcs7-certificates-region (point-min) (point-max)))
167 (insert-buffer-substring buf
)
168 (goto-char (point-min))
169 (while (re-search-forward "-----END CERTIFICATE-----" nil t
)
170 (when (smime-pkcs7-email-region (point-min) (point))
171 (setq addresses
(append (smime-buffer-as-string-region
172 (point-min) (point)) addresses
)))
173 (delete-region (point-min) (point)))
174 (setq addresses
(mapcar 'downcase addresses
))))
175 (if (not (member (downcase (or (mm-handle-multipart-from ctl
) "")) addresses
))
176 (mm-set-handle-multipart-parameter
177 mm-security-handle
'gnus-info
"Sender address forged")
179 (mm-set-handle-multipart-parameter
180 mm-security-handle
'gnus-info
"Ok (sender authenticated)")
181 (mm-set-handle-multipart-parameter
182 mm-security-handle
'gnus-info
"Ok (sender not trusted)")))
183 (mm-set-handle-multipart-parameter
184 mm-security-handle
'gnus-details
185 (concat "Sender claimed to be: " (mm-handle-multipart-from ctl
) "\n"
187 (concat "Addresses in certificate: "
188 (mapconcat 'identity addresses
", "))
189 "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
192 "---------------\n" openssl-output
"\n"
193 "Certificate(s) inside S/MIME signature:\n"
194 "---------------------------------------\n"
195 (buffer-string) "\n")))))
198 (defun mml-smime-verify-test (handle ctl
)
199 smime-openssl-program
)
203 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
204 ;;; mml-smime.el ends here