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-11-20 Kenichi OKADA <okada@opaopa.org>
+
+ * 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.
+
+\f
2000-10-20 Kenichi OKADA <okada@opaopa.org>
* SLIM: Version 1.14.3 released.
1999-03-01 MORIOKA Tomohiko <morioka@jaist.ac.jp>
* 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 <morioka@jaist.ac.jp>
1998-08-28 MORIOKA Tomohiko <morioka@jaist.ac.jp>
* 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 <shuhei-k@jaist.ac.jp>
* 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 <shuhei-k@jaist.ac.jp>
* FLIM: Version 1.2.0 (J\e-D\ e~\ fj\ er\ f) 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 <morioka@jaist.ac.jp>
* FLIM: Version 1.0.1 (Ky\e-D\ er\ fto) was released.
* mime-def.el (mime-spadework-module-version-string): New
- constant.
+ constant.
* eword-encode.el: Abolish constant 'eword-encode-version.
* 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).
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)))
PACKAGE = slim
API = 1.14
-RELEASE = 1
+RELEASE = 3
TAR = tar
RM = /bin/rm -f
+++ /dev/null
-;;; digest-md5.el --- Compute DIGEST-MD5.
-
-;; Copyright (C) 1999 Kenichi OKADA
-
-;; Author: Kenichi OKADA <okada@opaopa.org>
-;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
-;; 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
;;; 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 <tomo@m17n.org>
;; Keywords: OOP
(defconst :after ':after)
(defconst :around ':around)))
+
+;;; @ class
+;;;
+
(defmacro luna-find-class (name)
"Return the luna-class of the given NAME."
`(get ,name 'luna-class))
(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.
(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))
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.
(apply #'luna-send v 'initialize-instance v init-args)
))
+
+;;; @ interface (generic function)
+;;;
+
(defsubst luna-arglist-to-arguments (arglist)
(let (dest)
(while arglist
(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))
)))
(luna-class-obarray entity-class))))
+
+;;; @ standard object
+;;;
+
(luna-define-class-function 'standard-object)
(luna-define-method initialize-instance ((entity standard-object)
\e$B$3$N>l9g!"\e(BUNIX \e$B$N\e(B /etc/passwd \e$BMM<0$G0E9f2=$5$l$?%Q%9%o!<%I$rAw$C$F2<$5$$!#\e(B
\e$B$3$N>l9g\e(B cvsroot \e$B$O\e(B :pserver:<\e$B%"%+%&%s%HL>\e(B>@cvs.m17n.org:/cvs/root \e$B$H$J$j$^$9!#\e(B
-
<h2> History of FLIM
<node> History
<p>
;; (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)
--- /dev/null
+;;; qmtp.el --- basic functions to send mail with QMTP server
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; 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
--- /dev/null
+;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Kenichi OKADA <okada@opaopa.org>
+;; 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
--- /dev/null
+;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Kenichi OKADA <okada@opaopa.org>
+;; 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
-;;; 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 <okada@opaopa.org>
-;; Keywords: SMTP, SASL, RFC2222
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: SASL
;; This file is part of FLIM (Faithful Library about Internet Message).
;;; 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
--- /dev/null
+\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:
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
;; Simon Leinen <simon@switch.ch> (ESMTP support)
;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Kenichi OKADA <okada@opaopa.org> (SASL support)
-;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
-;; Maintainer: Kenichi OKADA <okada@opaopa.org>
-;; Keywords: SMTP, mail, SASL
+;; Daiki Ueno <ueno@unixuser.org>
+;; Keywords: SMTP, mail
;; This file is part of FLIM (Faithful Library about Internet Message).
;; 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:<sender>
- (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:<recipient>
- (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:<address>."
(let ((simple-address-list "")
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
+++ /dev/null
-;;; starttls.el --- TLSv1 functions
-
-;; Copyright (C) 1999 Daiki Ueno
-
-;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
-;; 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 <callen@certicom.com> and
-;; Tim Dierks <tdierks@certicom.com> (1999/01)
-
-;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
-;; by Chris Newman <chris.newman@innosoft.com> (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
projects / elisp / flim.git / commitdiff