Mercurial > emacs
comparison lisp/gnus/canlock.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; canlock.el --- functions for Cancel-Lock feature | |
2 | |
3 ;; Copyright (C) 1998, 1999, 2001, 2002, 2003 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Katsumi Yamaoka <yamaoka@jpl.org> | |
6 ;; Keywords: news, cancel-lock, hmac, sha1, rfc2104 | |
7 | |
8 ;; This program is free software; you can redistribute it and/or modify | |
9 ;; it under the terms of the GNU General Public License as published by | |
10 ;; the Free Software Foundation; either version 2, or (at your option) | |
11 ;; any later version. | |
12 | |
13 ;; This program is distributed in the hope that it will be useful, | |
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 ;; GNU General Public License for more details. | |
17 | |
18 ;; You should have received a copy of the GNU General Public License | |
19 ;; along with this program; see the file COPYING. If not, write to the | |
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
21 ;; Boston, MA 02111-1307, USA. | |
22 | |
23 ;;; Commentary: | |
24 | |
25 ;; Canlock is a library for generating and verifying Cancel-Lock and/or | |
26 ;; Cancel-Key header in news articles. This is used to protect articles | |
27 ;; from rogue cancel, supersede or replace attacks. The method is based | |
28 ;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November | |
29 ;; 3rd 1998. For instance, you can add Cancel-Lock (and possibly Cancel- | |
30 ;; Key) header in a news article by using a hook which will be evaluated | |
31 ;; just before sending an article as follows: | |
32 ;; | |
33 ;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t) | |
34 ;; | |
35 ;; Verifying Cancel-Lock is mainly a function of news servers, however, | |
36 ;; you can verify your own article using the command `canlock-verify' in | |
37 ;; the (raw) article buffer. You will be prompted for the password for | |
38 ;; each time if the option `canlock-password' or `canlock-password-for- | |
39 ;; verify' is nil. Note that setting these options is a bit unsafe. | |
40 | |
41 ;;; Code: | |
42 | |
43 (eval-when-compile | |
44 (require 'cl)) | |
45 | |
46 (autoload 'sha1-binary "sha1-el") | |
47 (autoload 'base64-encode-string "base64") | |
48 (autoload 'mail-fetch-field "mail-utils") | |
49 (defvar mail-header-separator) | |
50 | |
51 (defgroup canlock nil | |
52 "The Cancel-Lock feature." | |
53 :group 'applications) | |
54 | |
55 (defcustom canlock-sha1-function 'sha1-binary | |
56 "Function to call to make a SHA-1 message digest." | |
57 :type '(radio (function-item sha1-binary) | |
58 (function-item canlock-sha1-with-openssl) | |
59 (function :tag "Other")) | |
60 :group 'canlock) | |
61 | |
62 (defcustom canlock-sha1-function-for-verify canlock-sha1-function | |
63 "Function to call to make a SHA-1 message digest for verifying." | |
64 :type '(radio (function-item sha1-binary) | |
65 (function-item canlock-sha1-with-openssl) | |
66 (function :tag "Other")) | |
67 :group 'canlock) | |
68 | |
69 (defcustom canlock-openssl-program "openssl" | |
70 "Name of OpenSSL program." | |
71 :type 'string | |
72 :group 'canlock) | |
73 | |
74 (defcustom canlock-openssl-args '("sha1") | |
75 "Arguments passed to the OpenSSL program." | |
76 :type 'sexp | |
77 :group 'canlock) | |
78 | |
79 (defcustom canlock-ignore-errors nil | |
80 "If non-nil, ignore any error signals." | |
81 :type 'boolean | |
82 :group 'canlock) | |
83 | |
84 (defcustom canlock-password nil | |
85 "Password to use when signing a Cancel-Lock or a Cancel-Key header." | |
86 :type '(radio (const :format "Not specified " nil) | |
87 (string :tag "Password" :size 0)) | |
88 :group 'canlock) | |
89 | |
90 (defcustom canlock-password-for-verify canlock-password | |
91 "Password to use when verifying a Cancel-Lock or a Cancel-Key header." | |
92 :type '(radio (const :format "Not specified " nil) | |
93 (string :tag "Password" :size 0)) | |
94 :group 'canlock) | |
95 | |
96 (defcustom canlock-force-insert-header nil | |
97 "If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the | |
98 buffer does not look like a news message." | |
99 :type 'boolean | |
100 :group 'canlock) | |
101 | |
102 (defun canlock-sha1-with-openssl (message) | |
103 "Make a SHA-1 digest of MESSAGE using OpenSSL." | |
104 (let (default-enable-multibyte-characters) | |
105 (with-temp-buffer | |
106 (let ((coding-system-for-read 'binary) | |
107 (coding-system-for-write 'binary) | |
108 selective-display | |
109 (case-fold-search t)) | |
110 (insert message) | |
111 (apply 'call-process-region (point-min) (point-max) | |
112 canlock-openssl-program t t nil canlock-openssl-args) | |
113 (goto-char (point-min)) | |
114 (insert "\"") | |
115 (while (re-search-forward "\\([0-9a-f][0-9a-f]\\)" nil t) | |
116 (replace-match "\\\\x\\1")) | |
117 (insert "\"") | |
118 (goto-char (point-min)) | |
119 (read (current-buffer)))))) | |
120 | |
121 (eval-when-compile | |
122 (defmacro canlock-string-as-unibyte (string) | |
123 "Return a unibyte string with the same individual bytes as STRING." | |
124 (if (fboundp 'string-as-unibyte) | |
125 (list 'string-as-unibyte string) | |
126 string))) | |
127 | |
128 (defun canlock-sha1 (message) | |
129 "Make a SHA-1 digest of MESSAGE as a unibyte string of length 20 bytes." | |
130 (canlock-string-as-unibyte (funcall canlock-sha1-function message))) | |
131 | |
132 (defun canlock-make-cancel-key (message-id password) | |
133 "Make a Cancel-Key header." | |
134 (when (> (length password) 20) | |
135 (setq password (canlock-sha1 password))) | |
136 (setq password (concat password (make-string (- 64 (length password)) 0))) | |
137 (let ((ipad (mapconcat (lambda (byte) | |
138 (char-to-string (logxor 54 byte))) | |
139 password "")) | |
140 (opad (mapconcat (lambda (byte) | |
141 (char-to-string (logxor 92 byte))) | |
142 password ""))) | |
143 (base64-encode-string | |
144 (canlock-sha1 | |
145 (concat opad | |
146 (canlock-sha1 | |
147 (concat ipad (canlock-string-as-unibyte message-id)))))))) | |
148 | |
149 (defun canlock-narrow-to-header () | |
150 "Narrow the buffer to the head of the message." | |
151 (let (case-fold-search) | |
152 (narrow-to-region | |
153 (goto-char (point-min)) | |
154 (goto-char (if (re-search-forward | |
155 (format "^$\\|^%s$" | |
156 (regexp-quote mail-header-separator)) | |
157 nil t) | |
158 (match-beginning 0) | |
159 (point-max)))))) | |
160 | |
161 (defun canlock-delete-headers () | |
162 "Delete Cancel-Key or Cancel-Lock headers in the narrowed buffer." | |
163 (let ((case-fold-search t)) | |
164 (goto-char (point-min)) | |
165 (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t) | |
166 (delete-region (match-beginning 0) | |
167 (if (re-search-forward "^[^\t ]" nil t) | |
168 (goto-char (match-beginning 0)) | |
169 (point-max)))))) | |
170 | |
171 (defun canlock-fetch-fields (&optional key) | |
172 "Return a list of the values of Cancel-Lock header. | |
173 If KEY is non-nil, look for a Cancel-Key header instead. The buffer | |
174 is expected to be narrowed to just the headers of the message." | |
175 (let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock"))) | |
176 fields rest | |
177 (case-fold-search t)) | |
178 (when field | |
179 (setq fields (split-string field "[\t\n\r ,]+")) | |
180 (while fields | |
181 (when (string-match "^sha1:" (setq field (pop fields))) | |
182 (push (substring field 5) rest))) | |
183 (nreverse rest)))) | |
184 | |
185 (defun canlock-fetch-id-for-key () | |
186 "Return a Message-ID in Cancel, Supersedes or Replaces header. | |
187 The buffer is expected to be narrowed to just the headers of the | |
188 message." | |
189 (or (let ((cancel (mail-fetch-field "Control"))) | |
190 (and cancel | |
191 (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" | |
192 cancel) | |
193 (match-string 1 cancel))) | |
194 (mail-fetch-field "Supersedes") | |
195 (mail-fetch-field "Replaces"))) | |
196 | |
197 ;;;###autoload | |
198 (defun canlock-insert-header (&optional id-for-key id-for-lock password) | |
199 "Insert a Cancel-Key and/or a Cancel-Lock header if possible." | |
200 (let (news control key-for-key key-for-lock) | |
201 (save-excursion | |
202 (save-restriction | |
203 (canlock-narrow-to-header) | |
204 (when (setq news (or canlock-force-insert-header | |
205 (mail-fetch-field "Newsgroups"))) | |
206 (unless id-for-key | |
207 (setq id-for-key (canlock-fetch-id-for-key))) | |
208 (if (and (setq control (mail-fetch-field "Control")) | |
209 (string-match | |
210 "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" | |
211 control)) | |
212 (setq id-for-lock nil) | |
213 (unless id-for-lock | |
214 (setq id-for-lock (mail-fetch-field "Message-ID")))) | |
215 (canlock-delete-headers) | |
216 (goto-char (point-max)))) | |
217 (when news | |
218 (if (not (or id-for-key id-for-lock)) | |
219 (message "There are no Message-ID(s)") | |
220 (unless password | |
221 (setq password (or canlock-password | |
222 (read-passwd | |
223 "Password for Canlock: ")))) | |
224 (if (or (not (stringp password)) (zerop (length password))) | |
225 (message "Password for Canlock is bad") | |
226 (setq key-for-key (when id-for-key | |
227 (canlock-make-cancel-key | |
228 id-for-key password)) | |
229 key-for-lock (when id-for-lock | |
230 (canlock-make-cancel-key | |
231 id-for-lock password))) | |
232 (if (not (or key-for-key key-for-lock)) | |
233 (message "Couldn't insert Canlock header") | |
234 (when key-for-key | |
235 (insert "Cancel-Key: sha1:" key-for-key "\n")) | |
236 (when key-for-lock | |
237 (insert "Cancel-Lock: sha1:" | |
238 (base64-encode-string (canlock-sha1 key-for-lock)) | |
239 "\n"))))))))) | |
240 | |
241 ;;;###autoload | |
242 (defun canlock-verify (&optional buffer) | |
243 "Verify Cancel-Lock or Cancel-Key in BUFFER. | |
244 If BUFFER is nil, the current buffer is assumed. Signal an error if | |
245 it fails. You can modify the behavior of this function to return non- | |
246 nil instead of to signal an error by setting the option | |
247 `canlock-ignore-errors' to non-nil." | |
248 (interactive) | |
249 (let ((canlock-sha1-function (or canlock-sha1-function-for-verify | |
250 canlock-sha1-function)) | |
251 keys locks errmsg id-for-key id-for-lock password | |
252 key-for-key key-for-lock match) | |
253 (save-excursion | |
254 (when buffer | |
255 (set-buffer buffer)) | |
256 (save-restriction | |
257 (widen) | |
258 (canlock-narrow-to-header) | |
259 (setq keys (canlock-fetch-fields 'key) | |
260 locks (canlock-fetch-fields)) | |
261 (if (not (or keys locks)) | |
262 (setq errmsg | |
263 "There are neither Cancel-Lock nor Cancel-Key headers") | |
264 (setq id-for-key (canlock-fetch-id-for-key) | |
265 id-for-lock (mail-fetch-field "Message-ID")) | |
266 (or id-for-key id-for-lock | |
267 (setq errmsg "There are no Message-ID(s)"))))) | |
268 | |
269 (if errmsg | |
270 (if canlock-ignore-errors | |
271 errmsg | |
272 (error "%s" errmsg)) | |
273 | |
274 (setq password (or canlock-password-for-verify | |
275 (read-passwd "Password for Canlock: "))) | |
276 (if (or (not (stringp password)) (zerop (length password))) | |
277 (progn | |
278 (setq errmsg "Password for Canlock is bad") | |
279 (if canlock-ignore-errors | |
280 errmsg | |
281 (error "%s" errmsg))) | |
282 | |
283 (when keys | |
284 (when id-for-key | |
285 (setq key-for-key (canlock-make-cancel-key id-for-key password)) | |
286 (while (and keys (not match)) | |
287 (setq match (string-equal key-for-key (pop keys))))) | |
288 (setq keys (if match "good" "bad"))) | |
289 (setq match nil) | |
290 | |
291 (when locks | |
292 (when id-for-lock | |
293 (setq key-for-lock | |
294 (base64-encode-string | |
295 (canlock-sha1 (canlock-make-cancel-key id-for-lock | |
296 password)))) | |
297 (when (and locks (not match)) | |
298 (setq match (string-equal key-for-lock (pop locks))))) | |
299 (setq locks (if match "good" "bad"))) | |
300 | |
301 (prog1 | |
302 (when (member "bad" (list keys locks)) | |
303 "bad") | |
304 (cond ((and keys locks) | |
305 (message "Cancel-Key is %s, Cancel-Lock is %s" keys locks)) | |
306 (locks | |
307 (message "Cancel-Lock is %s" locks)) | |
308 (keys | |
309 (message "Cancel-Key is %s" keys)))))))) | |
310 | |
311 (provide 'canlock) | |
312 | |
313 ;;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78 | |
314 ;;; canlock.el ends here |