Commit | Line | Data |
---|---|---|
23f87bed MB |
1 | ;;; mml-smime.el --- S/MIME support for MML |
2 | ;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc. | |
3 | ||
4 | ;; Author: Simon Josefsson <simon@josefsson.org> | |
5 | ;; Keywords: Gnus, MIME, S/MIME, MML | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
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. | |
13 | ||
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. | |
18 | ||
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. | |
23 | ||
24 | ;;; Commentary: | |
25 | ||
26 | ;;; Code: | |
27 | ||
c1d7d285 MB |
28 | (eval-when-compile (require 'cl)) |
29 | ||
23f87bed MB |
30 | (require 'smime) |
31 | (require 'mm-decode) | |
32 | (autoload 'message-narrow-to-headers "message") | |
c1d7d285 | 33 | (autoload 'message-fetch-field "message") |
23f87bed MB |
34 | |
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))) | |
44 | ||
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)) | |
53 | (get-buffer tmp))) | |
54 | (push tmp certfiles) | |
55 | (setq file (mm-make-temp-file (expand-file-name "mml." | |
56 | mm-tmp-directory))) | |
57 | (with-current-buffer tmp | |
58 | (write-region (point-min) (point-max) file)) | |
59 | (push file certfiles) | |
60 | (push file tmpfiles))) | |
61 | (if (smime-encrypt-buffer certfiles) | |
62 | (progn | |
63 | (while (setq tmp (pop tmpfiles)) | |
64 | (delete-file tmp)) | |
65 | t) | |
66 | (while (setq tmp (pop tmpfiles)) | |
67 | (delete-file tmp)) | |
68 | nil)) | |
69 | (goto-char (point-max))) | |
70 | ||
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")) | |
77 | (list 'keyfile | |
78 | (if (= (length smime-keys) 1) | |
79 | (cadar smime-keys) | |
80 | (or (let ((from (cadr (funcall gnus-extract-address-components | |
81 | (or (save-excursion | |
82 | (save-restriction | |
83 | (message-narrow-to-headers) | |
84 | (message-fetch-field "from"))) | |
85 | ""))))) | |
86 | (and from (smime-get-key-by-email from))) | |
87 | (smime-get-key-by-email | |
88 | (completing-read "Sign this part with what signature? " | |
89 | smime-keys nil nil | |
90 | (and (listp (car-safe smime-keys)) | |
91 | (caar smime-keys)))))))) | |
92 | ||
93 | (defun mml-smime-get-file-cert () | |
94 | (ignore-errors | |
95 | (list 'certfile (read-file-name | |
96 | "File with recipient's S/MIME certificate: " | |
97 | smime-certificate-directory nil t "")))) | |
98 | ||
99 | (defun mml-smime-get-dns-cert () | |
100 | ;; todo: deal with comma separated multiple recipients | |
101 | (let (result who bad cert) | |
102 | (condition-case () | |
103 | (while (not result) | |
104 | (setq who (read-from-minibuffer | |
105 | (format "%sLookup certificate for: " (or bad "")) | |
106 | (cadr (funcall gnus-extract-address-components | |
107 | (or (save-excursion | |
108 | (save-restriction | |
109 | (message-narrow-to-headers) | |
110 | (message-fetch-field "to"))) | |
111 | ""))))) | |
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)))) | |
115 | (quit)) | |
116 | result)) | |
117 | ||
118 | (defun mml-smime-encrypt-query () | |
119 | ;; todo: add ldap support (xemacs ldap api?) | |
120 | ;; todo: try dns/ldap automatically first, before prompting user | |
121 | (let (certs done) | |
122 | (while (not done) | |
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? ")))) | |
131 | certs)) | |
132 | ||
133 | (defun mml-smime-verify (handle ctl) | |
134 | (with-temp-buffer | |
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 | |
152 | (buffer-string))) | |
153 | (if (not good-signature) | |
154 | (progn | |
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" | |
162 | openssl-output))) | |
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))) | |
166 | (with-temp-buffer | |
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") | |
178 | (if good-certificate | |
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" | |
186 | (if addresses | |
187 | (concat "Addresses in certificate: " | |
188 | (mapconcat 'identity addresses ", ")) | |
189 | "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)") | |
190 | "\n" "\n" | |
191 | "OpenSSL output:\n" | |
192 | "---------------\n" openssl-output "\n" | |
193 | "Certificate(s) inside S/MIME signature:\n" | |
194 | "---------------------------------------\n" | |
195 | (buffer-string) "\n"))))) | |
196 | handle) | |
197 | ||
198 | (defun mml-smime-verify-test (handle ctl) | |
199 | smime-openssl-program) | |
200 | ||
201 | (provide 'mml-smime) | |
202 | ||
203 | ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2 | |
204 | ;;; mml-smime.el ends here |