1 ;;; canlock.el --- Functions for Cancel-Lock feature.
2 ;; Copyright (C) 1998,1999 Katsumi Yamaoka
4 ;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
5 ;; Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Hideyuki SHIRAI <shirai@rdmg.mgcs.mei.co.jp>
7 ;; Hidekazu Nakamura <u90121@uis-inf.co.jp>
8 ;; Ken'ichi Okada <kokada@tamaru.kuee.kyoto-u.ac.jp>
9 ;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
10 ;; Created: 1998-11-24
11 ;; Revised: 1999-06-14
12 ;; Keywords: news, cancel-lock, hmac, sha1, rfc2104
14 ;; This program is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 2, or (at your option)
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with this program; if not, write to the Free Software
26 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
31 ;; This library is based on draft-ietf-usefor-cancel-lock-01.txt,
32 ;; released on 1998-11-03.
36 (defconst canlock-version "0.6")
38 (eval-when-compile (require 'cl))
42 (autoload 'sha1-encode-binary "sha1")
43 (autoload 'base64-encode "base64")
46 "Cancel-Lock feature."
50 (defcustom canlock-base64-encode-function 'base64-encode-string
51 "*Function called to encode string to base64."
52 :type '(radio (function-item base64-encode-string)
53 (function-item base64-encode)
54 (function-item canlock-base64-encode-string-with-mmencode)
55 (function :tag "Other"))
58 (defcustom canlock-mmencode-program "mmencode"
59 "*Name of mmencode program."
63 (defcustom canlock-mmencode-args-for-encoding nil
64 "*Arguments passed to mmencode program for encoding."
68 (defcustom canlock-sha1-function 'sha1-encode-binary
69 "*Function called to make a SHA1 digest from a message (string)."
70 :type '(radio (function-item sha1-encode-binary)
71 (function-item canlock-sha1-with-ssleay)
72 (function :tag "Other"))
75 (defcustom canlock-sha1-function-for-verify canlock-sha1-function
76 "*Function called to make a SHA1 digest for verifying."
77 :type '(radio (function-item sha1-encode-binary)
78 (function-item canlock-sha1-with-ssleay)
79 (function :tag "Other"))
82 (defcustom canlock-ssleay-program "ssleay"
83 "*Name of SSLeay program."
87 (defcustom canlock-ssleay-args '("sha1")
88 "*Arguments passed to SSLeay program."
92 (defcustom canlock-ignore-errors nil
93 "*If non-nil, ignore any error signals."
97 (defcustom canlock-load-hook nil
98 "*Hook to be run after the canlock package has been loaded."
102 ;;; Internal variables.
104 (defvar canlock-password nil
105 "*Password to use when signing a Cancel-Lock or a Cancel-Key header.")
107 (defvar canlock-password-for-verify canlock-password
108 "*Password to use when verifying a Cancel-Lock or a Cancel-Key header.")
110 (defvar canlock-force-insert-header nil
111 "*If non-nil, insert a Cancel-Lock or a Cancel-Key header even though the
112 buffer does not contain a news message.")
116 (defun canlock-base64-encode-string-with-mmencode (string)
117 "Encode string to base64 with mmencode."
119 (let ((coding-system-for-read 'raw-text)
120 (coding-system-for-write 'binary)
121 ;; For Mule 2 with APEL 9.12 or later.
122 (default-process-coding-system '(raw-text . binary))
123 mc-flag program-coding-system-alist)
125 (apply 'call-process-region (point-min) (point-max)
126 canlock-mmencode-program t t nil
127 canlock-mmencode-args-for-encoding)
128 (goto-char (point-max))
129 (skip-chars-backward "\n")
130 (buffer-substring (point-min) (point)))))
132 (defun canlock-hex-string-to-int (string)
133 "Convert hexadecimal string to integer."
137 (setq integer (+ (* 16 integer)
139 (* (lsh hex -6) 9))))
143 (defun canlock-sha1-with-ssleay (message)
144 "Make a SHA1 digest from a specified message (string) with SSLeay."
146 (let ((coding-system-for-read 'binary)
147 (coding-system-for-write 'binary)
148 ;; For Mule 2 with APEL 9.12 or later.
149 (default-process-coding-system '(binary . binary))
150 mc-flag program-coding-system-alist
151 (case-fold-search t))
153 (apply 'call-process-region (point-min) (point-max)
154 canlock-ssleay-program t t nil canlock-ssleay-args)
155 (goto-char (point-min))
156 (while (re-search-forward "[0-9A-F][0-9A-F]" nil t)
157 (goto-char (match-beginning 0))
158 (insert-char (canlock-hex-string-to-int (match-string 0)) 1)
160 (buffer-substring (point-min) (point)))))
162 (defvar canlock-read-passwd nil)
163 (defun canlock-read-passwd (prompt &rest args)
164 "Read a password using PROMPT.
165 If ARGS, PROMPT is used as an argument to `format'."
168 (apply 'format prompt args)
170 (unless canlock-read-passwd
171 (if (or (fboundp 'read-passwd) (load "passwd" t))
172 (setq canlock-read-passwd 'read-passwd)
173 (unless (fboundp 'ange-ftp-read-passwd)
174 (autoload 'ange-ftp-read-passwd "ange-ftp"))
175 (setq canlock-read-passwd 'ange-ftp-read-passwd)))
176 (funcall canlock-read-passwd prompt)))
178 (defun canlock-make-cancel-key (message-id password)
179 "Make a Cancel-Key header."
180 (cond ((> (length password) 20)
181 (setq password (funcall canlock-sha1-function password)))
182 ((< (length password) 20)
183 (setq password (concat
185 (make-string (- 20 (length password)) 0)))))
186 (setq password (concat password (make-string 44 0)))
187 (let ((ipad (mapconcat (lambda (char)
188 (char-to-string (logxor 54 char)))
190 (opad (mapconcat (lambda (char)
191 (char-to-string (logxor 92 char)))
193 (funcall canlock-base64-encode-function
194 (funcall canlock-sha1-function
197 (funcall canlock-sha1-function
198 (concat ipad message-id)))))))
200 (defun canlock-narrow-to-header ()
201 "Narrow to the message header."
202 (let (case-fold-search)
204 (goto-char (point-min))
205 (goto-char (if (re-search-forward
207 (regexp-quote mail-header-separator))
212 (defun canlock-delete-headers ()
213 "Delete Canlock headers if they already exist.
214 The buffer is expected to be narrowed to just the headers of the message."
215 (let ((case-fold-search t))
216 (goto-char (point-min))
217 (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t)
218 (delete-region (match-beginning 0)
219 (if (re-search-forward "^[^\t ]" nil t)
220 (goto-char (match-beginning 0))
223 (defun canlock-fetch-fields (&optional key)
224 "Return the list of values of Cancel-Lock field.
225 If the optional arg KEY is non-nil, Cancel-Key field will be fetched.
226 The buffer is expected to be narrowed to just the headers of the message."
227 (let ((feild (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock")))
228 (case-fold-search t))
230 (mapcar (lambda (str)
231 (string-match "^sha1:" str)
232 (substring str (match-end 0)))
233 (split-string feild "[\t\n\r ,]+")))))
235 (defun canlock-fetch-id-for-key ()
236 "Return the Message-ID for Cancel-Key.
237 The buffer is expected to be narrowed to just the headers of the message."
238 (let ((cancel (mail-fetch-field "Control")))
241 (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
243 (match-string 1 cancel))
244 (or (mail-fetch-field "Supersedes")
245 (mail-fetch-field "Replaces")))))
248 (defun canlock-insert-header (&optional id-for-key id-for-lock password)
249 "Insert a Cancel-Key and/or a Cancel-Lock header if possible."
250 (let (news control key-for-key key-for-lock)
253 (canlock-narrow-to-header)
254 (when (setq news (or canlock-force-insert-header
255 (mail-fetch-field "Newsgroups")))
257 (setq id-for-key (canlock-fetch-id-for-key)))
258 (if (and (setq control (mail-fetch-field "Control"))
260 "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
262 (setq id-for-lock nil)
264 (setq id-for-lock (mail-fetch-field "Message-ID"))))
265 (canlock-delete-headers)
266 (goto-char (point-max))))
268 (if (not (or id-for-key id-for-lock))
269 (message "There are no Message-ID(s).")
271 (setq password (or canlock-password
273 "Password for Canlock: "))))
274 (if (or (not (stringp password)) (zerop (length password)))
275 (message "Password for Canlock is bad.")
276 (setq key-for-key (when id-for-key
277 (canlock-make-cancel-key
278 id-for-key password))
279 key-for-lock (when id-for-lock
280 (canlock-make-cancel-key
281 id-for-lock password)))
282 (if (not (or key-for-key key-for-lock))
283 (message "Couldn't insert Canlock header.")
285 (insert "Cancel-Key: sha1:" key-for-key "\n"))
287 (insert "Cancel-Lock: sha1:"
288 (funcall canlock-base64-encode-function
289 (funcall canlock-sha1-function
294 (defun canlock-verify (&optional buffer)
295 "Verify Cancel-Lock or Cancel-Key. If failed, returns non-nil or signals
296 an error if `canlock-ignore-errors' is nil. If the optional arg BUFFER
297 is not specified, it runs in place."
299 (let ((canlock-sha1-function (or canlock-sha1-function-for-verify
300 canlock-sha1-function))
301 keys locks errmsg id-for-key id-for-lock password
302 key-for-key key-for-lock match)
308 (canlock-narrow-to-header)
309 (setq keys (canlock-fetch-fields 'key)
310 locks (canlock-fetch-fields))
311 (if (not (or keys locks))
313 "There are neither Cancel-Lock nor Cancel-Key fields.")
314 (setq id-for-key (canlock-fetch-id-for-key)
315 id-for-lock (mail-fetch-field "Message-ID"))
316 (or id-for-key id-for-lock
317 (setq errmsg "There are no Message-ID(s).")))))
320 (if canlock-ignore-errors
324 (setq password (or canlock-password-for-verify
325 (canlock-read-passwd "Password for Canlock: ")))
326 (if (or (not (stringp password)) (zerop (length password)))
328 (setq errmsg "Password for Canlock is bad.")
329 (if canlock-ignore-errors
331 (error "%s" errmsg)))
335 (setq key-for-key (canlock-make-cancel-key id-for-key password))
336 (while (and keys (not match))
337 (setq match (string-equal key-for-key (pop keys)))))
338 (setq keys (if match "good" "bad")))
344 (funcall canlock-base64-encode-function
345 (funcall canlock-sha1-function
346 (canlock-make-cancel-key
347 id-for-lock password))))
348 (when (and locks (not match))
349 (setq match (string-equal key-for-lock (pop locks)))))
350 (setq locks (if match "good" "bad")))
353 (when (member "bad" (list keys locks))
355 (cond ((and keys locks)
356 (message "Cancel-Key is %s, Cancel-Lock is %s." keys locks))
358 (message "Cancel-Lock is %s." locks))
360 (message "Cancel-Key is %s." keys))))))))
362 ;; Avoid byte compile warnings.
363 (defvar gnus-show-all-headers)
364 (defvar gnus-original-article-buffer)
365 (defvar mh-show-buffer)
366 (defvar vm-mail-buffer)
367 (defvar vm-message-pointer)
368 (defvar cmail-current-folder)
369 (defvar rmail-buffer)
372 (defun gnus-summary-canlock-verify ()
373 "Run `canlock-verify' from gnus summary buffer."
375 (gnus-summary-select-article gnus-show-all-headers)
376 (canlock-verify gnus-original-article-buffer))
379 (defun wl-summary-canlock-verify ()
380 "Run `canlock-verify' from Wanderlust summary buffer."
382 (wl-summary-set-message-buffer-or-redisplay)
383 (canlock-verify (wl-message-get-original-buffer)))
386 (if (or (featurep 'use-mew-1.94b20-or-later)
387 (and (fboundp 'function-max-args)
388 (or (fboundp 'mew-summary-display)
389 (load "mew-summary" t))
390 (eq 2 (function-max-args 'mew-summary-display))))
392 (defmacro canlock-mew-summary-display ()
393 '(mew-summary-display t))
394 (message "Use mew-1.94b20 or later."))
395 (defmacro canlock-mew-summary-display ()
397 (mew-summary-display)
398 (wrong-number-of-arguments
399 (mew-summary-display t))))
403 (defun mew-summary-canlock-verify ()
404 "Run `canlock-verify' from Mew summary buffer."
406 (canlock-mew-summary-display)
407 (canlock-verify (mew-buffer-message)))
410 (defun mh-summary-canlock-verify ()
411 "Run `canlock-verify' from MH folder buffer."
414 (canlock-verify mh-show-buffer))
417 (defun vm-summary-canlock-verify ()
418 "Run `canlock-verify' from VM summary buffer."
420 (vm-follow-summary-cursor)
421 (if (and vm-mail-buffer (buffer-name vm-mail-buffer))
423 (set-buffer vm-mail-buffer)
424 (let* ((mp (car vm-message-pointer))
425 (header (save-restriction
428 (aref (aref mp 0) 0) (vm-text-of mp)))))
432 (or canlock-ignore-errors
433 (error "Folder buffer has been killed."))))
436 (defun cmail-summary-canlock-verify ()
437 "Run `canlock-verify' from cmail summary buffer."
439 (let* ((page (cmail-get-page-number-from-summary))
440 (header (save-excursion
441 (set-buffer (cmail-folder-buffer cmail-current-folder))
443 (buffer-substring (point)
444 (if (search-forward "\n\n" nil t)
452 (defun rmail-summary-canlock-verify ()
453 "Run `canlock-verify' from RMAIL summary buffer."
455 (rmail-summary-rmail-update)
456 (let ((header (save-excursion
457 (set-buffer rmail-buffer)
458 (goto-char (point-min))
461 (search-backward "\n\C-_\C-l\n") ;; ^_^L
462 (re-search-forward "^[^\t\n ]+:")
464 (goto-char (match-beginning 0))
465 (progn (search-forward "\n\n")
473 (run-hooks 'canlock-load-hook)
475 ;;; canlock.el ends here