git.chise.org Git - elisp/gnus.git-/blob - contrib/canlock.el

   1 ;;; canlock.el --- Functions for Cancel-Lock feature.
   2 ;; Copyright (C) 1998,1999 Katsumi Yamaoka
   3
   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
  13
  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)
  17 ;; any later version.
  18
  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.
  23
  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,
  27 ;; USA.
  28
  29 ;;; Commentary:
  30
  31 ;; This library is based on draft-ietf-usefor-cancel-lock-01.txt,
  32 ;; released on 1998-11-03.
  33
  34 ;;; Code:
  35
  36 (defconst canlock-version "0.6")
  37
  38 (eval-when-compile (require 'cl))
  39 (require 'custom)
  40 (require 'mail-utils)
  41
  42 (autoload 'sha1-encode-binary "sha1")
  43 (autoload 'base64-encode "base64")
  44
  45 (defgroup canlock nil
  46   "Cancel-Lock feature."
  47   :prefix "canlock-"
  48   :group 'applications)
  49
  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"))
  56   :group 'canlock)
  57
  58 (defcustom canlock-mmencode-program "mmencode"
  59   "*Name of mmencode program."
  60   :type 'string
  61   :group 'canlock)
  62
  63 (defcustom canlock-mmencode-args-for-encoding nil
  64   "*Arguments passed to mmencode program for encoding."
  65   :type 'sexp
  66   :group 'canlock)
  67
  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"))
  73   :group 'canlock)
  74
  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"))
  80   :group 'canlock)
  81
  82 (defcustom canlock-ssleay-program "ssleay"
  83   "*Name of SSLeay program."
  84   :type 'string
  85   :group 'canlock)
  86
  87 (defcustom canlock-ssleay-args '("sha1")
  88   "*Arguments passed to SSLeay program."
  89   :type 'sexp
  90   :group 'canlock)
  91
  92 (defcustom canlock-ignore-errors nil
  93   "*If non-nil, ignore any error signals."
  94   :type 'boolean
  95   :group 'canlock)
  96
  97 (defcustom canlock-load-hook nil
  98   "*Hook to be run after the canlock package has been loaded."
  99   :type 'hook
 100   :group 'canlock)
 101
 102 ;;; Internal variables.
 103
 104 (defvar canlock-password nil
 105   "*Password to use when signing a Cancel-Lock or a Cancel-Key header.")
 106
 107 (defvar canlock-password-for-verify canlock-password
 108   "*Password to use when verifying a Cancel-Lock or a Cancel-Key header.")
 109
 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.")
 113
 114 ;;; Functions.
 115
 116 (defun canlock-base64-encode-string-with-mmencode (string)
 117   "Encode string to base64 with mmencode."
 118   (with-temp-buffer
 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)
 124       (insert string)
 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)))))
 131
 132 (defun canlock-hex-string-to-int (string)
 133   "Convert hexadecimal string to integer."
 134   (let ((integer 0))
 135     (mapcar
 136      (lambda (hex)
 137        (setq integer (+ (* 16 integer)
 138                         (logand hex 15)
 139                         (* (lsh hex -6) 9))))
 140      string)
 141     integer))
 142
 143 (defun canlock-sha1-with-ssleay (message)
 144   "Make a SHA1 digest from a specified message (string) with SSLeay."
 145   (with-temp-buffer
 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))
 152       (insert message)
 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)
 159         (delete-char 2))
 160       (buffer-substring (point-min) (point)))))
 161
 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'."
 166   (let ((prompt
 167          (if args
 168              (apply 'format prompt args)
 169            prompt)))
 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)))
 177
 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
 184                          password
 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)))
 189                          password ""))
 190         (opad (mapconcat (lambda (char)
 191                            (char-to-string (logxor 92 char)))
 192                          password "")))
 193     (funcall canlock-base64-encode-function
 194              (funcall canlock-sha1-function
 195                       (concat
 196                        opad
 197                        (funcall canlock-sha1-function
 198                                 (concat ipad message-id)))))))
 199
 200 (defun canlock-narrow-to-header ()
 201   "Narrow to the message header."
 202   (let (case-fold-search)
 203     (narrow-to-region
 204      (goto-char (point-min))
 205      (goto-char (if (re-search-forward
 206                      (format "^$\\|^%s$"
 207                              (regexp-quote mail-header-separator))
 208                      nil t)
 209                     (match-beginning 0)
 210                   (point-max))))))
 211
 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))
 221                        (point-max))))))
 222
 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))
 229     (when feild
 230       (mapcar (lambda (str)
 231                 (string-match "^sha1:" str)
 232                 (substring str (match-end 0)))
 233               (split-string feild "[\t\n\r ,]+")))))
 234
 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")))
 239     (if cancel
 240         (progn
 241           (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
 242                         cancel)
 243           (match-string 1 cancel))
 244       (or (mail-fetch-field "Supersedes")
 245           (mail-fetch-field "Replaces")))))
 246
 247 ;;;###autoload
 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)
 251     (save-excursion
 252       (save-restriction
 253         (canlock-narrow-to-header)
 254         (when (setq news (or canlock-force-insert-header
 255                              (mail-fetch-field "Newsgroups")))
 256           (unless id-for-key
 257             (setq id-for-key (canlock-fetch-id-for-key)))
 258           (if (and (setq control (mail-fetch-field "Control"))
 259                    (string-match
 260                     "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
 261                     control))
 262               (setq id-for-lock nil)
 263             (unless id-for-lock
 264               (setq id-for-lock (mail-fetch-field "Message-ID"))))
 265           (canlock-delete-headers)
 266           (goto-char (point-max))))
 267       (when news
 268         (if (not (or id-for-key id-for-lock))
 269             (message "There are no Message-ID(s).")
 270           (unless password
 271             (setq password (or canlock-password
 272                                (canlock-read-passwd
 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.")
 284               (when key-for-key
 285                 (insert "Cancel-Key: sha1:" key-for-key "\n"))
 286               (when key-for-lock
 287                 (insert "Cancel-Lock: sha1:"
 288                         (funcall canlock-base64-encode-function
 289                                  (funcall canlock-sha1-function
 290                                           key-for-lock))
 291                         "\n")))))))))
 292
 293 ;;;###autoload
 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."
 298   (interactive)
 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)
 303     (save-excursion
 304       (when buffer
 305         (set-buffer buffer))
 306       (save-restriction
 307         (widen)
 308         (canlock-narrow-to-header)
 309         (setq keys (canlock-fetch-fields 'key)
 310               locks (canlock-fetch-fields))
 311         (if (not (or keys locks))
 312             (setq errmsg
 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).")))))
 318
 319     (if errmsg
 320         (if canlock-ignore-errors
 321             errmsg
 322           (error "%s" errmsg))
 323
 324       (setq password (or canlock-password-for-verify
 325                          (canlock-read-passwd "Password for Canlock: ")))
 326       (if (or (not (stringp password)) (zerop (length password)))
 327           (progn
 328             (setq errmsg "Password for Canlock is bad.")
 329             (if canlock-ignore-errors
 330                 errmsg
 331               (error "%s" errmsg)))
 332
 333         (when keys
 334           (when id-for-key
 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")))
 339         (setq match nil)
 340
 341         (when locks
 342           (when id-for-lock
 343             (setq key-for-lock
 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")))
 351
 352         (prog1
 353             (when (member "bad" (list keys locks))
 354               "bad")
 355           (cond ((and keys locks)
 356                  (message "Cancel-Key is %s, Cancel-Lock is %s." keys locks))
 357                 (locks
 358                  (message "Cancel-Lock is %s." locks))
 359                 (keys
 360                  (message "Cancel-Key is %s." keys))))))))
 361
 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)
 370
 371 ;;;###autoload
 372 (defun gnus-summary-canlock-verify ()
 373   "Run `canlock-verify' from gnus summary buffer."
 374   (interactive)
 375   (gnus-summary-select-article gnus-show-all-headers)
 376   (canlock-verify gnus-original-article-buffer))
 377
 378 ;;;###autoload
 379 (defun wl-summary-canlock-verify ()
 380   "Run `canlock-verify' from Wanderlust summary buffer."
 381   (interactive)
 382   (wl-summary-set-message-buffer-or-redisplay)
 383   (canlock-verify (wl-message-get-original-buffer)))
 384
 385 (eval-when-compile
 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))))
 391       (progn
 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 ()
 396       '(condition-case nil
 397            (mew-summary-display)
 398          (wrong-number-of-arguments
 399           (mew-summary-display t))))
 400     ))
 401
 402 ;;;###autoload
 403 (defun mew-summary-canlock-verify ()
 404   "Run `canlock-verify' from Mew summary buffer."
 405   (interactive)
 406   (canlock-mew-summary-display)
 407   (canlock-verify (mew-buffer-message)))
 408
 409 ;;;###autoload
 410 (defun mh-summary-canlock-verify ()
 411   "Run `canlock-verify' from MH folder buffer."
 412   (interactive)
 413   (mh-header-display)
 414   (canlock-verify mh-show-buffer))
 415
 416 ;;;###autoload
 417 (defun vm-summary-canlock-verify ()
 418   "Run `canlock-verify' from VM summary buffer."
 419   (interactive)
 420   (vm-follow-summary-cursor)
 421   (if (and vm-mail-buffer (buffer-name vm-mail-buffer))
 422       (save-excursion
 423         (set-buffer vm-mail-buffer)
 424         (let* ((mp (car vm-message-pointer))
 425                (header (save-restriction
 426                          (widen)
 427                          (buffer-substring
 428                           (aref (aref mp 0) 0) (vm-text-of mp)))))
 429           (with-temp-buffer
 430             (insert header)
 431             (canlock-verify))))
 432     (or canlock-ignore-errors
 433         (error "Folder buffer has been killed."))))
 434
 435 ;;;###autoload
 436 (defun cmail-summary-canlock-verify ()
 437   "Run `canlock-verify' from cmail summary buffer."
 438   (interactive)
 439   (let* ((page (cmail-get-page-number-from-summary))
 440          (header (save-excursion
 441                    (set-buffer (cmail-folder-buffer cmail-current-folder))
 442                    (cmail-n-page page)
 443                    (buffer-substring (point)
 444                                      (if (search-forward "\n\n" nil t)
 445                                          (1- (point))
 446                                        (point-max))))))
 447     (with-temp-buffer
 448       (insert header)
 449       (canlock-verify))))
 450
 451 ;;;###autoload
 452 (defun rmail-summary-canlock-verify ()
 453   "Run `canlock-verify' from RMAIL summary buffer."
 454   (interactive)
 455   (rmail-summary-rmail-update)
 456   (let ((header (save-excursion
 457                   (set-buffer rmail-buffer)
 458                   (goto-char (point-min))
 459                   (save-restriction
 460                     (widen)
 461                     (search-backward "\n\C-_\C-l\n") ;; ^_^L
 462                     (re-search-forward "^[^\t\n ]+:")
 463                     (buffer-substring
 464                      (goto-char (match-beginning 0))
 465                      (progn (search-forward "\n\n")
 466                             (1- (point))))))))
 467     (with-temp-buffer
 468       (insert header)
 469       (canlock-verify))))
 470
 471 (provide 'canlock)
 472
 473 (run-hooks 'canlock-load-hook)
 474
 475 ;;; canlock.el ends here