From: yamaoka Date: Wed, 31 Oct 2001 02:42:52 +0000 (+0000) Subject: Synch with Oort Gnus. X-Git-Tag: t-gnus-6_15_4-08-quimby-last-~27 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=6f516665effb5caa4a28b37af8e837191b721f2f;p=elisp%2Fgnus.git- Synch with Oort Gnus. --- diff --git a/contrib/ChangeLog b/contrib/ChangeLog index 1778dde..77c02d2 100644 --- a/contrib/ChangeLog +++ b/contrib/ChangeLog @@ -1,3 +1,7 @@ +2001-10-30 21:00:00 ShengHuo ZHU + + * canlock.el, hex-util.el, sha1-el.el: Move to lisp. + 2001-10-30 Katsumi Yamaoka * canlock.el: (canlock-base64-encode-function): Removed. diff --git a/contrib/canlock.el b/contrib/canlock.el deleted file mode 100644 index 89673be..0000000 --- a/contrib/canlock.el +++ /dev/null @@ -1,319 +0,0 @@ -;;; canlock.el --- Functions for Cancel-Lock feature -;; Copyright (C) 1998, 1999, 2001 Free Software Foundation, Inc. - -;; Author: Katsumi Yamaoka -;; Keywords: news, cancel-lock, hmac, sha1, rfc2104 - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Canlock is a library for generating and verifying Cancel-Lock and/or -;; Cancel-Key header in news articles. This is used to protect articles -;; from rogue cancel, supersede or replace attacks. The method is based -;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November -;; 3rd 1998. For instance, you can add Cancel-Lock (and possibly Cancel- -;; Key) header in a news article by using a hook which will be evaluated -;; just before sending an article as follows: -;; -;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t) -;; -;; Verifying Cancel-Lock is mainly a function of news servers, however, -;; you can verify your own article using the command `canlock-verify' in -;; the (raw) article buffer. You will be prompted for the password for -;; each time if the option `canlock-password' or `canlock-password-for- -;; verify' is nil. Note that setting these options is a bit unsafe. - -;;; Code: - -(defconst canlock-version "0.8") - -(eval-when-compile - (require 'cl)) - -(autoload 'sha1-binary "sha1-el") -(autoload 'sha1-encode-binary "sha1") -(autoload 'base64-encode "base64") - -(defgroup canlock nil - "The Cancel-Lock feature." - :group 'applications) - -(defcustom canlock-sha1-function 'sha1-binary - "Function to call to make a SHA-1 message digest." - :type '(radio (function-item sha1-encode-binary) - (function-item sha1-binary) - (function-item canlock-sha1-with-openssl) - (function :tag "Other")) - :group 'canlock) - -(defcustom canlock-sha1-function-for-verify canlock-sha1-function - "Function to call to make a SHA-1 message digest for verifying." - :type '(radio (function-item sha1-encode-binary) - (function-item sha1-binary) - (function-item canlock-sha1-with-openssl) - (function :tag "Other")) - :group 'canlock) - -(defcustom canlock-openssl-program "openssl" - "Name of OpenSSL program." - :type 'string - :group 'canlock) - -(defcustom canlock-openssl-args '("sha1") - "Arguments passed to the OpenSSL program." - :type 'sexp - :group 'canlock) - -(defcustom canlock-ignore-errors nil - "If non-nil, ignore any error signals." - :type 'boolean - :group 'canlock) - -(defcustom canlock-password nil - "Password to use when signing a Cancel-Lock or a Cancel-Key header." - :type 'string - :group 'canlock) - -(defcustom canlock-password-for-verify canlock-password - "Password to use when verifying a Cancel-Lock or a Cancel-Key header." - :type 'string - :group 'canlock) - -(defcustom canlock-force-insert-header nil - "If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the -buffer does not look like a news message." - :type 'boolean - :group 'canlock) - -(defun canlock-sha1-with-openssl (message) - "Make a SHA-1 digest of MESSAGE using OpenSSL." - (with-temp-buffer - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - selective-display - (case-fold-search t)) - (insert message) - (apply 'call-process-region (point-min) (point-max) - canlock-openssl-program t t nil canlock-openssl-args) - (goto-char (point-min)) - (while (re-search-forward "[0-9a-f][0-9a-f]" nil t) - (replace-match (read (concat "\"\\x" (match-string 0) "\"")))) - (buffer-substring (point-min) (point))))) - -(defvar canlock-read-passwd nil) -(defun canlock-read-passwd (prompt &rest args) - "Read a password using PROMPT. -If ARGS, PROMPT is used as an argument to `format'." - (let ((prompt - (if args - (apply 'format prompt args) - prompt))) - (unless canlock-read-passwd - (if (or (fboundp 'read-passwd) (load "passwd" t)) - (setq canlock-read-passwd 'read-passwd) - (unless (fboundp 'ange-ftp-read-passwd) - (autoload 'ange-ftp-read-passwd "ange-ftp")) - (setq canlock-read-passwd 'ange-ftp-read-passwd))) - (funcall canlock-read-passwd prompt))) - -(defun canlock-make-cancel-key (message-id password) - "Make a Cancel-Key header." - (cond ((> (length password) 20) - (setq password (funcall canlock-sha1-function password))) - ((< (length password) 20) - (setq password (concat - password - (make-string (- 20 (length password)) 0))))) - (setq password (concat password (make-string 44 0))) - (let ((ipad (mapconcat (lambda (char) - (char-to-string (logxor 54 char))) - password "")) - (opad (mapconcat (lambda (char) - (char-to-string (logxor 92 char))) - password ""))) - (base64-encode-string (funcall canlock-sha1-function - (concat - opad - (funcall canlock-sha1-function - (concat ipad message-id))))))) - -(defun canlock-narrow-to-header () - "Narrow the buffer to the head of the message." - (let (case-fold-search) - (narrow-to-region - (goto-char (point-min)) - (goto-char (if (re-search-forward - (format "^$\\|^%s$" - (regexp-quote mail-header-separator)) - nil t) - (match-beginning 0) - (point-max)))))) - -(defun canlock-delete-headers () - "Delete Cancel-Key or Cancel-Lock headers in the narrowed buffer." - (let ((case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t) - (delete-region (match-beginning 0) - (if (re-search-forward "^[^\t ]" nil t) - (goto-char (match-beginning 0)) - (point-max)))))) - -(defun canlock-fetch-fields (&optional key) - "Return a list of the values of Cancel-Lock header. -If KEY is non-nil, look for a Cancel-Key header instead. The buffer -is expected to be narrowed to just the headers of the message." - (let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock"))) - fields rest - (case-fold-search t)) - (when field - (setq fields (split-string field "[\t\n\r ,]+")) - (while fields - (when (string-match "^sha1:" (setq field (pop fields))) - (push (substring field 5) rest))) - (nreverse rest)))) - -(defun canlock-fetch-id-for-key () - "Return a Message-ID in Cancel, Supersedes or Replaces header. -The buffer is expected to be narrowed to just the headers of the -message." - (or (let ((cancel (mail-fetch-field "Control"))) - (and cancel - (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" - cancel) - (match-string 1 cancel))) - (mail-fetch-field "Supersedes") - (mail-fetch-field "Replaces"))) - -;;;###autoload -(defun canlock-insert-header (&optional id-for-key id-for-lock password) - "Insert a Cancel-Key and/or a Cancel-Lock header if possible." - (let (news control key-for-key key-for-lock) - (save-excursion - (save-restriction - (canlock-narrow-to-header) - (when (setq news (or canlock-force-insert-header - (mail-fetch-field "Newsgroups"))) - (unless id-for-key - (setq id-for-key (canlock-fetch-id-for-key))) - (if (and (setq control (mail-fetch-field "Control")) - (string-match - "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" - control)) - (setq id-for-lock nil) - (unless id-for-lock - (setq id-for-lock (mail-fetch-field "Message-ID")))) - (canlock-delete-headers) - (goto-char (point-max)))) - (when news - (if (not (or id-for-key id-for-lock)) - (message "There are no Message-ID(s)") - (unless password - (setq password (or canlock-password - (canlock-read-passwd - "Password for Canlock: ")))) - (if (or (not (stringp password)) (zerop (length password))) - (message "Password for Canlock is bad") - (setq key-for-key (when id-for-key - (canlock-make-cancel-key - id-for-key password)) - key-for-lock (when id-for-lock - (canlock-make-cancel-key - id-for-lock password))) - (if (not (or key-for-key key-for-lock)) - (message "Couldn't insert Canlock header") - (when key-for-key - (insert "Cancel-Key: sha1:" key-for-key "\n")) - (when key-for-lock - (insert "Cancel-Lock: sha1:" - (base64-encode-string (funcall canlock-sha1-function - key-for-lock)) - "\n"))))))))) - -;;;###autoload -(defun canlock-verify (&optional buffer) - "Verify Cancel-Lock or Cancel-Key in BUFFER. -If BUFFER is nil, the current buffer is assumed. Signal an error if -it fails. You can modify the behavior of this function to return non- -nil instead of to signal an error by setting the option -`canlock-ignore-errors' to non-nil." - (interactive) - (let ((canlock-sha1-function (or canlock-sha1-function-for-verify - canlock-sha1-function)) - keys locks errmsg id-for-key id-for-lock password - key-for-key key-for-lock match) - (save-excursion - (when buffer - (set-buffer buffer)) - (save-restriction - (widen) - (canlock-narrow-to-header) - (setq keys (canlock-fetch-fields 'key) - locks (canlock-fetch-fields)) - (if (not (or keys locks)) - (setq errmsg - "There are neither Cancel-Lock nor Cancel-Key headers") - (setq id-for-key (canlock-fetch-id-for-key) - id-for-lock (mail-fetch-field "Message-ID")) - (or id-for-key id-for-lock - (setq errmsg "There are no Message-ID(s)"))))) - - (if errmsg - (if canlock-ignore-errors - errmsg - (error "%s" errmsg)) - - (setq password (or canlock-password-for-verify - (canlock-read-passwd "Password for Canlock: "))) - (if (or (not (stringp password)) (zerop (length password))) - (progn - (setq errmsg "Password for Canlock is bad") - (if canlock-ignore-errors - errmsg - (error "%s" errmsg))) - - (when keys - (when id-for-key - (setq key-for-key (canlock-make-cancel-key id-for-key password)) - (while (and keys (not match)) - (setq match (string-equal key-for-key (pop keys))))) - (setq keys (if match "good" "bad"))) - (setq match nil) - - (when locks - (when id-for-lock - (setq key-for-lock - (base64-encode-string (funcall canlock-sha1-function - (canlock-make-cancel-key - id-for-lock password)))) - (when (and locks (not match)) - (setq match (string-equal key-for-lock (pop locks))))) - (setq locks (if match "good" "bad"))) - - (prog1 - (when (member "bad" (list keys locks)) - "bad") - (cond ((and keys locks) - (message "Cancel-Key is %s, Cancel-Lock is %s" keys locks)) - (locks - (message "Cancel-Lock is %s" locks)) - (keys - (message "Cancel-Key is %s" keys)))))))) - -(provide 'canlock) - -;;; canlock.el ends here diff --git a/contrib/hex-util.el b/contrib/hex-util.el deleted file mode 100644 index ddf154d..0000000 --- a/contrib/hex-util.el +++ /dev/null @@ -1,73 +0,0 @@ -;;; hex-util.el --- Functions to encode/decode hexadecimal string. - -;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. - -;; Author: Shuhei KOBAYASHI -;; Keywords: data - -;; This file is part of FLIM (Faithful Library about Internet Message). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; Code: - -(eval-when-compile - (defmacro hex-char-to-num (chr) - (` (let ((chr (, chr))) - (cond - ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10)) - ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10)) - ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) - (t (error "Invalid hexadecimal digit `%c'" chr)))))) - (defmacro num-to-hex-char (num) - (` (aref "0123456789abcdef" (, num))))) - -(defun decode-hex-string (string) - "Decode hexadecimal STRING to octet string." - (let* ((len (length string)) - (dst (make-string (/ len 2) 0)) - (idx 0)(pos 0)) - (while (< pos len) -;;; logior and lsh are not byte-coded. -;;; (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4) -;;; (hex-char-to-num (aref string (1+ pos))))) - (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16) - (hex-char-to-num (aref string (1+ pos))))) - (setq idx (1+ idx) - pos (+ 2 pos))) - dst)) - -(defun encode-hex-string (string) - "Encode octet STRING to hexadecimal string." - (let* ((len (length string)) - (dst (make-string (* len 2) 0)) - (idx 0)(pos 0)) - (while (< pos len) -;;; logand and lsh are not byte-coded. -;;; (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15))) - (aset dst idx (num-to-hex-char (/ (aref string pos) 16))) - (setq idx (1+ idx)) -;;; (aset dst idx (num-to-hex-char (logand (aref string pos) 15))) - (aset dst idx (num-to-hex-char (% (aref string pos) 16))) - (setq idx (1+ idx) - pos (1+ pos))) - dst)) - -(provide 'hex-util) - -;;; hex-util.el ends here diff --git a/contrib/sha1-el.el b/contrib/sha1-el.el deleted file mode 100644 index 15c1f5a..0000000 --- a/contrib/sha1-el.el +++ /dev/null @@ -1,423 +0,0 @@ -;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp. - -;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. - -;; Author: Shuhei KOBAYASHI -;; Keywords: SHA1, FIPS 180-1 - -;; This file is part of FLIM (Faithful Library about Internet Message). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This program is implemented from the definition of SHA-1 in FIPS PUB -;; 180-1 (Federal Information Processing Standards Publication 180-1), -;; "Announcing the Standard for SECURE HASH STANDARD". -;; -;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c) -;; -;; Test cases from FIPS PUB 180-1. -;; -;; (sha1 "abc") -;; => a9993e364706816aba3e25717850c26c9cd0d89d -;; -;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") -;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1 -;; -;; (sha1 (make-string 1000000 ?a)) -;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f -;; -;; BUGS: -;; * It is assumed that length of input string is less than 2^29 bytes. -;; * It is caller's responsibility to make string (or region) unibyte. -;; -;; TODO: -;; * Rewrite from scratch! -;; This version is much faster than Keiichi Suzuki's another sha1.el, -;; but it is too dirty. - -;;; Code: - -(require 'hex-util) - -;;; -;;; external SHA1 function. -;;; - -(defvar sha1-maximum-internal-length 500 - "*Maximum length of message to use lisp version of SHA1 function. -If message is longer than this, `sha1-program' is used instead. - -If this variable is set to 0, use extarnal program only. -If this variable is set to nil, use internal function only.") - -(defvar sha1-program '("openssl" "sha1") - "*Name of program to compute SHA1. -It must be a string \(program name\) or list of strings \(name and its args\).") - -(defun sha1-string-external (string) - ;; `with-temp-buffer' is new in v20, so we do not use it. - (save-excursion - (let (buffer) - (unwind-protect - (let (prog args) - (if (consp sha1-program) - (setq prog (car sha1-program) - args (cdr sha1-program)) - (setq prog sha1-program - args nil)) - (setq buffer (set-buffer - (generate-new-buffer " *sha1 external*"))) - (insert string) - (apply (function call-process-region) - (point-min)(point-max) - prog t t nil args) - ;; SHA1 is 40 bytes long in hexadecimal form. - (buffer-substring (point-min)(+ (point-min) 40))) - (and buffer - (buffer-name buffer) - (kill-buffer buffer)))))) - -(defun sha1-region-external (beg end) - (sha1-string-external (buffer-substring-no-properties beg end))) - -;;; -;;; internal SHA1 function. -;;; - -(eval-when-compile - ;; optional second arg of string-to-number is new in v20. - (defconst sha1-K0-high 23170) ; (string-to-number "5A82" 16) - (defconst sha1-K0-low 31129) ; (string-to-number "7999" 16) - (defconst sha1-K1-high 28377) ; (string-to-number "6ED9" 16) - (defconst sha1-K1-low 60321) ; (string-to-number "EBA1" 16) - (defconst sha1-K2-high 36635) ; (string-to-number "8F1B" 16) - (defconst sha1-K2-low 48348) ; (string-to-number "BCDC" 16) - (defconst sha1-K3-high 51810) ; (string-to-number "CA62" 16) - (defconst sha1-K3-low 49622) ; (string-to-number "C1D6" 16) - -;;; original definition of sha1-F0. -;;; (defmacro sha1-F0 (B C D) -;;; (` (logior (logand (, B) (, C)) -;;; (logand (lognot (, B)) (, D))))) -;;; a little optimization from GnuPG/cipher/sha1.c. - (defmacro sha1-F0 (B C D) - (` (logxor (, D) (logand (, B) (logxor (, C) (, D)))))) - (defmacro sha1-F1 (B C D) - (` (logxor (, B) (, C) (, D)))) -;;; original definition of sha1-F2. -;;; (defmacro sha1-F2 (B C D) -;;; (` (logior (logand (, B) (, C)) -;;; (logand (, B) (, D)) -;;; (logand (, C) (, D))))) -;;; a little optimization from GnuPG/cipher/sha1.c. - (defmacro sha1-F2 (B C D) - (` (logior (logand (, B) (, C)) - (logand (, D) (logior (, B) (, C)))))) - (defmacro sha1-F3 (B C D) - (` (logxor (, B) (, C) (, D)))) - - (defmacro sha1-S1 (W-high W-low) - (` (let ((W-high (, W-high)) - (W-low (, W-low))) - (setq S1W-high (+ (% (* W-high 2) 65536) - (/ W-low (, (/ 65536 2))))) - (setq S1W-low (+ (/ W-high (, (/ 65536 2))) - (% (* W-low 2) 65536)))))) - (defmacro sha1-S5 (A-high A-low) - (` (progn - (setq S5A-high (+ (% (* (, A-high) 32) 65536) - (/ (, A-low) (, (/ 65536 32))))) - (setq S5A-low (+ (/ (, A-high) (, (/ 65536 32))) - (% (* (, A-low) 32) 65536)))))) - (defmacro sha1-S30 (B-high B-low) - (` (progn - (setq S30B-high (+ (/ (, B-high) 4) - (* (% (, B-low) 4) (, (/ 65536 4))))) - (setq S30B-low (+ (/ (, B-low) 4) - (* (% (, B-high) 4) (, (/ 65536 4)))))))) - - (defmacro sha1-OP (round) - (` (progn - (sha1-S5 sha1-A-high sha1-A-low) - (sha1-S30 sha1-B-high sha1-B-low) - (setq sha1-A-low (+ ((, (intern (format "sha1-F%d" round))) - sha1-B-low sha1-C-low sha1-D-low) - sha1-E-low - (, (symbol-value - (intern (format "sha1-K%d-low" round)))) - (aref block-low idx) - (progn - (setq sha1-E-low sha1-D-low) - (setq sha1-D-low sha1-C-low) - (setq sha1-C-low S30B-low) - (setq sha1-B-low sha1-A-low) - S5A-low))) - (setq carry (/ sha1-A-low 65536)) - (setq sha1-A-low (% sha1-A-low 65536)) - (setq sha1-A-high (% (+ ((, (intern (format "sha1-F%d" round))) - sha1-B-high sha1-C-high sha1-D-high) - sha1-E-high - (, (symbol-value - (intern (format "sha1-K%d-high" round)))) - (aref block-high idx) - (progn - (setq sha1-E-high sha1-D-high) - (setq sha1-D-high sha1-C-high) - (setq sha1-C-high S30B-high) - (setq sha1-B-high sha1-A-high) - S5A-high) - carry) - 65536))))) - - (defmacro sha1-add-to-H (H X) - (` (progn - (setq (, (intern (format "sha1-%s-low" H))) - (+ (, (intern (format "sha1-%s-low" H))) - (, (intern (format "sha1-%s-low" X))))) - (setq carry (/ (, (intern (format "sha1-%s-low" H))) 65536)) - (setq (, (intern (format "sha1-%s-low" H))) - (% (, (intern (format "sha1-%s-low" H))) 65536)) - (setq (, (intern (format "sha1-%s-high" H))) - (% (+ (, (intern (format "sha1-%s-high" H))) - (, (intern (format "sha1-%s-high" X))) - carry) - 65536))))) - ) - -;;; buffers (H0 H1 H2 H3 H4). -(defvar sha1-H0-high) -(defvar sha1-H0-low) -(defvar sha1-H1-high) -(defvar sha1-H1-low) -(defvar sha1-H2-high) -(defvar sha1-H2-low) -(defvar sha1-H3-high) -(defvar sha1-H3-low) -(defvar sha1-H4-high) -(defvar sha1-H4-low) - -(defun sha1-block (block-high block-low) - (let (;; step (c) --- initialize buffers (A B C D E). - (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low) - (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low) - (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low) - (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low) - (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low) - (idx 16)) - ;; step (b). - (let (;; temporary variables used in sha1-S1 macro. - S1W-high S1W-low) - (while (< idx 80) - (sha1-S1 (logxor (aref block-high (- idx 3)) - (aref block-high (- idx 8)) - (aref block-high (- idx 14)) - (aref block-high (- idx 16))) - (logxor (aref block-low (- idx 3)) - (aref block-low (- idx 8)) - (aref block-low (- idx 14)) - (aref block-low (- idx 16)))) - (aset block-high idx S1W-high) - (aset block-low idx S1W-low) - (setq idx (1+ idx)))) - ;; step (d). - (setq idx 0) - (let (;; temporary variables used in sha1-OP macro. - S5A-high S5A-low S30B-high S30B-low carry) - (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx))) - (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx))) - (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx))) - (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx)))) - ;; step (e). - (let (;; temporary variables used in sha1-add-to-H macro. - carry) - (sha1-add-to-H H0 A) - (sha1-add-to-H H1 B) - (sha1-add-to-H H2 C) - (sha1-add-to-H H3 D) - (sha1-add-to-H H4 E)))) - -(defun sha1-binary (string) - "Return the SHA1 of STRING in binary form." - (let (;; prepare buffers for a block. byte-length of block is 64. - ;; input block is split into two vectors. - ;; - ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ... - ;; block-high: +-0-+ +-1-+ +-2-+ +-3-+ - ;; block-low: +-0-+ +-1-+ +-2-+ +-3-+ - ;; - ;; length of each vector is 80, and elements of each vector are - ;; 16bit integers. elements 0x10-0x4F of each vector are - ;; assigned later in `sha1-block'. - (block-high (eval-when-compile (make-vector 80 nil))) - (block-low (eval-when-compile (make-vector 80 nil)))) - (unwind-protect - (let* (;; byte-length of input string. - (len (length string)) - (lim (* (/ len 64) 64)) - (rem (% len 4)) - (idx 0)(pos 0)) - ;; initialize buffers (H0 H1 H2 H3 H4). - (setq sha1-H0-high 26437 ; (string-to-number "6745" 16) - sha1-H0-low 8961 ; (string-to-number "2301" 16) - sha1-H1-high 61389 ; (string-to-number "EFCD" 16) - sha1-H1-low 43913 ; (string-to-number "AB89" 16) - sha1-H2-high 39098 ; (string-to-number "98BA" 16) - sha1-H2-low 56574 ; (string-to-number "DCFE" 16) - sha1-H3-high 4146 ; (string-to-number "1032" 16) - sha1-H3-low 21622 ; (string-to-number "5476" 16) - sha1-H4-high 50130 ; (string-to-number "C3D2" 16) - sha1-H4-low 57840) ; (string-to-number "E1F0" 16) - ;; loop for each 64 bytes block. - (while (< pos lim) - ;; step (a). - (setq idx 0) - (while (< idx 16) - (aset block-high idx (+ (* (aref string pos) 256) - (aref string (1+ pos)))) - (setq pos (+ pos 2)) - (aset block-low idx (+ (* (aref string pos) 256) - (aref string (1+ pos)))) - (setq pos (+ pos 2)) - (setq idx (1+ idx))) - (sha1-block block-high block-low)) - ;; last block. - (if (prog1 - (< (- len lim) 56) - (setq lim (- len rem)) - (setq idx 0) - (while (< pos lim) - (aset block-high idx (+ (* (aref string pos) 256) - (aref string (1+ pos)))) - (setq pos (+ pos 2)) - (aset block-low idx (+ (* (aref string pos) 256) - (aref string (1+ pos)))) - (setq pos (+ pos 2)) - (setq idx (1+ idx))) - ;; this is the last (at most) 32bit word. - (cond - ((= rem 3) - (aset block-high idx (+ (* (aref string pos) 256) - (aref string (1+ pos)))) - (setq pos (+ pos 2)) - (aset block-low idx (+ (* (aref string pos) 256) - 128))) - ((= rem 2) - (aset block-high idx (+ (* (aref string pos) 256) - (aref string (1+ pos)))) - (aset block-low idx 32768)) - ((= rem 1) - (aset block-high idx (+ (* (aref string pos) 256) - 128)) - (aset block-low idx 0)) - (t ;; (= rem 0) - (aset block-high idx 32768) - (aset block-low idx 0))) - (setq idx (1+ idx)) - (while (< idx 16) - (aset block-high idx 0) - (aset block-low idx 0) - (setq idx (1+ idx)))) - ;; last block has enough room to write the length of string. - (progn - ;; write bit length of string to last 4 bytes of the block. - (aset block-low 15 (* (% len 8192) 8)) - (setq len (/ len 8192)) - (aset block-high 15 (% len 65536)) - ;; XXX: It is not practical to compute SHA1 of - ;; such a huge message on emacs. - ;; (setq len (/ len 65536)) ; for 64bit emacs. - ;; (aset block-low 14 (% len 65536)) - ;; (aset block-high 14 (/ len 65536)) - (sha1-block block-high block-low)) - ;; need one more block. - (sha1-block block-high block-low) - (fillarray block-high 0) - (fillarray block-low 0) - ;; write bit length of string to last 4 bytes of the block. - (aset block-low 15 (* (% len 8192) 8)) - (setq len (/ len 8192)) - (aset block-high 15 (% len 65536)) - ;; XXX: It is not practical to compute SHA1 of - ;; such a huge message on emacs. - ;; (setq len (/ len 65536)) ; for 64bit emacs. - ;; (aset block-low 14 (% len 65536)) - ;; (aset block-high 14 (/ len 65536)) - (sha1-block block-high block-low)) - ;; make output string (in binary form). - (let ((result (make-string 20 0))) - (aset result 0 (/ sha1-H0-high 256)) - (aset result 1 (% sha1-H0-high 256)) - (aset result 2 (/ sha1-H0-low 256)) - (aset result 3 (% sha1-H0-low 256)) - (aset result 4 (/ sha1-H1-high 256)) - (aset result 5 (% sha1-H1-high 256)) - (aset result 6 (/ sha1-H1-low 256)) - (aset result 7 (% sha1-H1-low 256)) - (aset result 8 (/ sha1-H2-high 256)) - (aset result 9 (% sha1-H2-high 256)) - (aset result 10 (/ sha1-H2-low 256)) - (aset result 11 (% sha1-H2-low 256)) - (aset result 12 (/ sha1-H3-high 256)) - (aset result 13 (% sha1-H3-high 256)) - (aset result 14 (/ sha1-H3-low 256)) - (aset result 15 (% sha1-H3-low 256)) - (aset result 16 (/ sha1-H4-high 256)) - (aset result 17 (% sha1-H4-high 256)) - (aset result 18 (/ sha1-H4-low 256)) - (aset result 19 (% sha1-H4-low 256)) - result)) - ;; do not leave a copy of input string. - (fillarray block-high nil) - (fillarray block-low nil)))) - -(defun sha1-string-internal (string) - (encode-hex-string (sha1-binary string))) - -(defun sha1-region-internal (beg end) - (sha1-string-internal (buffer-substring-no-properties beg end))) - -;;; -;;; application interface. -;;; - -(defun sha1-region (beg end) - (if (and sha1-maximum-internal-length - (> (abs (- end beg)) sha1-maximum-internal-length)) - (sha1-region-external beg end) - (sha1-region-internal beg end))) - -(defun sha1-string (string) - (if (and sha1-maximum-internal-length - (> (length string) sha1-maximum-internal-length)) - (sha1-string-external string) - (sha1-string-internal string))) - -(defun sha1 (object &optional beg end) - "Return the SHA1 (Secure Hash Algorithm) of an object. -OBJECT is either a string or a buffer. -Optional arguments BEG and END denote buffer positions for computing the -hash of a portion of OBJECT." - (if (stringp object) - (sha1-string object) - (save-excursion - (set-buffer object) - (sha1-region (or beg (point-min)) (or end (point-max)))))) - -(provide 'sha1-el) - -;;; sha1-el.el ends here diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 5b84e9d..7606275 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,21 @@ +2001-10-30 21:00:00 ShengHuo ZHU + + * canlock.el, sha1-el.el, hex-util.el: Move from contrib + directory. Thanks to Katsumi Yamaoka and Shuhei + KOBAYASHI . + +2001-10-30 20:00:00 ShengHuo ZHU + + * gnus-art.el (article-display-x-face): Nix buffer-read-only + again. + + * mml2015.el (mml2015-gpg-verify): Convert to . + +2001-10-30 13:00:00 ShengHuo ZHU + + * gnus-spec.el (gnus-parse-simple-format): Use + buffer-substring-no-properties. + 2001-10-30 Katsumi Yamaoka * gnus-art.el (article-verify-cancel-lock): New function. diff --git a/lisp/canlock.el b/lisp/canlock.el new file mode 100644 index 0000000..89673be --- /dev/null +++ b/lisp/canlock.el @@ -0,0 +1,319 @@ +;;; canlock.el --- Functions for Cancel-Lock feature +;; Copyright (C) 1998, 1999, 2001 Free Software Foundation, Inc. + +;; Author: Katsumi Yamaoka +;; Keywords: news, cancel-lock, hmac, sha1, rfc2104 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Canlock is a library for generating and verifying Cancel-Lock and/or +;; Cancel-Key header in news articles. This is used to protect articles +;; from rogue cancel, supersede or replace attacks. The method is based +;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November +;; 3rd 1998. For instance, you can add Cancel-Lock (and possibly Cancel- +;; Key) header in a news article by using a hook which will be evaluated +;; just before sending an article as follows: +;; +;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t) +;; +;; Verifying Cancel-Lock is mainly a function of news servers, however, +;; you can verify your own article using the command `canlock-verify' in +;; the (raw) article buffer. You will be prompted for the password for +;; each time if the option `canlock-password' or `canlock-password-for- +;; verify' is nil. Note that setting these options is a bit unsafe. + +;;; Code: + +(defconst canlock-version "0.8") + +(eval-when-compile + (require 'cl)) + +(autoload 'sha1-binary "sha1-el") +(autoload 'sha1-encode-binary "sha1") +(autoload 'base64-encode "base64") + +(defgroup canlock nil + "The Cancel-Lock feature." + :group 'applications) + +(defcustom canlock-sha1-function 'sha1-binary + "Function to call to make a SHA-1 message digest." + :type '(radio (function-item sha1-encode-binary) + (function-item sha1-binary) + (function-item canlock-sha1-with-openssl) + (function :tag "Other")) + :group 'canlock) + +(defcustom canlock-sha1-function-for-verify canlock-sha1-function + "Function to call to make a SHA-1 message digest for verifying." + :type '(radio (function-item sha1-encode-binary) + (function-item sha1-binary) + (function-item canlock-sha1-with-openssl) + (function :tag "Other")) + :group 'canlock) + +(defcustom canlock-openssl-program "openssl" + "Name of OpenSSL program." + :type 'string + :group 'canlock) + +(defcustom canlock-openssl-args '("sha1") + "Arguments passed to the OpenSSL program." + :type 'sexp + :group 'canlock) + +(defcustom canlock-ignore-errors nil + "If non-nil, ignore any error signals." + :type 'boolean + :group 'canlock) + +(defcustom canlock-password nil + "Password to use when signing a Cancel-Lock or a Cancel-Key header." + :type 'string + :group 'canlock) + +(defcustom canlock-password-for-verify canlock-password + "Password to use when verifying a Cancel-Lock or a Cancel-Key header." + :type 'string + :group 'canlock) + +(defcustom canlock-force-insert-header nil + "If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the +buffer does not look like a news message." + :type 'boolean + :group 'canlock) + +(defun canlock-sha1-with-openssl (message) + "Make a SHA-1 digest of MESSAGE using OpenSSL." + (with-temp-buffer + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + selective-display + (case-fold-search t)) + (insert message) + (apply 'call-process-region (point-min) (point-max) + canlock-openssl-program t t nil canlock-openssl-args) + (goto-char (point-min)) + (while (re-search-forward "[0-9a-f][0-9a-f]" nil t) + (replace-match (read (concat "\"\\x" (match-string 0) "\"")))) + (buffer-substring (point-min) (point))))) + +(defvar canlock-read-passwd nil) +(defun canlock-read-passwd (prompt &rest args) + "Read a password using PROMPT. +If ARGS, PROMPT is used as an argument to `format'." + (let ((prompt + (if args + (apply 'format prompt args) + prompt))) + (unless canlock-read-passwd + (if (or (fboundp 'read-passwd) (load "passwd" t)) + (setq canlock-read-passwd 'read-passwd) + (unless (fboundp 'ange-ftp-read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp")) + (setq canlock-read-passwd 'ange-ftp-read-passwd))) + (funcall canlock-read-passwd prompt))) + +(defun canlock-make-cancel-key (message-id password) + "Make a Cancel-Key header." + (cond ((> (length password) 20) + (setq password (funcall canlock-sha1-function password))) + ((< (length password) 20) + (setq password (concat + password + (make-string (- 20 (length password)) 0))))) + (setq password (concat password (make-string 44 0))) + (let ((ipad (mapconcat (lambda (char) + (char-to-string (logxor 54 char))) + password "")) + (opad (mapconcat (lambda (char) + (char-to-string (logxor 92 char))) + password ""))) + (base64-encode-string (funcall canlock-sha1-function + (concat + opad + (funcall canlock-sha1-function + (concat ipad message-id))))))) + +(defun canlock-narrow-to-header () + "Narrow the buffer to the head of the message." + (let (case-fold-search) + (narrow-to-region + (goto-char (point-min)) + (goto-char (if (re-search-forward + (format "^$\\|^%s$" + (regexp-quote mail-header-separator)) + nil t) + (match-beginning 0) + (point-max)))))) + +(defun canlock-delete-headers () + "Delete Cancel-Key or Cancel-Lock headers in the narrowed buffer." + (let ((case-fold-search t)) + (goto-char (point-min)) + (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t) + (delete-region (match-beginning 0) + (if (re-search-forward "^[^\t ]" nil t) + (goto-char (match-beginning 0)) + (point-max)))))) + +(defun canlock-fetch-fields (&optional key) + "Return a list of the values of Cancel-Lock header. +If KEY is non-nil, look for a Cancel-Key header instead. The buffer +is expected to be narrowed to just the headers of the message." + (let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock"))) + fields rest + (case-fold-search t)) + (when field + (setq fields (split-string field "[\t\n\r ,]+")) + (while fields + (when (string-match "^sha1:" (setq field (pop fields))) + (push (substring field 5) rest))) + (nreverse rest)))) + +(defun canlock-fetch-id-for-key () + "Return a Message-ID in Cancel, Supersedes or Replaces header. +The buffer is expected to be narrowed to just the headers of the +message." + (or (let ((cancel (mail-fetch-field "Control"))) + (and cancel + (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" + cancel) + (match-string 1 cancel))) + (mail-fetch-field "Supersedes") + (mail-fetch-field "Replaces"))) + +;;;###autoload +(defun canlock-insert-header (&optional id-for-key id-for-lock password) + "Insert a Cancel-Key and/or a Cancel-Lock header if possible." + (let (news control key-for-key key-for-lock) + (save-excursion + (save-restriction + (canlock-narrow-to-header) + (when (setq news (or canlock-force-insert-header + (mail-fetch-field "Newsgroups"))) + (unless id-for-key + (setq id-for-key (canlock-fetch-id-for-key))) + (if (and (setq control (mail-fetch-field "Control")) + (string-match + "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" + control)) + (setq id-for-lock nil) + (unless id-for-lock + (setq id-for-lock (mail-fetch-field "Message-ID")))) + (canlock-delete-headers) + (goto-char (point-max)))) + (when news + (if (not (or id-for-key id-for-lock)) + (message "There are no Message-ID(s)") + (unless password + (setq password (or canlock-password + (canlock-read-passwd + "Password for Canlock: ")))) + (if (or (not (stringp password)) (zerop (length password))) + (message "Password for Canlock is bad") + (setq key-for-key (when id-for-key + (canlock-make-cancel-key + id-for-key password)) + key-for-lock (when id-for-lock + (canlock-make-cancel-key + id-for-lock password))) + (if (not (or key-for-key key-for-lock)) + (message "Couldn't insert Canlock header") + (when key-for-key + (insert "Cancel-Key: sha1:" key-for-key "\n")) + (when key-for-lock + (insert "Cancel-Lock: sha1:" + (base64-encode-string (funcall canlock-sha1-function + key-for-lock)) + "\n"))))))))) + +;;;###autoload +(defun canlock-verify (&optional buffer) + "Verify Cancel-Lock or Cancel-Key in BUFFER. +If BUFFER is nil, the current buffer is assumed. Signal an error if +it fails. You can modify the behavior of this function to return non- +nil instead of to signal an error by setting the option +`canlock-ignore-errors' to non-nil." + (interactive) + (let ((canlock-sha1-function (or canlock-sha1-function-for-verify + canlock-sha1-function)) + keys locks errmsg id-for-key id-for-lock password + key-for-key key-for-lock match) + (save-excursion + (when buffer + (set-buffer buffer)) + (save-restriction + (widen) + (canlock-narrow-to-header) + (setq keys (canlock-fetch-fields 'key) + locks (canlock-fetch-fields)) + (if (not (or keys locks)) + (setq errmsg + "There are neither Cancel-Lock nor Cancel-Key headers") + (setq id-for-key (canlock-fetch-id-for-key) + id-for-lock (mail-fetch-field "Message-ID")) + (or id-for-key id-for-lock + (setq errmsg "There are no Message-ID(s)"))))) + + (if errmsg + (if canlock-ignore-errors + errmsg + (error "%s" errmsg)) + + (setq password (or canlock-password-for-verify + (canlock-read-passwd "Password for Canlock: "))) + (if (or (not (stringp password)) (zerop (length password))) + (progn + (setq errmsg "Password for Canlock is bad") + (if canlock-ignore-errors + errmsg + (error "%s" errmsg))) + + (when keys + (when id-for-key + (setq key-for-key (canlock-make-cancel-key id-for-key password)) + (while (and keys (not match)) + (setq match (string-equal key-for-key (pop keys))))) + (setq keys (if match "good" "bad"))) + (setq match nil) + + (when locks + (when id-for-lock + (setq key-for-lock + (base64-encode-string (funcall canlock-sha1-function + (canlock-make-cancel-key + id-for-lock password)))) + (when (and locks (not match)) + (setq match (string-equal key-for-lock (pop locks))))) + (setq locks (if match "good" "bad"))) + + (prog1 + (when (member "bad" (list keys locks)) + "bad") + (cond ((and keys locks) + (message "Cancel-Key is %s, Cancel-Lock is %s" keys locks)) + (locks + (message "Cancel-Lock is %s" locks)) + (keys + (message "Cancel-Key is %s" keys)))))))) + +(provide 'canlock) + +;;; canlock.el ends here diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 5841211..d77a5db 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1827,7 +1827,8 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." ;; We now have the area of the buffer where the X-Face is stored. (save-excursion (let ((beg (point)) - (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) + (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))) + buffer-read-only) ;; We display the face. (if (symbolp gnus-article-x-face-command) ;; The command is a lisp function, so we call it. diff --git a/lisp/gnus-spec.el b/lisp/gnus-spec.el index bbab0bc..d0d50e2 100644 --- a/lisp/gnus-spec.el +++ b/lisp/gnus-spec.el @@ -602,7 +602,7 @@ characters when given a pad value." (push el flist))) (insert elem-type) (push (car elem) flist)))) - (setq fstring (buffer-string))) + (setq fstring (buffer-substring-no-properties (point-min) (point-max)))) ;; Do some postprocessing to increase efficiency. (setq diff --git a/lisp/hex-util.el b/lisp/hex-util.el new file mode 100644 index 0000000..ddf154d --- /dev/null +++ b/lisp/hex-util.el @@ -0,0 +1,73 @@ +;;; hex-util.el --- Functions to encode/decode hexadecimal string. + +;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. + +;; Author: Shuhei KOBAYASHI +;; Keywords: data + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (defmacro hex-char-to-num (chr) + (` (let ((chr (, chr))) + (cond + ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10)) + ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10)) + ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) + (t (error "Invalid hexadecimal digit `%c'" chr)))))) + (defmacro num-to-hex-char (num) + (` (aref "0123456789abcdef" (, num))))) + +(defun decode-hex-string (string) + "Decode hexadecimal STRING to octet string." + (let* ((len (length string)) + (dst (make-string (/ len 2) 0)) + (idx 0)(pos 0)) + (while (< pos len) +;;; logior and lsh are not byte-coded. +;;; (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4) +;;; (hex-char-to-num (aref string (1+ pos))))) + (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16) + (hex-char-to-num (aref string (1+ pos))))) + (setq idx (1+ idx) + pos (+ 2 pos))) + dst)) + +(defun encode-hex-string (string) + "Encode octet STRING to hexadecimal string." + (let* ((len (length string)) + (dst (make-string (* len 2) 0)) + (idx 0)(pos 0)) + (while (< pos len) +;;; logand and lsh are not byte-coded. +;;; (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15))) + (aset dst idx (num-to-hex-char (/ (aref string pos) 16))) + (setq idx (1+ idx)) +;;; (aset dst idx (num-to-hex-char (logand (aref string pos) 15))) + (aset dst idx (num-to-hex-char (% (aref string pos) 16))) + (setq idx (1+ idx) + pos (1+ pos))) + dst)) + +(provide 'hex-util) + +;;; hex-util.el ends here diff --git a/lisp/lpath.el b/lisp/lpath.el index 2b87d7f..ef92465 100644 --- a/lisp/lpath.el +++ b/lisp/lpath.el @@ -22,7 +22,6 @@ mail-aliases-setup mm-copy-tree mule-write-region-no-coding-system put-image ring-elements - canlock-verify charsetp coding-system-p propertize make-mode-line-mouse2-map diff --git a/lisp/mml2015.el b/lisp/mml2015.el index a59ff3f..f547cd1 100644 --- a/lisp/mml2015.el +++ b/lisp/mml2015.el @@ -445,6 +445,16 @@ by you.") (with-temp-buffer (setq message (current-buffer)) (insert part) + ;; Convert to in verify mode. Sign and + ;; clearsign use --textmode. The conversion is not necessary. + ;; In clearverify, the conversion is not necessary either. + (goto-char (point-min)) + (end-of-line) + (while (not (eobp)) + (unless (eq (char-before) ?\r) + (insert "\r")) + (forward-line) + (end-of-line)) (with-temp-buffer (setq signature (current-buffer)) (unless (setq part (mm-find-part-by-type diff --git a/lisp/sha1-el.el b/lisp/sha1-el.el new file mode 100644 index 0000000..15c1f5a --- /dev/null +++ b/lisp/sha1-el.el @@ -0,0 +1,423 @@ +;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp. + +;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. + +;; Author: Shuhei KOBAYASHI +;; Keywords: SHA1, FIPS 180-1 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This program is implemented from the definition of SHA-1 in FIPS PUB +;; 180-1 (Federal Information Processing Standards Publication 180-1), +;; "Announcing the Standard for SECURE HASH STANDARD". +;; +;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c) +;; +;; Test cases from FIPS PUB 180-1. +;; +;; (sha1 "abc") +;; => a9993e364706816aba3e25717850c26c9cd0d89d +;; +;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") +;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1 +;; +;; (sha1 (make-string 1000000 ?a)) +;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f +;; +;; BUGS: +;; * It is assumed that length of input string is less than 2^29 bytes. +;; * It is caller's responsibility to make string (or region) unibyte. +;; +;; TODO: +;; * Rewrite from scratch! +;; This version is much faster than Keiichi Suzuki's another sha1.el, +;; but it is too dirty. + +;;; Code: + +(require 'hex-util) + +;;; +;;; external SHA1 function. +;;; + +(defvar sha1-maximum-internal-length 500 + "*Maximum length of message to use lisp version of SHA1 function. +If message is longer than this, `sha1-program' is used instead. + +If this variable is set to 0, use extarnal program only. +If this variable is set to nil, use internal function only.") + +(defvar sha1-program '("openssl" "sha1") + "*Name of program to compute SHA1. +It must be a string \(program name\) or list of strings \(name and its args\).") + +(defun sha1-string-external (string) + ;; `with-temp-buffer' is new in v20, so we do not use it. + (save-excursion + (let (buffer) + (unwind-protect + (let (prog args) + (if (consp sha1-program) + (setq prog (car sha1-program) + args (cdr sha1-program)) + (setq prog sha1-program + args nil)) + (setq buffer (set-buffer + (generate-new-buffer " *sha1 external*"))) + (insert string) + (apply (function call-process-region) + (point-min)(point-max) + prog t t nil args) + ;; SHA1 is 40 bytes long in hexadecimal form. + (buffer-substring (point-min)(+ (point-min) 40))) + (and buffer + (buffer-name buffer) + (kill-buffer buffer)))))) + +(defun sha1-region-external (beg end) + (sha1-string-external (buffer-substring-no-properties beg end))) + +;;; +;;; internal SHA1 function. +;;; + +(eval-when-compile + ;; optional second arg of string-to-number is new in v20. + (defconst sha1-K0-high 23170) ; (string-to-number "5A82" 16) + (defconst sha1-K0-low 31129) ; (string-to-number "7999" 16) + (defconst sha1-K1-high 28377) ; (string-to-number "6ED9" 16) + (defconst sha1-K1-low 60321) ; (string-to-number "EBA1" 16) + (defconst sha1-K2-high 36635) ; (string-to-number "8F1B" 16) + (defconst sha1-K2-low 48348) ; (string-to-number "BCDC" 16) + (defconst sha1-K3-high 51810) ; (string-to-number "CA62" 16) + (defconst sha1-K3-low 49622) ; (string-to-number "C1D6" 16) + +;;; original definition of sha1-F0. +;;; (defmacro sha1-F0 (B C D) +;;; (` (logior (logand (, B) (, C)) +;;; (logand (lognot (, B)) (, D))))) +;;; a little optimization from GnuPG/cipher/sha1.c. + (defmacro sha1-F0 (B C D) + (` (logxor (, D) (logand (, B) (logxor (, C) (, D)))))) + (defmacro sha1-F1 (B C D) + (` (logxor (, B) (, C) (, D)))) +;;; original definition of sha1-F2. +;;; (defmacro sha1-F2 (B C D) +;;; (` (logior (logand (, B) (, C)) +;;; (logand (, B) (, D)) +;;; (logand (, C) (, D))))) +;;; a little optimization from GnuPG/cipher/sha1.c. + (defmacro sha1-F2 (B C D) + (` (logior (logand (, B) (, C)) + (logand (, D) (logior (, B) (, C)))))) + (defmacro sha1-F3 (B C D) + (` (logxor (, B) (, C) (, D)))) + + (defmacro sha1-S1 (W-high W-low) + (` (let ((W-high (, W-high)) + (W-low (, W-low))) + (setq S1W-high (+ (% (* W-high 2) 65536) + (/ W-low (, (/ 65536 2))))) + (setq S1W-low (+ (/ W-high (, (/ 65536 2))) + (% (* W-low 2) 65536)))))) + (defmacro sha1-S5 (A-high A-low) + (` (progn + (setq S5A-high (+ (% (* (, A-high) 32) 65536) + (/ (, A-low) (, (/ 65536 32))))) + (setq S5A-low (+ (/ (, A-high) (, (/ 65536 32))) + (% (* (, A-low) 32) 65536)))))) + (defmacro sha1-S30 (B-high B-low) + (` (progn + (setq S30B-high (+ (/ (, B-high) 4) + (* (% (, B-low) 4) (, (/ 65536 4))))) + (setq S30B-low (+ (/ (, B-low) 4) + (* (% (, B-high) 4) (, (/ 65536 4)))))))) + + (defmacro sha1-OP (round) + (` (progn + (sha1-S5 sha1-A-high sha1-A-low) + (sha1-S30 sha1-B-high sha1-B-low) + (setq sha1-A-low (+ ((, (intern (format "sha1-F%d" round))) + sha1-B-low sha1-C-low sha1-D-low) + sha1-E-low + (, (symbol-value + (intern (format "sha1-K%d-low" round)))) + (aref block-low idx) + (progn + (setq sha1-E-low sha1-D-low) + (setq sha1-D-low sha1-C-low) + (setq sha1-C-low S30B-low) + (setq sha1-B-low sha1-A-low) + S5A-low))) + (setq carry (/ sha1-A-low 65536)) + (setq sha1-A-low (% sha1-A-low 65536)) + (setq sha1-A-high (% (+ ((, (intern (format "sha1-F%d" round))) + sha1-B-high sha1-C-high sha1-D-high) + sha1-E-high + (, (symbol-value + (intern (format "sha1-K%d-high" round)))) + (aref block-high idx) + (progn + (setq sha1-E-high sha1-D-high) + (setq sha1-D-high sha1-C-high) + (setq sha1-C-high S30B-high) + (setq sha1-B-high sha1-A-high) + S5A-high) + carry) + 65536))))) + + (defmacro sha1-add-to-H (H X) + (` (progn + (setq (, (intern (format "sha1-%s-low" H))) + (+ (, (intern (format "sha1-%s-low" H))) + (, (intern (format "sha1-%s-low" X))))) + (setq carry (/ (, (intern (format "sha1-%s-low" H))) 65536)) + (setq (, (intern (format "sha1-%s-low" H))) + (% (, (intern (format "sha1-%s-low" H))) 65536)) + (setq (, (intern (format "sha1-%s-high" H))) + (% (+ (, (intern (format "sha1-%s-high" H))) + (, (intern (format "sha1-%s-high" X))) + carry) + 65536))))) + ) + +;;; buffers (H0 H1 H2 H3 H4). +(defvar sha1-H0-high) +(defvar sha1-H0-low) +(defvar sha1-H1-high) +(defvar sha1-H1-low) +(defvar sha1-H2-high) +(defvar sha1-H2-low) +(defvar sha1-H3-high) +(defvar sha1-H3-low) +(defvar sha1-H4-high) +(defvar sha1-H4-low) + +(defun sha1-block (block-high block-low) + (let (;; step (c) --- initialize buffers (A B C D E). + (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low) + (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low) + (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low) + (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low) + (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low) + (idx 16)) + ;; step (b). + (let (;; temporary variables used in sha1-S1 macro. + S1W-high S1W-low) + (while (< idx 80) + (sha1-S1 (logxor (aref block-high (- idx 3)) + (aref block-high (- idx 8)) + (aref block-high (- idx 14)) + (aref block-high (- idx 16))) + (logxor (aref block-low (- idx 3)) + (aref block-low (- idx 8)) + (aref block-low (- idx 14)) + (aref block-low (- idx 16)))) + (aset block-high idx S1W-high) + (aset block-low idx S1W-low) + (setq idx (1+ idx)))) + ;; step (d). + (setq idx 0) + (let (;; temporary variables used in sha1-OP macro. + S5A-high S5A-low S30B-high S30B-low carry) + (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx))) + (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx))) + (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx))) + (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx)))) + ;; step (e). + (let (;; temporary variables used in sha1-add-to-H macro. + carry) + (sha1-add-to-H H0 A) + (sha1-add-to-H H1 B) + (sha1-add-to-H H2 C) + (sha1-add-to-H H3 D) + (sha1-add-to-H H4 E)))) + +(defun sha1-binary (string) + "Return the SHA1 of STRING in binary form." + (let (;; prepare buffers for a block. byte-length of block is 64. + ;; input block is split into two vectors. + ;; + ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ... + ;; block-high: +-0-+ +-1-+ +-2-+ +-3-+ + ;; block-low: +-0-+ +-1-+ +-2-+ +-3-+ + ;; + ;; length of each vector is 80, and elements of each vector are + ;; 16bit integers. elements 0x10-0x4F of each vector are + ;; assigned later in `sha1-block'. + (block-high (eval-when-compile (make-vector 80 nil))) + (block-low (eval-when-compile (make-vector 80 nil)))) + (unwind-protect + (let* (;; byte-length of input string. + (len (length string)) + (lim (* (/ len 64) 64)) + (rem (% len 4)) + (idx 0)(pos 0)) + ;; initialize buffers (H0 H1 H2 H3 H4). + (setq sha1-H0-high 26437 ; (string-to-number "6745" 16) + sha1-H0-low 8961 ; (string-to-number "2301" 16) + sha1-H1-high 61389 ; (string-to-number "EFCD" 16) + sha1-H1-low 43913 ; (string-to-number "AB89" 16) + sha1-H2-high 39098 ; (string-to-number "98BA" 16) + sha1-H2-low 56574 ; (string-to-number "DCFE" 16) + sha1-H3-high 4146 ; (string-to-number "1032" 16) + sha1-H3-low 21622 ; (string-to-number "5476" 16) + sha1-H4-high 50130 ; (string-to-number "C3D2" 16) + sha1-H4-low 57840) ; (string-to-number "E1F0" 16) + ;; loop for each 64 bytes block. + (while (< pos lim) + ;; step (a). + (setq idx 0) + (while (< idx 16) + (aset block-high idx (+ (* (aref string pos) 256) + (aref string (1+ pos)))) + (setq pos (+ pos 2)) + (aset block-low idx (+ (* (aref string pos) 256) + (aref string (1+ pos)))) + (setq pos (+ pos 2)) + (setq idx (1+ idx))) + (sha1-block block-high block-low)) + ;; last block. + (if (prog1 + (< (- len lim) 56) + (setq lim (- len rem)) + (setq idx 0) + (while (< pos lim) + (aset block-high idx (+ (* (aref string pos) 256) + (aref string (1+ pos)))) + (setq pos (+ pos 2)) + (aset block-low idx (+ (* (aref string pos) 256) + (aref string (1+ pos)))) + (setq pos (+ pos 2)) + (setq idx (1+ idx))) + ;; this is the last (at most) 32bit word. + (cond + ((= rem 3) + (aset block-high idx (+ (* (aref string pos) 256) + (aref string (1+ pos)))) + (setq pos (+ pos 2)) + (aset block-low idx (+ (* (aref string pos) 256) + 128))) + ((= rem 2) + (aset block-high idx (+ (* (aref string pos) 256) + (aref string (1+ pos)))) + (aset block-low idx 32768)) + ((= rem 1) + (aset block-high idx (+ (* (aref string pos) 256) + 128)) + (aset block-low idx 0)) + (t ;; (= rem 0) + (aset block-high idx 32768) + (aset block-low idx 0))) + (setq idx (1+ idx)) + (while (< idx 16) + (aset block-high idx 0) + (aset block-low idx 0) + (setq idx (1+ idx)))) + ;; last block has enough room to write the length of string. + (progn + ;; write bit length of string to last 4 bytes of the block. + (aset block-low 15 (* (% len 8192) 8)) + (setq len (/ len 8192)) + (aset block-high 15 (% len 65536)) + ;; XXX: It is not practical to compute SHA1 of + ;; such a huge message on emacs. + ;; (setq len (/ len 65536)) ; for 64bit emacs. + ;; (aset block-low 14 (% len 65536)) + ;; (aset block-high 14 (/ len 65536)) + (sha1-block block-high block-low)) + ;; need one more block. + (sha1-block block-high block-low) + (fillarray block-high 0) + (fillarray block-low 0) + ;; write bit length of string to last 4 bytes of the block. + (aset block-low 15 (* (% len 8192) 8)) + (setq len (/ len 8192)) + (aset block-high 15 (% len 65536)) + ;; XXX: It is not practical to compute SHA1 of + ;; such a huge message on emacs. + ;; (setq len (/ len 65536)) ; for 64bit emacs. + ;; (aset block-low 14 (% len 65536)) + ;; (aset block-high 14 (/ len 65536)) + (sha1-block block-high block-low)) + ;; make output string (in binary form). + (let ((result (make-string 20 0))) + (aset result 0 (/ sha1-H0-high 256)) + (aset result 1 (% sha1-H0-high 256)) + (aset result 2 (/ sha1-H0-low 256)) + (aset result 3 (% sha1-H0-low 256)) + (aset result 4 (/ sha1-H1-high 256)) + (aset result 5 (% sha1-H1-high 256)) + (aset result 6 (/ sha1-H1-low 256)) + (aset result 7 (% sha1-H1-low 256)) + (aset result 8 (/ sha1-H2-high 256)) + (aset result 9 (% sha1-H2-high 256)) + (aset result 10 (/ sha1-H2-low 256)) + (aset result 11 (% sha1-H2-low 256)) + (aset result 12 (/ sha1-H3-high 256)) + (aset result 13 (% sha1-H3-high 256)) + (aset result 14 (/ sha1-H3-low 256)) + (aset result 15 (% sha1-H3-low 256)) + (aset result 16 (/ sha1-H4-high 256)) + (aset result 17 (% sha1-H4-high 256)) + (aset result 18 (/ sha1-H4-low 256)) + (aset result 19 (% sha1-H4-low 256)) + result)) + ;; do not leave a copy of input string. + (fillarray block-high nil) + (fillarray block-low nil)))) + +(defun sha1-string-internal (string) + (encode-hex-string (sha1-binary string))) + +(defun sha1-region-internal (beg end) + (sha1-string-internal (buffer-substring-no-properties beg end))) + +;;; +;;; application interface. +;;; + +(defun sha1-region (beg end) + (if (and sha1-maximum-internal-length + (> (abs (- end beg)) sha1-maximum-internal-length)) + (sha1-region-external beg end) + (sha1-region-internal beg end))) + +(defun sha1-string (string) + (if (and sha1-maximum-internal-length + (> (length string) sha1-maximum-internal-length)) + (sha1-string-external string) + (sha1-string-internal string))) + +(defun sha1 (object &optional beg end) + "Return the SHA1 (Secure Hash Algorithm) of an object. +OBJECT is either a string or a buffer. +Optional arguments BEG and END denote buffer positions for computing the +hash of a portion of OBJECT." + (if (stringp object) + (sha1-string object) + (save-excursion + (set-buffer object) + (sha1-region (or beg (point-min)) (or end (point-max)))))) + +(provide 'sha1-el) + +;;; sha1-el.el ends here diff --git a/texi/ChangeLog b/texi/ChangeLog index ddd8c0f..a9a4306 100644 --- a/texi/ChangeLog +++ b/texi/ChangeLog @@ -1,3 +1,8 @@ +2001-10-31 Katsumi Yamaoka + + * gnus.texi (NNTP): Added documentation for + `nntp-prepare-post-hook'. + 2001-10-29 Simon Josefsson * gnus.texi (Customizing Articles): Sort list. Remove diff --git a/texi/gnus-ja.texi b/texi/gnus-ja.texi index e6d1d99..05a8235 100644 --- a/texi/gnus-ja.texi +++ b/texi/gnus-ja.texi @@ -10763,6 +10763,19 @@ default force yes されています。それらは二種類に分類することができ、直接接続するための関数 群 (三つ) と間接的に接続するためのもの (二つ) があります。 +@item nntp-prepare-post-hook +@vindex nntp-prepare-post-hook +記事をポストする直前に実行されるフックです。もし記事 +に @code{Message-ID} ヘッダーが無くてニュースサーバーが推奨 ID を提供し +てくれるならば、このフックが実行される前にそれが記事に加えられます。これ +は、もしあなたが gnus が @code{Message-ID} ヘッダーを付けないようにして +いても、@code{Cancel-Lock} ヘッダーを作るために利用することができます。 +それにはこうすれば良いでしょう: + +@lisp +(add-hook 'nntp-prepare-post-hook 'canlock-insert-header) +@end lisp + @item nntp-list-options @vindex nntp-list-options LIST コマンドのオプションに使って、(サーバーの) リスト出力を設定したニュー diff --git a/texi/gnus.texi b/texi/gnus.texi index fdfb455..9711151 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -11305,6 +11305,18 @@ Five pre-made functions are supplied. These functions can be grouped in two categories: direct connection functions (three pre-made), and indirect ones (two pre-made). +@item nntp-prepare-post-hook +@vindex nntp-prepare-post-hook +A hook run just before posting an article. If there is no +@code{Message-ID} header in the article and the news server provides the +recommended ID, it will be added to the article before running this +hook. It is useful to make @code{Cancel-Lock} headers even if you +inhibit Gnus to add a @code{Message-ID} header, you could say: + +@lisp +(add-hook 'nntp-prepare-post-hook 'canlock-insert-header) +@end lisp + @item nntp-list-options @vindex nntp-list-options List of newsgroup name used for a option of the LIST command to restrict