From: okada Date: Sun, 19 Nov 2000 23:37:32 +0000 (+0000) Subject: * FLIM-ELS (flim-modules): Add `sasl-cram', `sasl-digest' , `qmtp'. X-Git-Tag: slim-1_14_5~8 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=510247933e1172bb4ac5964b34b956c9bb5c7acd;p=elisp%2Fflim.git * FLIM-ELS (flim-modules): Add `sasl-cram', `sasl-digest' , `qmtp'. Remove `digest-md5'. * sasl.el: sync up with flim-1_14. * smtp.el: sync up with flim-1_14. * qmtp.el: New file. * sasl-cram.el: New file. * sasl-digest.el: New file. * digest-md5.el: Delete. --- diff --git a/ChangeLog b/ChangeLog index b2a1433..dcd146a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2000-11-20 Kenichi OKADA + + * FLIM-ELS (flim-modules): Add `sasl-cram', `sasl-digest' , `qmtp'. + Remove `digest-md5'. + * sasl.el: sync up with flim-1_14. + * smtp.el: sync up with flim-1_14. + * qmtp.el: New file. + * sasl-cram.el: New file. + * sasl-digest.el: New file. + * digest-md5.el: Delete. + + 2000-10-20 Kenichi OKADA * SLIM: Version 1.14.3 released. @@ -1397,7 +1409,7 @@ 1999-03-01 MORIOKA Tomohiko * mel.el (mime-decode-string): Return STRING if return value of - `(mel-find-function 'mime-decode-string encoding)' is nil. + `(mel-find-function 'mime-decode-string encoding)' is nil. 1999-02-10 MORIOKA Tomohiko @@ -2718,12 +2730,12 @@ 1998-08-28 MORIOKA Tomohiko * eword-encode.el (eword-encode-field): Use `capitalize' instead - of `downcase' for `field-name'. + of `downcase' for `field-name'. * eword-encode.el (eword-encode-structured-field-body): New - function. + function. (eword-encode-field): Use `eword-encode-structured-field-body' for - "MIME-Version" and "User-Agent" field. + "MIME-Version" and "User-Agent" field. 1998-08-26 Shuhei KOBAYASHI @@ -2733,15 +2745,15 @@ * eword-encode.el (eword-encode-address-list): New function. (eword-encode-field): Use `eword-encode-address-list' instead of - `tm-eword::encode-address-list'; abolish - `tm-eword::encode-address-list'. + `tm-eword::encode-address-list'; abolish + `tm-eword::encode-address-list'. * eword-encode.el (eword-encode-field): Use `eword-encode-string' - instead of `tm-eword::encode-string'; abolish - `tm-eword::encode-string'. + instead of `tm-eword::encode-string'; abolish + `tm-eword::encode-string'. * eword-encode.el: Rename `tm-eword::make-rword' -> - `make-ew-rword'; rename `tm-eword::rword-' -> `ew-rword-'. + `make-ew-rword'; rename `tm-eword::rword-' -> `ew-rword-'. 1998-08-26 Shuhei KOBAYASHI @@ -3419,7 +3431,7 @@ * FLIM: Version 1.2.0 (J-D~jr) was released. * README.en (What's FLIM): Delete description about - std11-parse.el; add description about mailcap.el. + std11-parse.el; add description about mailcap.el. 1998-05-06 MORIOKA Tomohiko @@ -3506,7 +3518,7 @@ * FLIM: Version 1.0.1 (Ky-Drto) was released. * mime-def.el (mime-spadework-module-version-string): New - constant. + constant. * eword-encode.el: Abolish constant 'eword-encode-version. @@ -3543,6 +3555,6 @@ * Makefile: New file. * mime-def.el, std11-parse.el, std11.el, eword-decode.el, - eword-encode.el: Copied from MEL, SEMI (mime-def.el - eword-decode.el eword-encode.el) and APEL (std11-parse.el - std11.el). + eword-encode.el: Copied from MEL, SEMI (mime-def.el + eword-decode.el eword-encode.el) and APEL (std11-parse.el + std11.el). diff --git a/FLIM-ELS b/FLIM-ELS index 63ee339..e5cf2cf 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -15,8 +15,8 @@ md5 md5-el md5-dl sha1 sha1-el sha1-dl hmac-def hmac-md5 hmac-sha1 hex-util - scram-md5 digest-md5 unique-id - starttls)) + scram-md5 unique-id qmtp + sasl-cram sasl-digest)) (if (and (fboundp 'base64-encode-string) (subrp (symbol-function 'base64-encode-string))) diff --git a/Makefile b/Makefile index 72a037a..9f9860d 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ PACKAGE = slim API = 1.14 -RELEASE = 1 +RELEASE = 3 TAR = tar RM = /bin/rm -f diff --git a/digest-md5.el b/digest-md5.el deleted file mode 100644 index e72c535..0000000 --- a/digest-md5.el +++ /dev/null @@ -1,144 +0,0 @@ -;;; digest-md5.el --- Compute DIGEST-MD5. - -;; Copyright (C) 1999 Kenichi OKADA - -;; Author: Kenichi OKADA -;; Daiki Ueno -;; Keywords: DIGEST-MD5, HMAC-MD5, SASL, IMAP, POP, ACAP - -;; 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 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) - -;; Examples. -;; -;; (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) - -;; (digest-md5-build-response-value -;; "chris" "elwood.innosoft.com" "secret" "OA6MG9tEQGm2hh" -;; "OA6MHXh6VqTrRk" 1 "imap/elwood.innosoft.com" "auth") -;; => "d388dad90d4bbd760a152321f2143af7" - -;;; Code: - -(require 'hmac-md5) -(require 'unique-id) - -(defvar digest-md5-challenge nil) - -(defvar 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.") - -;;;###autoload -(defun digest-md5-parse-digest-challenge (digest-challenge) - ;; return a property list of - ;; (realm nonce qop-options stale maxbuf charset - ;; algorithm cipher-opts auth-param). - (with-temp-buffer - (set-syntax-table 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 'digest-md5-challenge (read (point-min-marker))) - (end-of-file - (error "Parse error in digest-challenge."))))) - -(defun 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)))) - -(defmacro digest-md5-cnonce () - ;; It is RECOMMENDED that it - ;; contain at least 64 bits of entropy. - '(concat (unique-id-m "") (unique-id-m ""))) - -(defmacro digest-md5-challenge (prop) - (list 'get ''digest-md5-challenge prop)) - -(defmacro digest-md5-build-response-value - (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 (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)))))))) - -;;;###autoload -(defun digest-md5-digest-response - (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=" - (digest-md5-build-response-value - username realm passwd nonce cnonce nonce-count digest-uri - (or qop "auth")) - "," - (mapconcat - #'identity - (delq nil - (mapcar (lambda (prop) - (if (digest-md5-challenge prop) - (format "%s=%s" - prop (digest-md5-challenge prop)))) - '(charset qop maxbuf cipher authzid))) - ","))) - -(provide 'digest-md5) - -;;; digest-md5.el ends here diff --git a/luna.el b/luna.el index e66d265..48da490 100644 --- a/luna.el +++ b/luna.el @@ -1,7 +1,6 @@ ;;; luna.el --- tiny OOP system kernel -;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. +;; Copyright (C) 1999,2000 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Keywords: OOP @@ -36,6 +35,10 @@ (defconst :after ':after) (defconst :around ':around))) + +;;; @ class +;;; + (defmacro luna-find-class (name) "Return the luna-class of the given NAME." `(get ,name 'luna-class)) @@ -116,18 +119,6 @@ If SLOTS is specified, TYPE will be defined to have them." (defmacro luna-class-slot-index (class slot-name) `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index)) -(defmacro luna-slot-index (entity slot-name) - `(luna-class-slot-index (luna-find-class (luna-class-name ,entity)) - ,slot-name)) - -(defsubst luna-slot-value (entity slot) - "Return the value of SLOT of ENTITY." - (aref entity (luna-slot-index entity slot))) - -(defsubst luna-set-slot-value (entity slot value) - "Store VALUE into SLOT of ENTITY." - (aset entity (luna-slot-index entity slot) value)) - (defmacro luna-define-method (name &rest definition) "Define NAME as a method function of a class. @@ -208,6 +199,35 @@ BODY is the body of method." (luna-class-find-parents-functions class service) ))) + +;;; @ instance (entity) +;;; + +(defmacro luna-class-name (entity) + "Return class-name of the ENTITY." + `(aref ,entity 0)) + +(defmacro luna-set-class-name (entity name) + `(aset ,entity 0 ,name)) + +(defmacro luna-get-obarray (entity) + `(aref ,entity 1)) + +(defmacro luna-set-obarray (entity obarray) + `(aset ,entity 1 ,obarray)) + +(defmacro luna-slot-index (entity slot-name) + `(luna-class-slot-index (luna-find-class (luna-class-name ,entity)) + ,slot-name)) + +(defsubst luna-slot-value (entity slot) + "Return the value of SLOT of ENTITY." + (aref entity (luna-slot-index entity slot))) + +(defsubst luna-set-slot-value (entity slot value) + "Store VALUE into SLOT of ENTITY." + (aset entity (luna-slot-index entity slot) value)) + (defmacro luna-find-functions (entity service) `(luna-class-find-functions (luna-find-class (luna-class-name ,entity)) ,service)) @@ -251,19 +271,6 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." t)))) luna-previous-return-value)) -(defmacro luna-class-name (entity) - "Return class-name of the ENTITY." - `(aref ,entity 0)) - -(defmacro luna-set-class-name (entity name) - `(aset ,entity 0 ,name)) - -(defmacro luna-get-obarray (entity) - `(aref ,entity 1)) - -(defmacro luna-set-obarray (entity obarray) - `(aset ,entity 1 ,obarray)) - (defun luna-make-entity (type &rest init-args) "Make instance of luna-class TYPE and return it. If INIT-ARGS is specified, it is used as initial values of the slots. @@ -275,6 +282,10 @@ It must be plist and each slot name must have prefix `:'." (apply #'luna-send v 'initialize-instance v init-args) )) + +;;; @ interface (generic function) +;;; + (defsubst luna-arglist-to-arguments (arglist) (let (dest) (while arglist @@ -301,6 +312,10 @@ ARGS is argument of and DOC is DOC-string." (put 'luna-define-generic 'lisp-indent-function 'defun) + +;;; @ accessor +;;; + (defun luna-define-internal-accessors (class-name) "Define internal accessors for an entity of CLASS-NAME." (let ((entity-class (luna-find-class class-name)) @@ -336,6 +351,10 @@ ARGS is argument of and DOC is DOC-string." ))) (luna-class-obarray entity-class)))) + +;;; @ standard object +;;; + (luna-define-class-function 'standard-object) (luna-define-method initialize-instance ((entity standard-object) diff --git a/mime-en.sgml b/mime-en.sgml index 746c987..4e8dcad 100644 --- a/mime-en.sgml +++ b/mime-en.sgml @@ -1358,7 +1358,6 @@ cvsroot $B$O(B :ext:cvs@cvs.m17n.org:/cvs/root $B$H$J$j$^$9!#(B $B$3$N>l9g!"(BUNIX $B$N(B /etc/passwd $BMM<0$G0E9f2=$5$l$?%Q%9%o!<%I$rAw$C$F2<$5$$!#(B $B$3$N>l9g(B cvsroot $B$O(B :pserver:<$B%"%+%&%s%HL>(B>@cvs.m17n.org:/cvs/root $B$H$J$j$^$9!#(B -

History of FLIM History

diff --git a/mmgeneric.el b/mmgeneric.el index 84d481b..5bd9686 100644 --- a/mmgeneric.el +++ b/mmgeneric.el @@ -37,19 +37,21 @@ ;; (autoload 'mime-parse-external "mime-parse") (autoload 'mime-entity-content "mime") -(luna-define-class mime-entity () - (location - content-type children parent - node-id - content-disposition encoding - ;; for other fields - original-header parsed-header)) +(eval-and-compile + (luna-define-class mime-entity () + (location + content-type children parent + node-id + content-disposition encoding + ;; for other fields + original-header parsed-header)) + + (luna-define-internal-accessors 'mime-entity) + ) (defalias 'mime-entity-representation-type-internal 'luna-class-name) (defalias 'mime-entity-set-representation-type-internal 'luna-set-class-name) -(luna-define-internal-accessors 'mime-entity) - (luna-define-method mime-entity-fetch-field ((entity mime-entity) field-name) (or (symbolp field-name) diff --git a/qmtp.el b/qmtp.el new file mode 100644 index 0000000..459cd7f --- /dev/null +++ b/qmtp.el @@ -0,0 +1,142 @@ +;;; qmtp.el --- basic functions to send mail with QMTP server + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; 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..25d1082 --- /dev/null +++ b/sasl-cram.el @@ -0,0 +1,51 @@ +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; 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..1a1eb8a --- /dev/null +++ b/sasl-digest.el @@ -0,0 +1,151 @@ +;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; 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-nonce-count 1) +(defvar sasl-digest-md5-unique-id-function + sasl-unique-id-function) + +(defvar sasl-digest-md5-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)) ;"" + +(defun sasl-digest-md5-parse-string (string) + "Parse STRING and return a property list. +The value is a cons cell of the form \(realm nonce qop-options stale maxbuf +charset algorithm cipher-opts auth-param)." + (with-temp-buffer + (set-syntax-table sasl-digest-md5-syntax-table) + (save-excursion + (insert string) + (goto-char (point-min)) + (insert "(") + (while (progn (forward-sexp) (not (eobp))) + (delete-char 1) + (insert " ")) + (insert ")") + (read (point-min-marker))))) + +(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name) + (concat serv-type "/" host + (if (and serv-name + (not (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))) + +(defun sasl-digest-md5-response-value (username + realm + nonce + cnonce + nonce-count + qop + digest-uri + authzid) + (let ((passphrase + (sasl-read-passphrase + (format "DIGEST-MD5 passphrase for %s: " + username)))) + (unwind-protect + (encode-hex-string + (md5-binary + (concat + (encode-hex-string + (md5-binary (concat (md5-binary + (concat username ":" realm ":" passphrase)) + ":" nonce ":" cnonce + (if authzid + (concat ":" authzid))))) + ":" nonce + ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" + (encode-hex-string + (md5-binary + (concat "AUTHENTICATE:" digest-uri + (if (string-equal "auth-int" qop) + ":00000000000000000000000000000000"))))))) + (fillarray passphrase 0)))) + +(defun sasl-digest-md5-response (client step) + (let* ((plist + (sasl-digest-md5-parse-string (sasl-step-data step))) + (realm + (or (sasl-client-property client 'realm) + (plist-get plist 'realm))) ;need to check + (nonce-count + (or (sasl-client-property client 'nonce-count) + sasl-digest-md5-nonce-count)) + (digest-uri + (sasl-digest-md5-digest-uri + (sasl-client-service client)(sasl-client-server client))) + (cnonce + (or (sasl-client-property client 'cnonce) + (sasl-digest-md5-cnonce)))) + (sasl-client-set-property client 'nonce-count (1+ nonce-count)) + (concat + "username=\"" (sasl-client-name client) "\"," + "realm=\"" realm "\"," + "nonce=\"" (plist-get plist 'nonce) "\"," + "cnonce=\"" cnonce "\"," + (format "nc=%08x," nonce-count) + "digest-uri=\"" digest-uri "\"," + "response=" + (sasl-digest-md5-response-value + (sasl-client-name client) + realm + (plist-get plist 'nonce) + cnonce + nonce-count + (or (sasl-client-property client 'qop) + "auth") + digest-uri + (plist-get plist 'authzid))))) + +(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 index dd07f13..8528898 100644 --- a/sasl.el +++ b/sasl.el @@ -1,9 +1,9 @@ -;;; sasl.el --- basic functions for SASL +;;; sasl.el --- SASL client framework -;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. +;; Copyright (C) 2000 Free Software Foundation, Inc. -;; Author: Kenichi OKADA -;; Keywords: SMTP, SASL, RFC2222 +;; Author: Daiki Ueno +;; Keywords: SASL ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -24,133 +24,246 @@ ;;; Commentary: -;; Example. +;; This module provides common interface functions to share several +;; SASL mechanism drivers. The toplevel is designed to be mostly +;; compatible with [Java-SASL]. ;; -;; (base64-encode-string -;; (sasl-scram-md5-client-msg-2 -;; (base64-decode-string "dGVzdHNhbHQBAAAAaW1hcEBlbGVhbm9yLmlubm9zb2Z0LmNvbQBqaGNOWmxSdVBiemlGcCt2TFYrTkN3") -;; (base64-decode-string "AGNocmlzADx0NG40UGFiOUhCMEFtL1FMWEI3MmVnQGVsZWFub3IuaW5ub3NvZnQuY29tPg==") -;; (scram-md5-make-salted-pass -;; "secret stuff" "testsalt"))) -;; => "AQAAAMg9jU8CeB4KOfk7sUhSQPs=" +;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", +;; RFC 2222, October 1997. ;; -;; (base64-encode-string -;; (scram-md5-make-server-msg-2 -;; (base64-decode-string "dGVzdHNhbHQBAAAAaW1hcEBlbGVhbm9yLmlubm9zb2Z0LmNvbQBqaGNOWmxSdVBiemlGcCt2TFYrTkN3") -;; (base64-decode-string "AGNocmlzADx0NG40UGFiOUhCMEFtL1FMWEI3MmVnQGVsZWFub3IuaW5ub3NvZnQuY29tPg==") -;; (scram-make-security-info nil t 0) -;; "testsalt" -;; (scram-md5-make-salted-pass -;; "secret stuff" "testsalt"))) -;; => "U0odqYw3B7XIIW0oSz65OQ==" +;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program +;; Interface", draft-weltman-java-sasl-03.txt, March 2000. ;;; Code: -(require 'hmac-md5) - -(eval-when-compile - (require 'scram-md5) - (require 'digest-md5)) - -(eval-and-compile - (autoload 'open-ssl-stream "ssl") - (autoload 'base64-decode-string "base64") - (autoload 'base64-encode-string "base64") - (autoload 'starttls-open-stream "starttls") - (autoload 'starttls-negotiate "starttls") - (autoload 'digest-md5-parse-digest-challenge "digest-md5") - (autoload 'digest-md5-digest-response "digest-md5") - (autoload 'scram-md5-make-salted-pass "scram-md5") - (autoload 'scram-md5-parse-server-msg-1 "scram-md5") - (autoload 'scram-md5-make-client-msg-1 "scram-md5")) - -;;; CRAM-MD5 -(defun sasl-cram-md5 (username passphrase challenge) - (let ((secure-word (copy-sequence passphrase))) - (setq secure-word (unwind-protect - (hmac-md5 challenge secure-word) - (fillarray secure-word 0)) - secure-word (unwind-protect - (encode-hex-string secure-word) - (fillarray secure-word 0)) - secure-word (unwind-protect - (concat username " " secure-word) - (fillarray secure-word 0))))) - -;;; PLAIN -(defun sasl-plain (authorid authenid passphrase) - (concat authorid "\0" authenid "\0" passphrase)) - -;;; SCRAM-MD5 -(defvar sasl-scram-md5-client-security-info - (eval-when-compile - (scram-make-security-info nil t 0))) - -(defun sasl-scram-md5-make-salted-pass (server-msg-1 passphrase) - (scram-md5-make-salted-pass - passphrase - (car - (scram-md5-parse-server-msg-1 server-msg-1)))) - -(defun sasl-scram-md5-client-msg-1 (authenticate-id &optional authorize-id) - (scram-md5-make-client-msg-1 authenticate-id authorize-id)) - -(defun sasl-scram-md5-client-msg-2 (server-msg-1 client-msg-1 salted-pass) - (let (client-proof client-key shared-key client-verifier) - (setq client-key - (scram-md5-make-client-key salted-pass)) - (setq client-verifier - (scram-md5-make-client-verifier client-key)) - (setq shared-key - (unwind-protect - (scram-md5-make-shared-key - server-msg-1 - client-msg-1 - sasl-scram-md5-client-security-info - client-verifier) - (fillarray client-verifier 0))) - (setq client-proof - (unwind-protect - (scram-md5-make-client-proof - client-key shared-key) - (fillarray client-key 0) - (fillarray shared-key 0))) +(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 - (scram-md5-make-client-msg-2 - sasl-scram-md5-client-security-info - client-proof) - (fillarray client-proof 0)))) - -(defun sasl-scram-md5-authenticate-server (server-msg-1 - server-msg-2 - client-msg-1 - salted-pass) - (string= server-msg-2 - (scram-md5-make-server-msg-2 - server-msg-1 - client-msg-1 - sasl-scram-md5-client-security-info - (car - (scram-md5-parse-server-msg-1 server-msg-1)) - salted-pass))) - -;;; DIGEST-MD5 - -(defvar sasl-digest-md5-nonce-count 1) - -(defun sasl-digest-md5-digest-response (digest-challenge username passwd - serv-type host &optional realm) - (digest-md5-parse-digest-challenge digest-challenge) - (digest-md5-digest-response - username - (or realm (digest-md5-challenge 'realm)) ;; need to check. - passwd - (digest-md5-challenge 'nonce) - (digest-md5-cnonce) - sasl-digest-md5-nonce-count - (digest-md5-digest-uri serv-type host) ;; MX host - )) + (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-match "^Username:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-client-name client)) + +(defun sasl-login-response-2 (client step) +;;; (unless (string-match "^Password:" (sasl-step-data step)) +;;; (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 + '(ignore ;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 \ No newline at end of file +;;; sasl.el ends here diff --git a/sasl.texi b/sasl.texi new file mode 100644 index 0000000..4e538d5 --- /dev/null +++ b/sasl.texi @@ -0,0 +1,264 @@ +\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} + +@ifinfo +This file describes the Emacs SASL library. + +Copyright (C) 2000 Daiki Ueno. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.1 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with no Front-Cover Texts, and with no Back-Cover +Texts. A copy of the license is included in the section entitled "GNU +Free Documentation License". +@end ifinfo + +@tex + +@titlepage +@title Emacs SASL Library + +@author by Daiki Ueno +@page + +@vskip 0pt plus 1filll +Copyright @copyright{} 2000 Daiki Ueno. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.1 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with no Front-Cover Texts, and with no Back-Cover +Texts. A copy of the license is included in the section entitled "GNU +Free Documentation License". +@end titlepage +@page + +@end tex + +@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/smtp.el b/smtp.el index 6be6927..2a979d4 100644 --- a/smtp.el +++ b/smtp.el @@ -5,10 +5,8 @@ ;; Author: Tomoji Kagatani ;; Simon Leinen (ESMTP support) ;; Shuhei KOBAYASHI -;; Kenichi OKADA (SASL support) -;; Daiki Ueno -;; Maintainer: Kenichi OKADA -;; Keywords: SMTP, mail, SASL +;; Daiki Ueno +;; Keywords: SMTP, mail ;; This file is part of FLIM (Faithful Library about Internet Message). @@ -27,410 +25,527 @@ ;; 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 'sasl)) -(eval-and-compile - (autoload 'starttls-open-stream "starttls") - (autoload 'starttls-negotiate "starttls") - (autoload 'sasl-cram-md5 "sasl") - (autoload 'sasl-plain "sasl") - (autoload 'sasl-scram-md5-client-msg-1 "sasl") - (autoload 'sasl-scram-md5-client-msg-2 "sasl") - (autoload 'sasl-scram-md5-authenticate-server "sasl") - (autoload 'sasl-digest-md5-digest-response "sasl")) - -(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-fqdn nil - "*User's fully qualified domain name." + "Fully qualified domain name used for Message-ID." :type '(choice (const nil) string) :group 'smtp) -(defcustom smtp-debug-info nil - "*smtp debug info printout. messages and process buffer." +(defcustom smtp-use-8bitmime t + "If non-nil, use ESMTP 8BITMIME (RFC1652) if available." :type 'boolean - :group 'smtp) + :group 'smtp-extensions) -(defcustom smtp-notify-success nil - "*If non-nil, notification for successful mail delivery is returned - to user (RFC1891)." +(defcustom smtp-use-size t + "If non-nil, use ESMTP SIZE (RFC1870) if available." :type 'boolean - :group 'smtp) + :group 'smtp-extensions) -(defcustom smtp-authenticate-type nil - "*SMTP authentication mechanism (RFC2554)." - :type 'symbol - :group 'smtp) +(defcustom smtp-use-starttls nil + "If non-nil, use STARTTLS (RFC2595) if available." + :type 'boolean + :group 'smtp-extensions) -(defvar smtp-authenticate-user nil) -(defvar smtp-authenticate-passphrase nil) +(defcustom smtp-use-sasl nil + "If non-nil, use SMTP Authentication (RFC2554) if available." + :type 'boolean + :group 'smtp-extensions) -(defvar smtp-authenticate-method-alist - '((cram-md5 smtp-auth-cram-md5) - (plain smtp-auth-plain) - (login smtp-auth-login) - (anonymous smtp-auth-anonymous) - (scram-md5 smtp-auth-scram-md5) - (digest-md5 smtp-auth-digest-md5))) +(defcustom smtp-sasl-user-name (user-login-name) + "Identification to be used for authorization." + :type 'string + :group 'smtp-extensions) -(defcustom smtp-connection-type nil - "*SMTP connection type." - :type '(choice (const nil) (const :tag "TLS" starttls)) - :group 'smtp) +(defcustom smtp-sasl-properties nil + "Properties set to SASL client." + :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 +;;; the current sending package should be guaranteed to be accessible +;;; 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 +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 consider the function `open-network-stream' is a emulation +;;; for another network stream. They are likely to be implemented with an +;;; 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-fqdn - smtp-fqdn) - (smtp-local-domain - (concat system-name "." smtp-local-domain)) - ((string-match "[^.]\\.[^.]" system-name) - system-name) - (t - (error "Cannot generate valid FQDN. Set `smtp-fqdn' or `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 - (if smtp-connection-type - (as-binary-process - (starttls-open-stream - "SMTP" (current-buffer) server smtp-service)) - (open-network-stream-as-binary - "SMTP" (current-buffer) server smtp-service))) - - (set-process-filter process 'smtp-process-filter) - - (if (eq smtp-connection-type 'force) - (starttls-negotiate process)) - - ;; 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))) - extension) - (while extension-lines - (if (string-match - "^auth " - (setq extension - (downcase (substring (car extension-lines) 4)))) - (while (string-match "\\([^ ]+\\)" extension (match-end 1)) - (push (intern (match-string 1 extension)) extensions)) - (push (intern extension) extensions)) - (setq extension-lines (cdr extension-lines))))) - - ;; STARTTLS --- begin a TLS negotiation (RFC 2595) - (when (and smtp-connection-type - (null (eq smtp-connection-type 'force)) - (memq 'starttls extensions)) - (smtp-send-command process "STARTTLS") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (starttls-negotiate process) - ;; for sendmail warning XXX - (smtp-send-command process (format "HELO %s" (smtp-make-fqdn))) - (setq response (smtp-read-response process))) - - ;; AUTH --- SMTP Service Extension for Authentication (RFC2554) - (when smtp-authenticate-type - (let ((auth smtp-authenticate-type) method) - (if (and - (memq auth extensions) - (setq method (nth 1 (assq auth smtp-authenticate-method-alist)))) - (funcall method process) - (throw 'done - (format "AUTH mechanism %s not available" auth))))) - - ;; 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 - (if (memq 'dsn extensions) - "RCPT TO:<%s> NOTIFY=SUCCESS" - (throw 'done - (format "Delivery Status Notifications is not available"))) - "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 - (memq (process-status process) '(open run))) - (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) + (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-properties + (sasl-client-set-properties client smtp-sasl-properties)) + (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)))) + (beginning-of-line 2))) + (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))) -(defun smtp-read-response (process) - (let ((case-fold-search nil) - (response-strings nil) - (response-continue t) - (return-value '(nil ())) - match-end) +(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 ((response-continue t) + 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 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) + (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"))) - (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)) - -(defun smtp-send-command (process command &optional secure) - (goto-char (point-max)) - (if secure - (insert "Here is insecure words.\r\n") - (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)) +(defun smtp-send-data (process data) ;; 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 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-deduce-address-list (smtp-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO:

." (let ((simple-address-list "") @@ -492,216 +607,6 @@ don't define this value." recipient-address-list)) (kill-buffer smtp-address-buffer)))) -(defun smtp-auth-cram-md5 (process) - (let ((secure-word (copy-sequence smtp-authenticate-passphrase)) - response) - (smtp-send-command process "AUTH CRAM-MD5") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (smtp-send-command - process - (setq secure-word (unwind-protect - (sasl-cram-md5 - smtp-authenticate-user secure-word - (base64-decode-string - (substring (car (cdr response)) 4))) - (fillarray secure-word 0)) - secure-word (unwind-protect - (base64-encode-string secure-word) - (fillarray secure-word 0))) t) - (fillarray secure-word 0) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - -(defun smtp-auth-plain (process) - (let ((secure-word (copy-sequence smtp-authenticate-passphrase)) - response) - (smtp-send-command - process - (setq secure-word (unwind-protect - (sasl-plain "" smtp-authenticate-user secure-word) - (fillarray secure-word 0)) - secure-word (unwind-protect - (base64-encode-string secure-word) - (fillarray secure-word 0)) - secure-word (unwind-protect - (concat "AUTH PLAIN " secure-word) - (fillarray secure-word 0))) t) - (fillarray secure-word 0) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - -(defun smtp-auth-login (process) - (let ((secure-word (copy-sequence smtp-authenticate-passphrase)) - response) - (smtp-send-command process "AUTH LOGIN") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (smtp-send-command - process - (base64-encode-string - smtp-authenticate-user)) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (smtp-send-command - process - (setq secure-word (unwind-protect - (base64-encode-string secure-word) - (fillarray secure-word 0))) t) - (fillarray secure-word 0) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - -(defun smtp-auth-anonymous (process &optional token) - (let (response) - (smtp-send-command - process "AUTH ANONYMOUS") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (smtp-send-command process - (base64-encode-string - (or token - user-mail-address - ""))) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))))) - -(defun smtp-auth-scram-md5 (process) - ;; now tesing - (let (server-msg-1 server-msg-2 client-msg-1 salted-pass - response secure-word) - (smtp-send-command process "AUTH SCRAM-MD5") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (unwind-protect - (smtp-send-command - process - (setq secure-word - (base64-encode-string - (setq client-msg-1 - (sasl-scram-md5-client-msg-1 - smtp-authenticate-user)))) t) - (fillarray secure-word 0)) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (progn - (fillarray client-msg-1 0) - (throw 'done (car (cdr response))))) - (setq secure-word - (unwind-protect - (substring (car (cdr response)) 4) - (fillarray (car (cdr response)) 0))) - (setq server-msg-1 - (unwind-protect - (base64-decode-string secure-word) - (fillarray secure-word 0))) - (setq secure-word - (sasl-scram-md5-client-msg-2 - server-msg-1 client-msg-1 - (setq salted-pass - (sasl-scram-md5-make-salted-pass - smtp-authenticate-passphrase server-msg-1)))) - (setq secure-word - (unwind-protect - (base64-encode-string secure-word) - (fillarray secure-word 0))) - (unwind-protect - (smtp-send-command process secure-word t) - (fillarray secure-word 0)) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (progn - (fillarray salted-pass 0) - (fillarray server-msg-1 0) - (fillarray client-msg-1 0) - (throw 'done (car (cdr response))))) - (setq server-msg-2 - (unwind-protect - (base64-decode-string - (setq secure-word - (substring (car (cdr response)) 4))) - (fillarray secure-word 0))) - (if (null - (unwind-protect - (sasl-scram-md5-authenticate-server - server-msg-1 - server-msg-2 - client-msg-1 - salted-pass) - (fillarray salted-pass 0) - (fillarray server-msg-1 0) - (fillarray server-msg-2 0) - (fillarray client-msg-1 0))) - (throw 'done nil)) - (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)))) )) - -(defun smtp-auth-digest-md5 (process) - "Login to server using the AUTH DIGEST-MD5 method." - (let (user realm response) - (smtp-send-command process "AUTH DIGEST-MD5") - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (if (string-match "^\\([^@]*\\)@\\([^@]*\\)" - smtp-authenticate-user) - (setq user (match-string 1 smtp-authenticate-user) - realm (match-string 2 smtp-authenticate-user)) - (setq user smtp-authenticate-user - realm nil)) - (smtp-send-command process - (base64-encode-string - (sasl-digest-md5-digest-response - (base64-decode-string - (substring (car (cdr response)) 4)) - user - smtp-authenticate-passphrase - "smtp" smtp-server realm) - 'no-line-break) t) - (setq response (smtp-read-response process)) - (if (or (null (car response)) - (not (integerp (car response))) - (>= (car response) 400)) - (throw 'done (car (cdr response)))) - (smtp-send-command process ""))) - (provide 'smtp) ;;; smtp.el ends here diff --git a/starttls.el b/starttls.el deleted file mode 100644 index bb2f04f..0000000 --- a/starttls.el +++ /dev/null @@ -1,84 +0,0 @@ -;;; starttls.el --- TLSv1 functions - -;; Copyright (C) 1999 Daiki Ueno - -;; Author: Daiki Ueno -;; Created: 1999/11/20 -;; Keywords: TLS, SSL, OpenSSL - -;; 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 GNU Emacs; 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 defines some utility functions for TLSv1 functions. - -;; [RFC 2246] "The TLS Protocol Version 1.0" -;; by Christopher Allen and -;; Tim Dierks (1999/01) - -;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" -;; by Chris Newman (1999/06) - -;;; Code: - -(defgroup starttls nil - "Support for `Transport Layer Security' protocol." - :group 'ssl) - -(defcustom starttls-program "starttls" - "The program to run in a subprocess to open an TLSv1 connection." - :group 'starttls) - -(defcustom starttls-extra-args nil - "Extra arguments to `starttls-program'" - :group 'starttls) - -(defun starttls-negotiate (process) - (signal-process (process-id process) 'SIGALRM)) - -(defun starttls-open-stream (name buffer host service) - "Open a TLS connection for a service to a host. -Returns a subprocess-object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST SERVICE. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or `buffer-name') to associate with the process. - Process output goes at end of that buffer, unless you specify - an output stream or filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg SERVICE is name of the service desired, or an integer -specifying a port number to connect to." - - (let* ((process-connection-type nil) - (process (apply #'start-process - name buffer starttls-program - host (format "%s" service) - starttls-extra-args))) - (process-kill-without-query process) - process)) - -(defun starttls-open-ssl-stream (name buffer host service) - (let* ((starttls-extra-args - (cons "--force" starttls-extra-args))) - (starttls-open-stream name buffer host service))) - -(provide 'starttls) - -;;; starttls.el ends here