From: ueno Date: Mon, 6 Nov 2000 13:03:19 +0000 (+0000) Subject: Merge `deisui-1_14_0-1'. X-Git-Tag: flim-1_14_0-pre1~21 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=cfbeb2aa70dd2506c32ce4a2e1d232731a93701d;p=elisp%2Fflim.git Merge `deisui-1_14_0-1'. --- diff --git a/ChangeLog b/ChangeLog index 5726824..8169e34 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,151 @@ +2000-11-05 Daiki Ueno + + * qmtp.el (qmtp-send-package): Don't check "K" reply per recipient. + (qmtp-via-smtp): Mark as obsolete. + (qmtp-send-buffer): New function. + + * sasl.texi: New file. + +2000-11-05 Daiki Ueno + + * sasl.el (sasl-step-data): New function. + (sasl-step-set-data): New function. + +2000-11-04 Daiki Ueno + + * sasl.el: Don't require 'poe' + - Rename `sasl-*instantiator*' to `sasl-*client*'. + - Rename `sasl-*authenticator*' to `sasl-*mechanism*'. + - Rename `sasl-*continuations*' to `sasl-*steps*'. + (sasl-make-client): Accept 1st argument `mechanism'. + (sasl-next-step): Rename from `sasl-evaluate-challenge'. + +2000-11-04 Daiki Ueno + + * sasl.el (sasl-make-instantiator): Define as function. + (sasl-instantiator-name): Ditto. + (sasl-instantiator-service): Ditto. + (sasl-instantiator-server): Ditto. + (sasl-instantiator-set-properties): Ditto. + (sasl-instantiator-set-property): Ditto. + (sasl-instantiator-property): Ditto. + (sasl-instantiator-properties): Ditto. + (sasl-authenticator-mechanism): Ditto. + (sasl-authenticator-continuations): Ditto. + +2000-11-02 Daiki Ueno + + * sasl.el: Rename `sasl-*principal*' to `sasl-*instantiator*'. + (sasl-make-instantiator): Abolish optional 4th argument. + (sasl-instantiator-set-properties): New function. + (sasl-instantiator-put-property): New function. + (sasl-instantiator-property): New function. + (sasl-instantiator-properties): New function. + + * smtp.el (smtp-sasl-user-name): Rename from + `smtp-sasl-principal-user'. + (smtp-sasl-user-realm): Rename from `smtp-sasl-principal-realm'. + +2000-11-02 Daiki Ueno + + * sasl.el (sasl-mechanisms): Add `LOGIN' and `ANONYMOUS'. + (sasl-mechanism-alist): Likewise. + (sasl-error): Define. + (sasl-login-continuations): New variable. + (sasl-login-response-1): New function. + (sasl-login-response-2): New function. + (sasl-anonymous-continuations): New variable. + (sasl-anonymous-response): New function. + + * smtp.el (smtp-error): Define. + (smtp-via-smtp): Use it. + +2000-11-02 Daiki Ueno + + * smtp.el (smtp-via-smtp): Mark as obsolete. + (smtp-send-buffer): Rename from `smtp-via-smtp'. + +2000-11-02 Daiki Ueno + + * sasl.el (sasl-make-authenticator): Allocate a freshly generated + symbol for each continuation. + +2000-11-02 Daiki Ueno + + * sasl-digest.el (sasl-digest-md5-response-1): Rename from + `sasl-digest-md5-digest-response'. + (sasl-digest-md5-response-2): New alias. + (sasl-digest-md5-parse-digest-challenge): Save excursion. + + * sasl.el (sasl-mechanism-alist): Rename from `sasl-mechanisms'. + (sasl-mechanisms): New variable. + (sasl-find-authenticator): Check `sasl-mechanisms' rather than + `sasl-mechanism-alist'. + + * smtp.el (smtp-submit-package): Use `smtp-primitive-ehlo'. + (smtp-primitive-auth): Check authenticator. + +2000-11-02 Daiki Ueno + + * FLIM-ELS (hmac-modules): New variable. + (flim-modules): Move HMAC modules to `hmac-modules' + - Add `sasl-digest'. + + * smtp.el (smtp-sasl-principal-realm): New user option. + + * sasl.el (sasl-plain-response): New function. + (sasl-mechanisms): Add `DIGEST-MD5' and `PLAIN'. + (sasl-unique-id-function): New variable. + (sasl-plain-continuations): New variable. + (sasl-unique-id): New function. + (sasl-unique-id-char): New variable. + + * sasl-digest.el: New file. + +2000-11-01 Daiki Ueno + + * smtp.el: Bind `sasl-mechanisms'; add autoload settings for + `sasl-make-principal', `sasl-find-authenticator', + `sasl-authenticator-mechanism-internal' and + `sasl-evaluate-challenge'. + (smtp-use-sasl): New user option. + (smtp-sasl-principal-name): New user option. + (smtp-sasl-mechanisms): New user option. + (smtp-submit-package): Call `smtp-primitive-starttls' and + `smtp-primitive-auth'. + (smtp-primitive-ehlo): Don't modify the rest of a extension line. + (smtp-primitive-auth): New function. + (smtp-primitive-starttls): Check the response code. + + * sasl.el: New implementation. + + * sasl-cram.el: New file. + + * FLIM-ELS (flim-modules): Add `md5', `md5-el', `md5-dl', + `hex-util', `hmac-def', `hmac-md5', `sasl' and `sasl-cram'. + +2000-11-01 Daiki Ueno + + * smtp.el: Add autoload settings for `starttls-open-stream' and + `starttls-negotiate'. + (smtp-connection-set-extensions-internal): New macro. + (smtp-connection-extensions-internal): New macro. + (smtp-make-connection): Set the `extension' slot to nil. + (smtp-primitive-ehlo): New function. + (smtp-submit-package): Rename from `smtp-commit'. + (smtp-submit-package-function): Rename from `smtp-commit-function'. + (smtp-primitive-starttls): New function. + (smtp-extensions): New group. + (smtp-use-8bitmime): New variable. + (smtp-use-size): New variable. + (smtp-use-starttls): New variable. + (smtp-via-smtp): Bind `smtp-open-connection-function'. + +2000-10-31 Daiki Ueno + + * smtp.el: New implementation; don't use `tram.el' and `luna.el'. + + 2000-08-28 Yuuichi Teranishi * eword-encode.el (eword-encode-mailboxes-to-rword-list): diff --git a/FLIM-ELS b/FLIM-ELS index 775bb54..0fa8ca9 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -11,16 +11,23 @@ mime mime-parse mmgeneric mmbuffer mmcooked mmdbuffer mmexternal mailcap - smtp smtpmail)) + sasl sasl-cram sasl-digest + smtp qmtp smtpmail)) + +(setq hmac-modules '(hex-util + hmac-def + md5 md5-el md5-dl + sha1 sha1-el sha1-dl + hmac-md5 hmac-sha1)) + +(setq flim-modules (nconc hmac-modules flim-modules)) (if (and (fboundp 'base64-encode-string) (subrp (symbol-function 'base64-encode-string))) nil (if (fboundp 'dynamic-link) - (setq flim-modules (cons 'mel-b-dl flim-modules)) - ) - (setq flim-modules (cons 'mel-b-el flim-modules)) - ) + (setq flim-modules (cons 'mel-b-dl flim-modules))) + (setq flim-modules (cons 'mel-b-el flim-modules))) (require 'pccl) (unless-broken ccl-usable diff --git a/hex-util.el b/hex-util.el new file mode 100644 index 0000000..92a09ff --- /dev/null +++ b/hex-util.el @@ -0,0 +1,73 @@ +;;; hex-util.el --- Functions to encode/decode hexadecimal string. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; 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/hmac-def.el b/hmac-def.el new file mode 100644 index 0000000..7525c89 --- /dev/null +++ b/hmac-def.el @@ -0,0 +1,85 @@ +;;; hmac-def.el --- A macro for defining HMAC functions. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: HMAC, RFC 2104 + +;; 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 RFC 2104, +;; "HMAC: Keyed-Hashing for Message Authentication". + +;;; Code: + +(defmacro define-hmac-function (name H B L &optional bit) + "Define a function NAME(TEXT KEY) which computes HMAC with function H. + +HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)): + +H is a cryptographic hash function, such as SHA1 and MD5, which takes +a string and return a digest of it (in binary form). +B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.) +L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.) +If BIT is non-nil, truncate output to specified bits." + (` (defun (, name) (text key) + (, (concat "Compute " + (upcase (symbol-name name)) + " over TEXT with KEY.")) + (let ((key-xor-ipad (make-string (, B) ?\x36)) + (key-xor-opad (make-string (, B) ?\x5C)) + (len (length key)) + (pos 0)) + (unwind-protect + (progn + ;; if `key' is longer than the block size, apply hash function + ;; to `key' and use the result as a real `key'. + (if (> len (, B)) + (setq key ((, H) key) + len (, L))) + (while (< pos len) + (aset key-xor-ipad pos (logxor (aref key pos) ?\x36)) + (aset key-xor-opad pos (logxor (aref key pos) ?\x5C)) + (setq pos (1+ pos))) + (setq key-xor-ipad (unwind-protect + (concat key-xor-ipad text) + (fillarray key-xor-ipad 0)) + key-xor-ipad (unwind-protect + ((, H) key-xor-ipad) + (fillarray key-xor-ipad 0)) + key-xor-opad (unwind-protect + (concat key-xor-opad key-xor-ipad) + (fillarray key-xor-opad 0)) + key-xor-opad (unwind-protect + ((, H) key-xor-opad) + (fillarray key-xor-opad 0))) + ;; now `key-xor-opad' contains + ;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)). + (, (if (and bit (< (/ bit 8) L)) + (` (substring key-xor-opad 0 (, (/ bit 8)))) + ;; return a copy of `key-xor-opad'. + (` (concat key-xor-opad))))) + ;; cleanup. + (fillarray key-xor-ipad 0) + (fillarray key-xor-opad 0)))))) + +(provide 'hmac-def) + +;;; hmac-def.el ends here diff --git a/hmac-md5.el b/hmac-md5.el new file mode 100644 index 0000000..9c936d0 --- /dev/null +++ b/hmac-md5.el @@ -0,0 +1,95 @@ +;;; hmac-md5.el --- Compute HMAC-MD5. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Kenichi OKADA +;; Maintainer: Kenichi OKADA +;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 + +;; 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: + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". +;; +;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) +;; => "9294727a3638bb1c13f48ef8158bfc9d" +;; +;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) +;; => "750c783e6ab0b503eaa86e310a5db738" +;; +;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) +;; => "56be34521d144c88dbb8c733f0e8b3f6" +;; +;; (encode-hex-string +;; (hmac-md5 +;; (make-string 50 ?\xcd) +;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) +;; => "697eaf0aca3a3aea3a75164746ffaa79" +;; +;; (encode-hex-string +;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995690efd4c" +;; (encode-hex-string +;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key - Hash Key First" +;; (make-string 80 ?\xaa))) +;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" +;; (make-string 80 ?\xaa))) +;; => "6f630fad67cda0ee1fb1f562db3aa53e" + +;;; Code: + +(eval-when-compile (require 'hmac-def)) +(require 'hex-util) ; (decode-hex-string STRING) +(require 'md5) ; expects (md5 STRING) + +;; We cannot define this function in md5.el because recent XEmacs provides +;; built-in md5 function and provides feature 'md5 at startup. +(if (and (featurep 'xemacs) + (fboundp 'md5) + (subrp (symbol-function 'md5)) + (condition-case nil + ;; `md5' of XEmacs 21 takes 4th arg CODING (and 5th arg NOERROR). + (md5 "" nil nil 'binary) ; => "fb5d2156096fa1f254352f3cc3fada7e" + (error nil))) + ;; XEmacs 21. + (defun md5-binary (string &optional start end) + "Return the MD5 of STRING in binary form." + (decode-hex-string (md5 string start end 'binary))) + ;; not XEmacs 21 and not DL. + (if (not (fboundp 'md5-binary)) + (defun md5-binary (string) + "Return the MD5 of STRING in binary form." + (decode-hex-string (md5 string))))) + +(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY) +;; (define-hmac-function hmac-md5-96 md5-binary 64 16 96) + +(provide 'hmac-md5) + +;;; hmac-md5.el ends here diff --git a/hmac-sha1.el b/hmac-sha1.el new file mode 100644 index 0000000..6b2beea --- /dev/null +++ b/hmac-sha1.el @@ -0,0 +1,80 @@ +;;; hmac-sha1.el --- Compute HMAC-SHA1. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: HMAC, RFC 2104, HMAC-SHA1, SHA1, Cancel-Lock + +;; 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: + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". +;; +;; (encode-hex-string (hmac-sha1 "Hi There" (make-string 20 ?\x0b))) +;; => "b617318655057264e28bc0b6fb378c8ef146be00" +;; +;; (encode-hex-string (hmac-sha1 "what do ya want for nothing?" "Jefe")) +;; => "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79" +;; +;; (encode-hex-string (hmac-sha1 (make-string 50 ?\xdd) (make-string 20 ?\xaa))) +;; => "125d7342b9ac11cd91a39af48aa17b4f63f175d3" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; (make-string 50 ?\xcd) +;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) +;; => "4c9007f4026250c6bc8414f9bf50c86c2d7235da" +;; +;; (encode-hex-string +;; (hmac-sha1 "Test With Truncation" (make-string 20 ?\x0c))) +;; => "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04" +;; (encode-hex-string +;; (hmac-sha1-96 "Test With Truncation" (make-string 20 ?\x0c))) +;; => "4c1a03424b55e07fe7f27be1" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; "Test Using Larger Than Block-Size Key - Hash Key First" +;; (make-string 80 ?\xaa))) +;; => "aa4ae5e15272d00e95705637ce8a3b55ed402112" +;; +;; (encode-hex-string +;; (hmac-sha1 +;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" +;; (make-string 80 ?\xaa))) +;; => "e8e99d0f45237d786d6bbaa7965c7808bbff1a91" + +;;; Code: + +(eval-when-compile (require 'hmac-def)) +(require 'hex-util) ; (decode-hex-string STRING) +(require 'sha1) ; expects (sha1 STRING) + +;;; For consintency with hmac-md5.el, we define this function here. +(or (fboundp 'sha1-binary) + (defun sha1-binary (string) + "Return the SHA1 of STRING in binary form." + (decode-hex-string (sha1 string)))) + +(define-hmac-function hmac-sha1 sha1-binary 64 20) ; => (hmac-sha1 TEXT KEY) +;; (define-hmac-function hmac-sha1-96 sha1-binary 64 20 96) + +(provide 'hmac-sha1) + +;;; hmac-sha1.el ends here diff --git a/md5-dl.el b/md5-dl.el new file mode 100644 index 0000000..72078c5 --- /dev/null +++ b/md5-dl.el @@ -0,0 +1,70 @@ +;;; md5-dl.el --- MD5 Message Digest Algorithm using DL module. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: MD5, RFC 1321 + +;; 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 + (defun-maybe md5-string (a)) + (defun-maybe dynamic-link (a)) + (defun-maybe dynamic-call (a b))) + +(defvar md5-dl-module + (if (and (fboundp 'md5-string) + (subrp (symbol-function 'md5-string))) + nil + (if (fboundp 'dynamic-link) + (let ((path (expand-file-name "md5.so" exec-directory))) + (and (file-exists-p path) + path))))) + +(defvar md5-dl-handle + (and (stringp md5-dl-module) + (file-exists-p md5-dl-module) + (dynamic-link md5-dl-module))) + +;;; md5-dl-module provides `md5-string'. +(dynamic-call "emacs_md5_init" md5-dl-handle) + +(defun md5-region (beg end) + (interactive "r") + (md5-string (buffer-substring-no-properties beg end))) + +;;; Note that XEmacs built-in version takes two more args: CODING and NOERROR. +;;;###autoload +(defun md5 (object &optional beg end) + "Return the MD5 (a secure message digest 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) + (md5-string object) + (save-excursion + (set-buffer object) + (md5-region (or beg (point-min)) (or end (point-max)))))) + +(provide 'md5-dl) + +;;; md5-dl.el ends here. diff --git a/md5-el.el b/md5-el.el new file mode 100644 index 0000000..e7374d8 --- /dev/null +++ b/md5-el.el @@ -0,0 +1,408 @@ +;;; md5.el -- MD5 Message Digest Algorithm +;;; Gareth Rees + +;; LCD Archive Entry: +;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| +;; MD5 cryptographic message digest algorithm| +;; 13-Nov-95|1.0|~/misc/md5.el.Z| + +;;; Details: ------------------------------------------------------------------ + +;; This is a direct translation into Emacs LISP of the reference C +;; implementation of the MD5 Message-Digest Algorithm written by RSA +;; Data Security, Inc. +;; +;; The algorithm takes a message (that is, a string of bytes) and +;; computes a 16-byte checksum or "digest" for the message. This digest +;; is supposed to be cryptographically strong in the sense that if you +;; are given a 16-byte digest D, then there is no easier way to +;; construct a message whose digest is D than to exhaustively search the +;; space of messages. However, the robustness of the algorithm has not +;; been proven, and a similar algorithm (MD4) was shown to be unsound, +;; so treat with caution! +;; +;; The C algorithm uses 32-bit integers; because GNU Emacs +;; implementations provide 28-bit integers (with 24-bit integers on +;; versions prior to 19.29), the code represents a 32-bit integer as the +;; cons of two 16-bit integers. The most significant word is stored in +;; the car and the least significant in the cdr. The algorithm requires +;; at least 17 bits of integer representation in order to represent the +;; carry from a 16-bit addition. + +;;; Usage: -------------------------------------------------------------------- + +;; To compute the MD5 Message Digest for a message M (represented as a +;; string or as a vector of bytes), call +;; +;; (md5-encode M) +;; +;; which returns the message digest as a vector of 16 bytes. If you +;; need to supply the message in pieces M1, M2, ... Mn, then call +;; +;; (md5-init) +;; (md5-update M1) +;; (md5-update M2) +;; ... +;; (md5-update Mn) +;; (md5-final) + +;;; Copyright and licence: ---------------------------------------------------- + +;; Copyright (C) 1995, 1996, 1997 by Gareth Rees +;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm +;; +;; md5.el 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. +;; +;; md5.el 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. +;; +;; The original copyright notice is given below, as required by the +;; licence for the original code. This code is distributed under *both* +;; RSA's original licence and the GNU General Public Licence. (There +;; should be no problems, as the former is more liberal than the +;; latter). + +;;; Original copyright notice: ------------------------------------------------ + +;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. +;; +;; License to copy and use this software is granted provided that it is +;; identified as the "RSA Data Security, Inc. MD5 Message- Digest +;; Algorithm" in all material mentioning or referencing this software or +;; this function. +;; +;; License is also granted to make and use derivative works provided +;; that such works are identified as "derived from the RSA Data +;; Security, Inc. MD5 Message-Digest Algorithm" in all material +;; mentioning or referencing the derived work. +;; +;; RSA Data Security, Inc. makes no representations concerning either +;; the merchantability of this software or the suitability of this +;; software for any particular purpose. It is provided "as is" without +;; express or implied warranty of any kind. +;; +;; These notices must be retained in any copies of any part of this +;; documentation and/or software. + +;;; Code: --------------------------------------------------------------------- + +(defvar md5-program "md5" + "*Program that reads a message on its standard input and writes an +MD5 digest on its output.") + +(defvar md5-maximum-internal-length 4096 + "*The maximum size of a piece of data that should use the MD5 routines +written in lisp. If a message exceeds this, it will be run through an +external filter for processing. Also see the `md5-program' variable. +This variable has no effect if you call the md5-init|update|final +functions - only used by the `md5' function's simpler interface.") + +(defvar md5-bits (make-vector 4 0) + "Number of bits handled, modulo 2^64. +Represented as four 16-bit numbers, least significant first.") +(defvar md5-buffer (make-vector 4 '(0 . 0)) + "Scratch buffer (four 32-bit integers).") +(defvar md5-input (make-vector 64 0) + "Input buffer (64 bytes).") + +(defun md5-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +(defun md5-encode (message) + "Encodes MESSAGE using the MD5 message digest algorithm. +MESSAGE must be a string or an array of bytes. +Returns a vector of 16 bytes containing the message digest." + (if (or (null md5-maximum-internal-length) + (<= (length message) md5-maximum-internal-length)) + (progn + (md5-init) + (md5-update message) + (md5-final)) + (save-excursion + (set-buffer (get-buffer-create " *md5-work*")) + (erase-buffer) + (insert message) + (call-process-region (point-min) (point-max) + md5-program + t (current-buffer)) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (let ((data (buffer-substring (point-min) (+ (point-min) 32))) + (vec (make-vector 16 0)) + (ctr 0)) + (while (< ctr 16) + (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) + (md5-unhex (aref data (1+ (* ctr 2)))))) + (setq ctr (1+ ctr))))))) + +(defsubst md5-add (x y) + "Return 32-bit sum of 32-bit integers X and Y." + (let ((m (+ (car x) (car y))) + (l (+ (cdr x) (cdr y)))) + (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) + +;; FF, GG, HH and II are basic MD5 functions, providing transformations +;; for rounds 1, 2, 3 and 4 respectively. Each function follows this +;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x +;; by y bits to the left): +;; +;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b +;; +;; so we use the macro `md5-make-step' to construct each one. The +;; helper functions F, G, H and I operate on 16-bit numbers; the full +;; operation splits its inputs, operates on the halves separately and +;; then puts the results together. + +(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) +(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) +(defsubst md5-H (x y z) (logxor x y z)) +(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) + +(defmacro md5-make-step (name func) + (` + (defun (, name) (a b c d x s ac) + (let* + ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) + (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) + (m2 (logand 65535 (+ m1 (lsh l1 -16)))) + (l2 (logand 65535 l1)) + (m3 (logand 65535 (if (> s 15) + (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) + (+ (lsh m2 s) (lsh l2 (- s 16)))))) + (l3 (logand 65535 (if (> s 15) + (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) + (+ (lsh l2 s) (lsh m2 (- s 16))))))) + (md5-add (cons m3 l3) b))))) + +(md5-make-step md5-FF md5-F) +(md5-make-step md5-GG md5-G) +(md5-make-step md5-HH md5-H) +(md5-make-step md5-II md5-I) + +(defun md5-init () + "Initialise the state of the message-digest routines." + (aset md5-bits 0 0) + (aset md5-bits 1 0) + (aset md5-bits 2 0) + (aset md5-bits 3 0) + (aset md5-buffer 0 '(26437 . 8961)) + (aset md5-buffer 1 '(61389 . 43913)) + (aset md5-buffer 2 '(39098 . 56574)) + (aset md5-buffer 3 '( 4146 . 21622))) + +(defun md5-update (string) + "Update the current MD5 state with STRING (an array of bytes)." + (let ((len (length string)) + (i 0) + (j 0)) + (while (< i len) + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Store this byte (truncating to 8 bits to be sure) + (aset md5-input j (logand 255 (aref string i))) + + ;; Update number of bits by 8 (modulo 2^64) + (let ((c 8) (k 0)) + (while (and (> c 0) (< k 4)) + (let ((b (aref md5-bits k))) + (aset md5-bits k (logand 65535 (+ b c))) + (setq c (if (> b (- 65535 c)) 1 0) + k (1+ k))))) + + ;; Increment number of bytes processed + (setq i (1+ i)) + + ;; When 64 bytes accumulated, pack them into sixteen 32-bit + ;; integers in the array `in' and then tranform them. + (if (= j 63) + (let ((in (make-vector 16 (cons 0 0))) + (k 0) + (kk 0)) + (while (< k 16) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4))) + (md5-transform in)))))) + +(defun md5-pack (array i) + "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." + (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) + (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) + +(defun md5-byte (array n b) + "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." + (let ((e (aref array n))) + (cond ((eq b 0) (logand 255 (cdr e))) + ((eq b 1) (lsh (cdr e) -8)) + ((eq b 2) (logand 255 (car e))) + ((eq b 3) (lsh (car e) -8))))) + +(defun md5-final () + (let ((in (make-vector 16 (cons 0 0))) + (j 0) + (digest (make-vector 16 0)) + (padding)) + + ;; Save the number of bits in the message + (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) + (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) + + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Pad out computation to 56 bytes modulo 64 + (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) + (aset padding 0 128) + (md5-update padding) + + ;; Append length in bits and transform + (let ((k 0) (kk 0)) + (while (< k 14) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4)))) + (md5-transform in) + + ;; Store the results in the digest + (let ((k 0) (kk 0)) + (while (< k 4) + (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) + (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) + (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) + (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) + (setq k (+ k 1) kk (+ kk 4)))) + + ;; Return digest + digest)) + +;; It says in the RSA source, "Note that if the Mysterious Constants are +;; arranged backwards in little-endian order and decrypted with the DES +;; they produce OCCULT MESSAGES!" Security through obscurity? + +(defun md5-transform (in) + "Basic MD5 step. Transform md5-buffer based on array IN." + (let ((a (aref md5-buffer 0)) + (b (aref md5-buffer 1)) + (c (aref md5-buffer 2)) + (d (aref md5-buffer 3))) + (setq + a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) + d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) + c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) + b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) + a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) + d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) + c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) + b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) + a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) + d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) + c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) + b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) + a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) + d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) + c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) + b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) + a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) + d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) + c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) + b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) + a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) + d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) + c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) + b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) + a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) + d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) + c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) + b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) + a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) + d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) + c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) + b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) + a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) + d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) + c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) + b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) + a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) + d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) + c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) + b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) + a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) + d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) + c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) + b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) + a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) + d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) + c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) + b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) + a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) + d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) + c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) + b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) + a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) + d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) + c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) + b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) + a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) + d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) + c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) + b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) + a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) + d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) + c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) + b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) + + (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) + (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) + (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) + (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Here begins the merger with the XEmacs API and the md5.el from the URL +;;; package. Courtesy wmperry@cs.indiana.edu +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun md5 (object &optional start end) + "Return the MD5 (a secure message digest algorithm) of an object. +OBJECT is either a string or a buffer. +Optional arguments START and END denote buffer positions for computing the +hash of a portion of OBJECT." + (let ((buffer nil)) + (unwind-protect + (save-excursion + (setq buffer (generate-new-buffer " *md5-work*")) + (set-buffer buffer) + (cond + ((bufferp object) + (insert-buffer-substring object start end)) + ((stringp object) + (insert (if (or start end) + (substring object start end) + object))) + (t nil)) + (prog1 + (if (or (null md5-maximum-internal-length) + (<= (point-max) md5-maximum-internal-length)) + (mapconcat + (function (lambda (node) (format "%02x" node))) + (md5-encode (buffer-string)) + "") + (call-process-region (point-min) (point-max) + shell-file-name + t buffer nil + shell-command-switch md5-program) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (buffer-substring (point-min) (+ (point-min) 32))) + (kill-buffer buffer))) + (and buffer (buffer-name buffer) (kill-buffer buffer) nil)))) + +(provide 'md5-el) diff --git a/md5.el b/md5.el new file mode 100644 index 0000000..55c658b --- /dev/null +++ b/md5.el @@ -0,0 +1,67 @@ +;;; md5.el --- MD5 Message Digest Algorithm. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Keywords: MD5, RFC 1321 + +;; 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: + +;; Examples from RFC 1321. +;; +;; (md5 "") +;; => d41d8cd98f00b204e9800998ecf8427e +;; +;; (md5 "a") +;; => 0cc175b9c0f1b6a831c399e269772661 +;; +;; (md5 "abc") +;; => 900150983cd24fb0d6963f7d28e17f72 +;; +;; (md5 "message digest") +;; => f96b697d7cb7938d525a2f31aaf161d0 +;; +;; (md5 "abcdefghijklmnopqrstuvwxyz") +;; => c3fcd3d76192e4007dfb496cca67e13b +;; +;; (md5 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") +;; => d174ab98d277d9f5a5611c2c9f419d9f +;; +;; (md5 "12345678901234567890123456789012345678901234567890123456789012345678901234567890") +;; => 57edf4a22be3c955ac49da2e2107b67a + +;;; Code: + +(cond + ((and (fboundp 'md5) + (subrp (symbol-function 'md5))) + ;; recent XEmacs has `md5' as a built-in function. + ;; (and 'md5 is already provided.) + ) + ((and (fboundp 'dynamic-link) + (file-exists-p (expand-file-name "md5.so" exec-directory))) + ;; Emacs with DL patch. + (require 'md5-dl)) + (t + (require 'md5-el))) + +(provide 'md5) + +;;; md5.el ends here. diff --git a/mime-def.el b/mime-def.el index acae86f..73602ac 100644 --- a/mime-def.el +++ b/mime-def.el @@ -5,7 +5,8 @@ ;; Author: MORIOKA Tomohiko ;; Keywords: definition, MIME, multimedia, mail, news -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of DEISUI (Deisui is an Entity Implementation for +;; SEMI based User Interfaces). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as diff --git a/qmtp.el b/qmtp.el new file mode 100644 index 0000000..bbb933b --- /dev/null +++ b/qmtp.el @@ -0,0 +1,142 @@ +;;; qmtp.el --- basic functions to send mail with QMTP server + +;; Copyright (C) 2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Keywords: QMTP, qmail + +;; 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: + +;; Installation: + +;; To send mail using QMTP instead of SMTP, do + +;; (fset 'smtp-via-smtp 'qmtp-via-qmtp) + +;;; Code: + +(require 'poem) +(require 'pcustom) + +(defgroup qmtp nil + "QMTP protocol for sending mail." + :group 'mail) + +(defcustom qmtp-default-server nil + "Specify default QMTP server." + :type '(choice (const nil) string) + :group 'qmtp) + +(defvar qmtp-server qmtp-default-server + "The name of the host running QMTP server. +It can also be a function +called from `qmtp-via-qmtp' with arguments SENDER and RECIPIENTS.") + +(defcustom qmtp-service "qmtp" + "QMTP service port number. \"qmtp\" or 209." + :type '(choice (integer :tag "209" 209) + (string :tag "qmtp" "qmtp")) + :group 'qmtp) + +(defcustom qmtp-timeout 30 + "Timeout for each QMTP session." + :type 'integer + :group 'qmtp) + +(defvar qmtp-open-connection-function (function open-network-stream)) + +(defvar qmtp-error-response-alist + '((?Z "Temporary failure") + (?D "Permanent failure"))) + +(defvar qmtp-read-point nil) + +(defun qmtp-encode-netstring-string (string) + (format "%d:%s," (length string) string)) + +(defun qmtp-send-package (process sender recipients buffer) + (with-temp-buffer + (buffer-disable-undo) + (erase-buffer) + (set-buffer-multibyte nil) + (insert + (format "%d:\n" + (with-current-buffer buffer + (1+ (point-max));; for the "\n" + ))) + (insert-buffer-substring buffer) + (insert + "\n," + (qmtp-encode-netstring-string sender) + (qmtp-encode-netstring-string + (mapconcat #'qmtp-encode-netstring-string + recipients ""))) + (process-send-region process (point-min)(point-max))) + (goto-char qmtp-read-point) + (while (and (memq (process-status process) '(open run)) + (not (re-search-forward "^[0-9]+:" nil 'noerror))) + (unless (accept-process-output process qmtp-timeout) + (error "timeout expired: %d" qmtp-timeout)) + (goto-char qmtp-read-point)) + (let ((response (char-after (match-end 0)))) + (unless (eq response ?K) + (error (nth 1 (assq response qmtp-error-response-alist)))) + (setq recipients (cdr recipients)) + (beginning-of-line 2) + (setq qmtp-read-point (point)))) + +;;;###autoload +(defun qmtp-via-qmtp (sender recipients buffer) + (condition-case nil + (progn + (qmtp-send-buffer sender recipients buffer) + t) + (error))) + +(make-obsolete 'qmtp-via-qmtp "It's old API.") + +;;;###autoload +(defun qmtp-send-buffer (sender recipients buffer) + (save-excursion + (set-buffer + (get-buffer-create + (format "*trace of QMTP session to %s*" qmtp-server))) + (buffer-disable-undo) + (erase-buffer) + (make-local-variable 'qmtp-read-point) + (setq qmtp-read-point (point-min)) + (let (process) + (unwind-protect + (progn + (as-binary-process + (setq process + (funcall qmtp-open-connection-function + "QMTP" (current-buffer) qmtp-server qmtp-service))) + (qmtp-send-package process sender recipients buffer)) + (when (and process + (memq (process-status process) '(open run))) + ;; QUIT + (process-send-eof process) + (delete-process process)))))) + +(provide 'qmtp) + +;;; qmtp.el ends here diff --git a/sasl-cram.el b/sasl-cram.el new file mode 100644 index 0000000..a9db4a6 --- /dev/null +++ b/sasl-cram.el @@ -0,0 +1,51 @@ +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Daiki Ueno + +;; Author: Kenichi OKADA +;; Daiki Ueno +;; Keywords: SASL, CRAM-MD5 + +;; 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: + +(require 'sasl) +(require 'hmac-md5) + +(defconst sasl-cram-md5-steps + '(ignore ;no initial response + sasl-cram-md5-response)) + +(defun sasl-cram-md5-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "CRAM-MD5 passphrase for %s: " + (sasl-client-name client))))) + (unwind-protect + (concat (sasl-client-name client) " " + (encode-hex-string + (hmac-md5 (sasl-step-data step) passphrase))) + (fillarray passphrase 0)))) + +(put 'sasl-cram 'sasl-mechanism + (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps)) + +(provide 'sasl-cram) + +;;; sasl-cram.el ends here diff --git a/sasl-digest.el b/sasl-digest.el new file mode 100644 index 0000000..a3804a0 --- /dev/null +++ b/sasl-digest.el @@ -0,0 +1,173 @@ +;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Daiki Ueno + +;; Author: Kenichi OKADA +;; Daiki Ueno +;; Keywords: SASL, DIGEST-MD5 + +;; 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. + +;; This program is implemented from draft-leach-digest-sasl-05.txt. +;; +;; It is caller's responsibility to base64-decode challenges and +;; base64-encode responses in IMAP4 AUTHENTICATE command. +;; +;; Passphrase should be longer than 16 bytes. (See RFC 2195) + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defvar sasl-digest-md5-challenge nil) +(defvar sasl-digest-md5-nonce-count 1) +(defvar sasl-digest-md5-unique-id-function + sasl-unique-id-function) + +(defvar sasl-digest-md5-parse-digest-challenge-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?, "." table) + table) + "A syntax table for parsing digest-challenge attributes.") + +(defconst sasl-digest-md5-steps + '(ignore ;no initial response + sasl-digest-md5-response + ignore)) ;"" + +;;; @ low level functions +;;; +;;; Examples in `draft-leach-digest-sasl-05.txt'. +;;; +;;; (sasl-digest-md5-parse-digest-challenge +;;; "realm=\"elwood.innosoft.com\",nonce=\"OA6MG9tEQGm2hh\",qop=\"auth\",algorithm=md5-sess,charset=utf-8") +;;; => (realm "elwood.innosoft.com" nonce "OA6MG9tEQGm2hh" qop "auth" algorithm md5-sess charset utf-8) + +;;; (sasl-digest-md5-build-response-value +;;; "chris" "elwood.innosoft.com" "secret" "OA6MG9tEQGm2hh" +;;; "OA6MHXh6VqTrRk" 1 "imap/elwood.innosoft.com" "auth") +;;; => "d388dad90d4bbd760a152321f2143af7" + +(defun sasl-digest-md5-parse-digest-challenge (digest-challenge) + "Return a property list parsed DIGEST-CHALLENGE. +The value is a cons cell of the form \(realm nonce qop-options stale maxbuf +charset algorithm cipher-opts auth-param)." + (save-excursion + (with-temp-buffer + (set-syntax-table sasl-digest-md5-parse-digest-challenge-syntax-table) + (insert digest-challenge) + (goto-char (point-min)) + (insert "(") + (while (progn (forward-sexp) (not (eobp))) + (delete-char 1) + (insert " ")) + (insert ")") + (condition-case nil + (setplist 'sasl-digest-md5-challenge (read (point-min-marker))) + (end-of-file + (error "Parse error in digest-challenge.")))))) + +(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name) + (concat serv-type "/" host + (if (and serv-name + (null (string= host serv-name))) + (concat "/" serv-name)))) + +(defun sasl-digest-md5-cnonce () + (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function)) + (sasl-unique-id))) + +(defmacro sasl-digest-md5-challenge (prop) + (list 'get ''sasl-digest-md5-challenge prop)) + +(defmacro sasl-digest-md5-build-response-value-1 + (username realm passwd nonce cnonce nonce-count digest-uri qop) + `(encode-hex-string + (md5-binary + (concat + (encode-hex-string + (md5-binary (concat (md5-binary + (concat ,username + ":" ,realm + ":" ,passwd)) + ":" ,nonce + ":" ,cnonce + (let ((authzid (sasl-digest-md5-challenge 'authzid))) + (if authzid (concat ":" authzid) nil))))) + ":" ,nonce + ":" (format "%08x" ,nonce-count) ":" ,cnonce ":" ,qop ":" + (encode-hex-string + (md5-binary + (concat "AUTHENTICATE:" ,digest-uri + (if (string-equal "auth-int" ,qop) + ":00000000000000000000000000000000" + nil)))))))) + +(defun sasl-digest-md5-build-response-value + (username realm passwd nonce cnonce nonce-count digest-uri + &optional charset qop maxbuf cipher authzid) + (concat + "username=\"" username "\"," + "realm=\"" realm "\"," + "nonce=\"" nonce "\"," + (format "nc=%08x," nonce-count) + "cnonce=\"" cnonce "\"," + "digest-uri=\"" digest-uri "\"," + "response=" + (sasl-digest-md5-build-response-value-1 + username realm passwd nonce cnonce nonce-count digest-uri + (or qop "auth")) + "," + (mapconcat + #'identity + (delq nil + (mapcar (lambda (prop) + (if (sasl-digest-md5-challenge prop) + (format "%s=%s" + prop (sasl-digest-md5-challenge prop)))) + '(charset qop maxbuf cipher authzid))) + ","))) + +(defun sasl-digest-md5-response (client step) + (sasl-digest-md5-parse-digest-challenge (sasl-step-data step)) + (let ((passphrase + (sasl-read-passphrase + (format "DIGEST-MD5 passphrase for %s: " + (sasl-client-name client))))) + (unwind-protect + (sasl-digest-md5-build-response-value + (sasl-client-name client) + (or (sasl-client-property client 'realm) + (sasl-digest-md5-challenge 'realm)) ;need to check + passphrase + (sasl-digest-md5-challenge 'nonce) + (sasl-digest-md5-cnonce) + sasl-digest-md5-nonce-count + (sasl-digest-md5-digest-uri + (sasl-client-service client) + (sasl-client-server client))) + (fillarray passphrase 0)))) + +(put 'sasl-digest 'sasl-mechanism + (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps)) + +(provide 'sasl-digest) + +;;; sasl-digest.el ends here diff --git a/sasl.el b/sasl.el new file mode 100644 index 0000000..6c3ef2f --- /dev/null +++ b/sasl.el @@ -0,0 +1,269 @@ +;;; sasl.el --- SASL client framework + +;; Copyright (C) 2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Keywords: SASL + +;; 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 module provides common interface functions to share several +;; SASL mechanism drivers. The toplevel is designed to be mostly +;; compatible with [Java-SASL]. +;; +;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", +;; RFC 2222, October 1997. +;; +;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program +;; Interface", draft-weltman-java-sasl-03.txt, March 2000. + +;;; Code: + +(defvar sasl-mechanisms + '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS")) + +(defvar sasl-mechanism-alist + '(("CRAM-MD5" sasl-cram) + ("DIGEST-MD5" sasl-digest) + ("PLAIN" sasl-plain) + ("LOGIN" sasl-login) + ("ANONYMOUS" sasl-anonymous))) + +(defvar sasl-unique-id-function #'sasl-unique-id-function) + +(put 'sasl-error 'error-message "SASL error") +(put 'sasl-error 'error-conditions '(sasl-error error)) + +(defun sasl-error (datum) + (signal 'sasl-error (list datum))) + +;;; @ SASL client +;;; + +(defun sasl-make-client (mechanism name service server) + "Return a newly allocated SASL client. +NAME is name of the authorization. SERVICE is name of the service desired. +SERVER is the fully qualified host name of the server to authenticate to." + (vector mechanism name service server (make-symbol "sasl-client-properties"))) + +(defun sasl-client-mechanism (client) + "Return the authentication mechanism driver of CLIENT." + (aref client 0)) + +(defun sasl-client-name (client) + "Return the authorization name of CLIENT, a string." + (aref client 1)) + +(defun sasl-client-service (client) + "Return the service name of CLIENT, a string." + (aref client 2)) + +(defun sasl-client-server (client) + "Return the server name of CLIENT, a string." + (aref client 3)) + +(defun sasl-client-set-properties (client plist) + "Destructively set the properties of CLIENT. +The second argument PLIST is the new property list." + (setplist (aref client 4) plist)) + +(defun sasl-client-set-property (client property value) + "Add the given property/value to CLIENT." + (put (aref client 4) property value)) + +(defun sasl-client-property (client property) + "Return the value of the PROPERTY of CLIENT." + (get (aref client 4) property)) + +(defun sasl-client-properties (client) + "Return the properties of CLIENT." + (symbol-plist (aref client 4))) + +;;; @ SASL mechanism +;;; + +(defun sasl-make-mechanism (name steps) + "Make an authentication mechanism. +NAME is a IANA registered SASL mechanism name. +STEPS is list of continuation function." + (vector name + (mapcar + (lambda (step) + (let ((symbol (make-symbol (symbol-name step)))) + (fset symbol (symbol-function step)) + symbol)) + steps))) + +(defun sasl-mechanism-name (mechanism) + "Return name of MECHANISM, a string." + (aref mechanism 0)) + +(defun sasl-mechanism-steps (mechanism) + "Return the authentication steps of MECHANISM, a list of functions." + (aref mechanism 1)) + +(defun sasl-find-mechanism (mechanisms) + "Retrieve an apropriate mechanism object from MECHANISMS hints." + (let* ((sasl-mechanisms sasl-mechanisms) + (mechanism + (catch 'done + (while sasl-mechanisms + (if (member (car sasl-mechanisms) mechanisms) + (throw 'done (nth 1 (assoc (car sasl-mechanisms) + sasl-mechanism-alist)))) + (setq sasl-mechanisms (cdr sasl-mechanisms)))))) + (if mechanism + (require mechanism)) + (get mechanism 'sasl-mechanism))) + +;;; @ SASL authentication step +;;; + +(defun sasl-step-data (step) + "Return the data which STEP holds, a string." + (aref step 1)) + +(defun sasl-step-set-data (step data) + "Store DATA string to STEP." + (aset step 1 data)) + +(defun sasl-next-step (client step) + "Evaluate the challenge and prepare an appropriate next response. +The data type of the value and optional 2nd argument STEP is nil or +opaque authentication step which holds the reference to the next action +and the current challenge. At the first time STEP should be set to nil." + (let* ((steps + (sasl-mechanism-steps + (sasl-client-mechanism client))) + (function + (if (vectorp step) + (nth 1 (memq (aref step 0) steps)) + (car steps)))) + (if function + (vector function (funcall function client step))))) + +(defvar sasl-read-passphrase nil) +(defun sasl-read-passphrase (prompt) + (if (not sasl-read-passphrase) + (if (functionp 'read-passwd) + (setq sasl-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq sasl-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) + (funcall sasl-read-passphrase prompt)) + +(defun sasl-unique-id () + "Compute a data string which must be different each time. +It contain at least 64 bits of entropy." + (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function))) + +(defvar sasl-unique-id-char nil) + +;; stolen (and renamed) from message.el +(defun sasl-unique-id-function () + ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Instead we use this randomly inited counter. + (setq sasl-unique-id-char + (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20))))) + ;; (current-time) returns 16-bit ints, + ;; and 2^16*25 just fits into 4 digits i base 36. + (* 25 25))) + (let ((tm (current-time))) + (concat + (sasl-unique-id-number-base36 + (+ (car tm) + (lsh (% sasl-unique-id-char 25) 16)) 4) + (sasl-unique-id-number-base36 + (+ (nth 1 tm) + (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + +(defun sasl-unique-id-number-base36 (num len) + (if (if (< len 0) + (<= num 0) + (= len 0)) + "" + (concat (sasl-unique-id-number-base36 (/ num 36) (1- len)) + (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" + (% num 36)))))) + +;;; PLAIN (RFC2595 Section 6) +(defconst sasl-plain-steps + '(sasl-plain-response)) + +(defun sasl-plain-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "PLAIN passphrase for %s: " (sasl-client-name client)))) + (authenticator-name + (sasl-client-property + client 'authenticator-name)) + (name (sasl-client-name client))) + (unwind-protect + (if (and authenticator-name + (not (string= authenticator-name name))) + (concat authenticator-name "\0" name "\0" passphrase) + (concat "\0" name "\0" passphrase)) + (fillarray passphrase 0)))) + +(put 'sasl-plain 'sasl-mechanism + (sasl-make-mechanism "PLAIN" sasl-plain-steps)) + +(provide 'sasl-plain) + +;;; LOGIN (No specification exists) +(defconst sasl-login-steps + '(ignore ;no initial response + sasl-login-response-1 + sasl-login-response-2)) + +(defun sasl-login-response-1 (client step) + (unless (string= (sasl-step-data step) "Username:") + (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-client-name client)) + +(defun sasl-login-response-2 (client step) + (unless (string= (sasl-step-data step) "Password:") + (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " (sasl-client-name client)))) + +(put 'sasl-login 'sasl-mechanism + (sasl-make-mechanism "LOGIN" sasl-login-steps)) + +(provide 'sasl-login) + +;;; ANONYMOUS (RFC2245) +(defconst sasl-anonymous-steps + '(identity ;no initial response + sasl-anonymous-response)) + +(defun sasl-anonymous-response (client step) + (or (sasl-client-property client 'trace) + (sasl-client-name client))) + +(put 'sasl-anonymous 'sasl-mechanism + (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) + +(provide 'sasl-anonymous) + +(provide 'sasl) + +;;; sasl.el ends here diff --git a/sasl.texi b/sasl.texi new file mode 100644 index 0000000..6d6e9ec --- /dev/null +++ b/sasl.texi @@ -0,0 +1,229 @@ +\input texinfo @c -*-texinfo-*- + +@setfilename sasl.info + +@set VERSION 0.2 + +@direntry +* SASL: (sasl). The Emacs SASL library. +@end direntry + +@settitle Emacs SASL Library @value{VERSION} + +@node Top +@top Emacs SASL +This manual describes the Emacs SASL library. + +A common interface to share several authentication mechanisms between +applications using different protocols. + +@menu +* Overview:: What Emacs SASL library is. +* How to use:: Adding authentication support to your applications. +* Data types:: +* Backend drivers:: Writing your own drivers. +* Index:: +* Function Index:: +* Variable Index:: +@end menu + +@node Overview +@chapter Overview + +@sc{sasl} is short for @dfn{Simple Authentication and Security Layer}. +This standard is documented in RFC2222. It provides a simple method for +adding authentication support to various application protocols. + +The toplevel interface of this library is inspired by Java @sc{sasl} +Application Program Interface. It defines an abstraction over a series +of authentication mechanism drivers (@ref{Backend drivers}). + +Backend drivers are designed to be close as possible to the +authentication mechanism. You can access the additional configuration +information anywhere from the implementation. + +@node How to use +@chapter How to use + +(Not yet written). + +To use Emacs SASL library, please evaluate following expression at the +beginning of your application program. + +@lisp +(require 'sasl) +@end lisp + +If you want to check existence of sasl.el at runtime, instead you +can list autoload settings for functions you want. + +@node Data types +@chapter Data types + +There are three data types to be used for carrying a negotiated +security layer---a mechanism, a client parameter and an authentication +step. + +@menu +* Mechanisms:: +* Clients:: +* Steps:: +@end menu + +@node Mechanisms +@section Mechanisms + +A mechanism (@code{sasl-mechanism} object) is a schema of the @sc{sasl} +authentication mechanism driver. + +@defvar sasl-mechanisms +A list of mechanism names. +@end defvar + +@defun sasl-find-mechanism mechanisms + +Retrieve an apropriate mechanism. +This function compares MECHANISMS and @code{sasl-mechanisms} then +returns apropriate @code{sasl-mechanism} object. + +@example +(let ((sasl-mechanisms '("CRAM-MD5" "DIGEST-MD5"))) + (setq mechanism (sasl-find-mechanism server-supported-mechanisms))) +@end example + +@end defun + +@defun sasl-mechanism-name mechanism +Return name of mechanism, a string. +@end defun + +If you want to write an authentication mechanism driver (@ref{Backend +drivers}), use @code{sasl-make-mechanism} and modify +@code{sasl-mechanisms} and @code{sasl-mechanism-alist} correctly. + +@defun sasl-make-mechanism name steps +Allocate a @code{sasl-mechanism} object. +This function takes two parameters---name of the mechanism, and a list +of authentication functions. + +@example +(defconst sasl-anonymous-steps + '(identity ;no initial response + sasl-anonymous-response)) + +(put 'sasl-anonymous 'sasl-mechanism + (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) +@end example + +@end defun + +@node Clients +@section Clients + +A client (@code{sasl-client} object) initialized with four +parameters---a mechanism, a user name, name of the service and name of +the server. + +@defun sasl-make-client mechanism name service server +Prepare a @code{sasl-client} object. +@end defun + +@defun sasl-client-mechanism client +Return the mechanism (@code{sasl-mechanism} object) of client. +@end defun + +@defun sasl-client-name client +Return the authorization name of client, a string. +@end defun + +@defun sasl-client-service client +Return the service name of client, a string. +@end defun + +@defun sasl-client-server client +Return the server name of client, a string. +@end defun + +If you want to specify additional configuration properties, please use +@code{sasl-client-set-property}. + +@defun sasl-client-set-property client property value +Add the given property/value to client. +@end defun + +@defun sasl-client-property client property +Return the value of the property of client. +@end defun + +@defun sasl-client-set-properties client plist +Destructively set the properties of client. +The second argument is the new property list. +@end defun + +@defun sasl-client-properties client +Return the whole property list of client configuration. +@end defun + +@node Steps +@section Steps + +A step (@code{sasl-step} object) is an abstraction of authentication +"step" which holds the response value and the next entry point for the +authentication process (the latter is not accessible). + +@defun sasl-step-data step +Return the data which STEP holds, a string. +@end defun + +@defun sasl-step-set-data step data +Store DATA string to STEP. +@end defun + +To get the initial response, you should call the function +@code{sasl-next-step} with the second argument nil. + +@example +(setq name (sasl-mechanism-name mechanism)) +@end example + +At this point we could send the command which starts a SASL +authentication protocol exchange. For example, + +@example +(process-send-string + process + (if (sasl-step-data step) ;initial response + (format "AUTH %s %s\r\n" name (base64-encode-string (sasl-step-data step) t)) + (format "AUTH %s\r\n" name))) +@end example + +To go on with the authentication process, all you have to do is call +@code{sasl-next-step} consecutively. + +@defun sasl-next-step client step +Perform the authentication step. +At the first time STEP should be set to nil. +@end defun + +@node Backend drivers +@chapter Backend drivers + +(Not yet written). + +@node Index +@chapter Index +@printindex cp + +@node Function Index +@chapter Function Index +@printindex fn + +@node Variable Index +@chapter Variable Index +@printindex vr + +@summarycontents +@contents +@bye + +@c End: diff --git a/sha1-dl.el b/sha1-dl.el new file mode 100644 index 0000000..7edccdd --- /dev/null +++ b/sha1-dl.el @@ -0,0 +1,59 @@ +;;; sha1-dl.el --- SHA1 Secure Hash Algorithm using DL module. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; 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: + +;;; Code: + +(provide 'sha1-dl) ; beware of circular dependency. +(eval-when-compile + (require 'sha1) ; sha1-dl-module. + (defun-maybe dynamic-link (a)) + (defun-maybe dynamic-call (a b))) + +(defvar sha1-dl-handle + (and (stringp sha1-dl-module) + (file-exists-p sha1-dl-module) + (dynamic-link sha1-dl-module))) + +;;; sha1-dl-module provides `sha1-string' and `sha1-binary'. +(dynamic-call "emacs_sha1_init" sha1-dl-handle) + +(defun sha1-region (beg end) + (sha1-string (buffer-substring-no-properties beg end))) + +(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-dl) + +;;; sha1-dl.el ends here diff --git a/sha1-el.el b/sha1-el.el new file mode 100644 index 0000000..96d52a3 --- /dev/null +++ b/sha1-el.el @@ -0,0 +1,408 @@ +;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; 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. +;; +;; 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. + +;;; 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/sha1.el b/sha1.el new file mode 100644 index 0000000..a7265b6 --- /dev/null +++ b/sha1.el @@ -0,0 +1,77 @@ +;;; sha1.el --- SHA1 Secure Hash Algorithm. + +;; Copyright (C) 1999 Shuhei KOBAYASHI + +;; Author: Shuhei KOBAYASHI +;; Kenichi OKADA +;; Maintainer: Kenichi OKADA +;; 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: + +;; Examples from FIPS PUB 180-1. +;; +;; +;; (sha1 "abc") +;; => a9993e364706816aba3e25717850c26c9cd0d89d +;; +;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") +;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1 +;; +;; (sha1 (make-string 1000000 ?a)) +;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f + +;;; Code: + +(require 'hex-util) + +(eval-when-compile + (defun-maybe sha1-string (a))) + +(defvar sha1-dl-module + (if (and (fboundp 'sha1-string) + (subrp (symbol-function 'sha1-string))) + nil + (if (fboundp 'dynamic-link) + (let ((path (expand-file-name "sha1.so" exec-directory))) + (and (file-exists-p path) + path))))) + +(cond + (sha1-dl-module + ;; Emacs with DL patch. + (require 'sha1-dl)) + (t + (require 'sha1-el))) + +;; compatibility for another sha1.el by Keiichi Suzuki. +(defun sha1-encode (string) + (decode-hex-string + (sha1-string string))) +(defun sha1-encode-binary (string) + (decode-hex-string + (sha1-string string))) + +(make-obsolete 'sha1-encode "It's old API.") +(make-obsolete 'sha1-encode-binary "It's old API.") + +(provide 'sha1) + +;;; sha1.el ends here diff --git a/smtp.el b/smtp.el index 27a0b99..0e9b28e 100644 --- a/smtp.el +++ b/smtp.el @@ -3,8 +3,9 @@ ;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani -;; Simon Leinen (ESMTP support) -;; Shuhei KOBAYASHI +;; Simon Leinen (ESMTP support) +;; Shuhei KOBAYASHI +;; Daiki Ueno ;; Keywords: SMTP, mail ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -24,327 +25,532 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; + ;;; Code: -(require 'poe) -(require 'poem) +(require 'pces) (require 'pcustom) (require 'mail-utils) ; mail-strip-quoted-names - -(eval-when-compile (require 'cl)) ; push +(require 'sasl) (defgroup smtp nil "SMTP protocol for sending mail." :group 'mail) +(defgroup smtp-extensions nil + "SMTP service extensions (RFC1869)." + :group 'smtp) + (defcustom smtp-default-server nil - "*Specify default SMTP server." + "Specify default SMTP server." :type '(choice (const nil) string) :group 'smtp) (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server) - "*The name of the host running SMTP server. It can also be a function + "The name of the host running SMTP server. +It can also be a function called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS." :type '(choice (string :tag "Name") (function :tag "Function")) :group 'smtp) (defcustom smtp-service "smtp" - "*SMTP service port number. \"smtp\" or 25." + "SMTP service port number. \"smtp\" or 25." :type '(choice (integer :tag "25" 25) (string :tag "smtp" "smtp")) :group 'smtp) -(defcustom smtp-use-8bitmime t - "*If non-nil, use ESMTP 8BITMIME if available." - :type 'boolean - :group 'smtp) - (defcustom smtp-local-domain nil - "*Local domain name without a host name. + "Local domain name without a host name. If the function (system-name) returns the full internet address, don't define this value." :type '(choice (const nil) string) :group 'smtp) -(defcustom smtp-debug-info nil - "*smtp debug info printout. messages and process buffer." - :type 'boolean +(defcustom smtp-fqdn nil + "Fully qualified domain name used for Message-ID." + :type '(choice (const nil) string) :group 'smtp) -(defcustom smtp-notify-success nil - "*If non-nil, notification for successful mail delivery is returned - to user (RFC1891)." +(defcustom smtp-use-8bitmime t + "If non-nil, use ESMTP 8BITMIME (RFC1652) if available." :type 'boolean - :group 'smtp) - + :group 'smtp-extensions) + +(defcustom smtp-use-size t + "If non-nil, use ESMTP SIZE (RFC1870) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-use-starttls nil + "If non-nil, use STARTTLS (RFC2595) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-use-sasl nil + "If non-nil, use SMTP Authentication (RFC2554) if available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-sasl-user-name (user-login-name) + "Identification to be used for authorization." + :type 'string + :group 'smtp-extensions) + +(defcustom smtp-sasl-user-realm smtp-local-domain + "Realm name to be used for authorization." + :type 'string + :group 'smtp-extensions) + +(defcustom smtp-sasl-mechanisms nil + "List of authentication mechanisms." + :type '(repeat string) + :group 'smtp-extensions) + +(defvar sasl-mechanisms) + +(defvar smtp-open-connection-function #'open-network-stream) + (defvar smtp-read-point nil) +(defvar smtp-connection-alist nil) + +(defvar smtp-submit-package-function #'smtp-submit-package) + +;;; @ SMTP package structure +;;; A package contains a mail message, an envelope sender address, +;;; and one or more envelope recipient addresses. In ESMTP model, +;;; we should guarantee the user to access the current sending package +;;; anywhere from the hook methods (or SMTP commands). + +(defmacro smtp-package-sender (package) + "Return the sender of PACKAGE, a string." + `(aref ,package 0)) + +(defmacro smtp-package-recipients (package) + "Return the recipients of PACKAGE, a list of strings." + `(aref ,package 1)) + +(defmacro smtp-package-buffer (package) + "Return the data of PACKAGE, a buffer." + `(aref ,package 2)) + +(defmacro smtp-make-package (sender recipients buffer) + "Create a new package structure. +A package is a unit of SMTP message which contains a mail message, +an envelope sender address, and one or more envelope recipient addresses. +SENDER specifies the package sender, a string. +RECIPIENTS is a list of recipients. +BUFFER may be a buffer or a buffer name which contains mail message." + `(vector ,sender ,recipients ,buffer)) + +(defun smtp-package-buffer-size (package) + "Return the size of PACKAGE, an integer." + (save-excursion + (set-buffer (smtp-package-buffer package)) + (let ((size + (+ (buffer-size) + ;; Add one byte for each change-of-line + ;; because or CR-LF representation: + (count-lines (point-min) (point-max)) + ;; For some reason, an empty line is + ;; added to the message. Maybe this + ;; is a bug, but it can't hurt to add + ;; those two bytes anyway: + 2))) + (goto-char (point-min)) + (while (re-search-forward "^\\." nil t) + (setq size (1+ size))) + size))) + +;;; @ SMTP connection structure +;;; We should take care of a emulation for another network stream. +;;; They are likely to be implemented with a external program and the function +;;; `process-contact' returns the process ID instead of `(HOST SERVICE)' pair. + +(defmacro smtp-connection-process (connection) + "Return the subprocess-object of CONNECTION." + `(aref ,connection 0)) + +(defmacro smtp-connection-server (connection) + "Return the server of CONNECTION, a string." + `(aref ,connection 1)) + +(defmacro smtp-connection-service (connection) + "Return the service of CONNECTION, a string or an integer." + `(aref ,connection 2)) + +(defmacro smtp-connection-extensions (connection) + "Return the SMTP extensions of CONNECTION, a list of strings." + `(aref ,connection 3)) + +(defmacro smtp-connection-set-extensions (connection extensions) + "Set the SMTP extensions of CONNECTION. +EXTENSIONS is a list of cons cells of the form \(EXTENSION . PARAMETERS). +Where EXTENSION is a symbol and PARAMETERS is a list of strings." + `(aset ,connection 3 ,extensions)) + +(defmacro smtp-make-connection (process server service) + "Create a new connection structure. +PROCESS is an internal subprocess-object. SERVER is name of the host +to connect to. SERVICE is name of the service desired." + `(vector ,process ,server ,service nil)) + +(defun smtp-connection-opened (connection) + "Say whether the CONNECTION to server has been opened." + (let ((process (smtp-connection-process connection))) + (if (memq (process-status process) '(open run)) + t))) + +(defun smtp-close-connection (connection) + "Close the CONNECTION to server." + (let ((process (smtp-connection-process connection))) + (delete-process process))) + (defun smtp-make-fqdn () "Return user's fully qualified domain name." - (let ((system-name (system-name))) - (cond - (smtp-local-domain - (concat system-name "." smtp-local-domain)) - ((string-match "[^.]\\.[^.]" system-name) - system-name) - (t - (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly."))))) - -(defun smtp-via-smtp (sender recipients smtp-text-buffer) - (let ((server (if (functionp smtp-server) - (funcall smtp-server sender recipients) - smtp-server)) - process response extensions) + (if smtp-fqdn + smtp-fqdn + (let ((system-name (system-name))) + (cond + (smtp-local-domain + (concat system-name "." smtp-local-domain)) + ((string-match "[^.]\\.[^.]" system-name) + system-name) + (t + (error "Cannot generate valid FQDN")))))) + +(defun smtp-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((entry (assq buffer smtp-connection-alist)) + connection) + (when entry + (setq connection (nth 1 entry)) + (if (smtp-connection-opened connection) + connection + (setq smtp-connection-alist + (delq entry smtp-connection-alist)) + nil)))) + +(eval-and-compile + (autoload 'starttls-open-stream "starttls") + (autoload 'starttls-negotiate "starttls")) + +(defun smtp-open-connection (buffer server service) + "Open a SMTP connection for a service to a host. +Return a newly allocated connection-object. +BUFFER is the buffer to associate with the connection. SERVER is name +of the host to connect to. SERVICE is name of the service desired." + (let ((process + (as-binary-process + (funcall smtp-open-connection-function + "SMTP" buffer server service))) + connection) + (when process + (setq connection (smtp-make-connection process server service)) + (set-process-filter process 'smtp-process-filter) + (setq smtp-connection-alist + (cons (list buffer connection) + smtp-connection-alist)) + connection))) + +;;;###autoload +(defun smtp-via-smtp (sender recipients buffer) + (condition-case nil + (progn + (smtp-send-buffer sender recipients buffer) + t) + (smtp-error))) + +(make-obsolete 'smtp-via-smtp "It's old API.") + +;;;###autoload +(defun smtp-send-buffer (sender recipients buffer) + (let ((server + (if (functionp smtp-server) + (funcall smtp-server sender recipients) + smtp-server)) + (package + (smtp-make-package sender recipients buffer)) + (smtp-open-connection-function + (if smtp-use-starttls + #'starttls-open-stream + smtp-open-connection-function))) (save-excursion (set-buffer (get-buffer-create (format "*trace of SMTP session to %s*" server))) (erase-buffer) + (buffer-disable-undo) + (unless (smtp-find-connection (current-buffer)) + (smtp-open-connection (current-buffer) server smtp-service)) (make-local-variable 'smtp-read-point) (setq smtp-read-point (point-min)) - - (unwind-protect - (catch 'done - (setq process (open-network-stream-as-binary - "SMTP" (current-buffer) server smtp-service)) - (or process (throw 'done nil)) - - (set-process-filter process 'smtp-process-filter) - - ;; Greeting - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - ;; EHLO - (smtp-send-command process - (format "EHLO %s" (smtp-make-fqdn))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (progn - ;; HELO - (smtp-send-command process - (format "HELO %s" (smtp-make-fqdn))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response))))) - (let ((extension-lines (cdr (cdr response)))) - (while extension-lines - (push (intern (downcase (substring (car extension-lines) 4))) - extensions) - (setq extension-lines (cdr extension-lines))))) - - ;; ONEX --- One message transaction only (sendmail extension?) - (if (or (memq 'onex extensions) - (memq 'xone extensions)) - (progn - (smtp-send-command process "ONEX") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; VERB --- Verbose (sendmail extension?) - (if (and smtp-debug-info - (or (memq 'verb extensions) - (memq 'xvrb extensions))) - (progn - (smtp-send-command process "VERB") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; XUSR --- Initial (user) submission (sendmail extension?) - (if (memq 'xusr extensions) - (progn - (smtp-send-command process "XUSR") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - - ;; MAIL FROM: - (smtp-send-command - process - (format "MAIL FROM:<%s>%s%s" - sender - ;; SIZE --- Message Size Declaration (RFC1870) - (if (memq 'size extensions) - (format " SIZE=%d" - (save-excursion - (set-buffer smtp-text-buffer) - (+ (- (point-max) (point-min)) - ;; Add one byte for each change-of-line - ;; because or CR-LF representation: - (count-lines (point-min) (point-max)) - ;; For some reason, an empty line is - ;; added to the message. Maybe this - ;; is a bug, but it can't hurt to add - ;; those two bytes anyway: - 2))) - "") - ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) - (if (and (memq '8bitmime extensions) - smtp-use-8bitmime) - " BODY=8BITMIME" - ""))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - ;; RCPT TO: - (while recipients - (smtp-send-command process - (format - (if smtp-notify-success - "RCPT TO:<%s> NOTIFY=SUCCESS" - "RCPT TO:<%s>") - (car recipients))) - (setq recipients (cdr recipients)) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response))))) - - ;; DATA - (smtp-send-command process "DATA") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - ;; Mail contents - (smtp-send-data process smtp-text-buffer) - - ;; DATA end "." - (smtp-send-command process ".") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - - t) - - (if (and process - (eq (process-status process) 'open)) - (progn - ;; QUIT - (smtp-send-command process "QUIT") - (smtp-read-response process) - (delete-process process))))))) - + (funcall smtp-submit-package-function package)))) + +(defun smtp-submit-package (package) + (unwind-protect + (progn + (smtp-primitive-greeting package) + (condition-case nil + (smtp-primitive-ehlo package) + (smtp-response-error + (smtp-primitive-helo package))) + (if smtp-use-starttls + (smtp-primitive-starttls package)) + (if smtp-use-sasl + (smtp-primitive-auth package)) + (smtp-primitive-mailfrom package) + (smtp-primitive-rcptto package) + (smtp-primitive-data package)) + (let ((connection (smtp-find-connection (current-buffer)))) + (when (smtp-connection-opened connection) + ;; QUIT + (smtp-primitive-quit package) + (smtp-close-connection connection))))) + +;;; @ hook methods for `smtp-submit-package' +;;; + +(defun smtp-primitive-greeting (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (response + (smtp-read-response + (smtp-connection-process connection)))) + (if (/= (car response) 220) + (smtp-response-error response)))) + +(defun smtp-primitive-ehlo (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + response) + (smtp-send-command process (format "EHLO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response process)) + (if (/= (car response) 250) + (smtp-response-error response)) + (smtp-connection-set-extensions + connection (mapcar + (lambda (extension) + (let ((extensions + (split-string extension))) + (setcar extensions + (car (read-from-string + (downcase (car extensions))))) + extensions)) + (cdr response))))) + +(defun smtp-primitive-helo (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + response) + (smtp-send-command process (format "HELO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response process)) + (if (/= (car response) 250) + (smtp-response-error response)))) + +(defun smtp-primitive-auth (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + (mechanisms + (cdr (assq 'auth (smtp-connection-extensions connection)))) + (sasl-mechanisms + (or smtp-sasl-mechanisms sasl-mechanisms)) + (mechanism + (sasl-find-mechanism mechanisms)) + client + name + step + response) + (unless mechanism + (error "No authentication mechanism available")) + (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp" + (smtp-connection-server connection))) + (if smtp-sasl-user-realm + (sasl-client-set-property client 'realm smtp-sasl-user-realm)) + (setq name (sasl-mechanism-name mechanism) + ;; Retrieve the initial response + step (sasl-next-step client nil)) + (smtp-send-command + process + (if (sasl-step-data step) + (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t)) + (format "AUTH %s" name))) + (catch 'done + (while t + (setq response (smtp-read-response process)) + (when (= (car response) 235) + ;; The authentication process is finished. + (setq step (sasl-next-step client step)) + (if (null step) + (throw 'done nil)) + (smtp-response-error response)) ;Bogus server? + (if (/= (car response) 334) + (smtp-response-error response)) + (sasl-step-set-data step (base64-decode-string (nth 1 response))) + (setq step (sasl-next-step client step)) + (smtp-send-command + process (if (sasl-step-data step) + (base64-encode-string (sasl-step-data step) t) + "")))))) + +(defun smtp-primitive-starttls (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + response) + ;; STARTTLS --- begin a TLS negotiation (RFC 2595) + (smtp-send-command process "STARTTLS") + (setq response (smtp-read-response process)) + (if (/= (car response) 220) + (smtp-response-error response)) + (starttls-negotiate process))) + +(defun smtp-primitive-mailfrom (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + (extensions + (smtp-connection-extensions + connection)) + (sender + (smtp-package-sender package)) + extension + response) + ;; SIZE --- Message Size Declaration (RFC1870) + (if (and smtp-use-size + (assq 'size extensions)) + (setq extension (format "SIZE=%d" (smtp-package-buffer-size package)))) + ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) + (if (and smtp-use-8bitmime + (assq '8bitmime extensions)) + (setq extension (concat extension " BODY=8BITMIME"))) + (smtp-send-command + process + (if extension + (format "MAIL FROM:<%s> %s" sender extension) + (format "MAIL FROM:<%s>" sender))) + (setq response (smtp-read-response process)) + (if (/= (car response) 250) + (smtp-response-error response)))) + +(defun smtp-primitive-rcptto (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + (recipients + (smtp-package-recipients package)) + response) + (while recipients + (smtp-send-command + process (format "RCPT TO:<%s>" (pop recipients))) + (setq response (smtp-read-response process)) + (unless (memq (car response) '(250 251)) + (smtp-response-error response))))) + +(defun smtp-primitive-data (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + response) + (smtp-send-command process "DATA") + (setq response (smtp-read-response process)) + (if (/= (car response) 354) + (smtp-response-error response)) + (save-excursion + (set-buffer (smtp-package-buffer package)) + (goto-char (point-min)) + (while (not (eobp)) + (smtp-send-data + process (buffer-substring (point) (progn (end-of-line)(point)))) + (forward-char))) + (smtp-send-command process ".") + (setq response (smtp-read-response process)) + (if (/= (car response) 250) + (smtp-response-error response)))) + +(defun smtp-primitive-quit (package) + (let* ((connection + (smtp-find-connection (current-buffer))) + (process + (smtp-connection-process connection)) + response) + (smtp-send-command process "QUIT") + (setq response (smtp-read-response process)) + (if (/= (car response) 221) + (smtp-response-error response)))) + +;;; @ low level process manipulating function +;;; (defun smtp-process-filter (process output) (save-excursion (set-buffer (process-buffer process)) (goto-char (point-max)) (insert output))) +(put 'smtp-error 'error-message "SMTP error") +(put 'smtp-error 'error-conditions '(smtp-error error)) + +(put 'smtp-response-error 'error-message "SMTP response error") +(put 'smtp-response-error 'error-conditions '(smtp-response-error smtp-error error)) + +(defun smtp-response-error (response) + (signal 'smtp-response-error response)) + (defun smtp-read-response (process) - (let ((case-fold-search nil) - (response-strings nil) + (let (case-fold-search (response-continue t) - (return-value '(nil ())) - match-end) - + response) (while response-continue (goto-char smtp-read-point) (while (not (search-forward "\r\n" nil t)) (accept-process-output process) (goto-char smtp-read-point)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtp-read-point (- match-end 2)) - response-strings)) - - (goto-char smtp-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtp-debug-info - (message "%s" (car response-strings))) - - (setq smtp-read-point match-end) - - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil - (setq response-continue nil) - (setq return-value - (cons (string-to-int - (buffer-substring begin end)) - (nreverse response-strings))))) - - (if (looking-at "[0-9]+-") - (progn (if smtp-debug-info - (message "%s" (car response-strings))) - (setq smtp-read-point match-end) - (setq response-continue t)) - (progn - (setq smtp-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))))))) - (setq smtp-read-point match-end) - return-value)) + (setq response + (nconc response + (list (buffer-substring + (+ 4 smtp-read-point) + (- (point) 2))))) + (goto-char + (prog1 smtp-read-point + (setq smtp-read-point (point)))) + (if (looking-at "[1-5][0-9][0-9] ") + (setq response (cons (read (point-marker)) response) + response-continue nil))) + response)) (defun smtp-send-command (process command) - (goto-char (point-max)) - (insert command "\r\n") - (setq smtp-read-point (point)) - (process-send-string process command) - (process-send-string process "\r\n")) - -(defun smtp-send-data-1 (process data) - (goto-char (point-max)) - (if smtp-debug-info - (insert data "\r\n")) - (setq smtp-read-point (point)) - ;; Escape "." at start of a line. - (if (eq (string-to-char data) ?.) - (process-send-string process ".")) - (process-send-string process data) - (process-send-string process "\r\n")) - -(defun smtp-send-data (process buffer) - (let ((data-continue t) - (sending-data nil) - this-line - this-line-end) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert command "\r\n") + (setq smtp-read-point (point)) + (process-send-string process command) + (process-send-string process "\r\n"))) - (save-excursion - (set-buffer buffer) - (goto-char (point-min))) - - (while data-continue - (save-excursion - (set-buffer buffer) - (beginning-of-line) - (setq this-line (point)) - (end-of-line) - (setq this-line-end (point)) - (setq sending-data nil) - (setq sending-data (buffer-substring this-line this-line-end)) - (if (or (/= (forward-line 1) 0) (eobp)) - (setq data-continue nil))) - - (smtp-send-data-1 process sending-data)))) +(defun smtp-send-data (process data) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (setq smtp-read-point (point)) + ;; Escape "." at start of a line. + (if (eq (string-to-char data) ?.) + (process-send-string process ".")) + (process-send-string process data) + (process-send-string process "\r\n"))) (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO:
."