2000-11-01 Daiki Ueno <ueno@unixuser.org>
+ * smtp.el: Bind `sasl-mechanisms'; add autoload settings for
+ `sasl-make-principal', `sasl-find-authenticator',
+ `sasl-authenticator-mechanism-internal' and
+ `sasl-evaluate-challenge'.
+ (smtp-use-sasl): New user option.
+ (smtp-sasl-principal-name): New user option.
+ (smtp-sasl-mechanisms): New user option.
+ (smtp-submit-package): Call `smtp-primitive-starttls' and
+ `smtp-primitive-auth'.
+ (smtp-primitive-ehlo): Don't modify the rest of a extension line.
+ (smtp-primitive-auth): New function.
+ (smtp-primitive-starttls): Check the response code.
+
+ * sasl.el: New implementation.
+
+ * sasl-cram.el: New file.
+
+ * FLIM-ELS (flim-modules): Add `md5', `md5-el', `md5-dl',
+ `hex-util', `hmac-def', `hmac-md5', `sasl' and `sasl-cram'.
+
+2000-11-01 Daiki Ueno <ueno@unixuser.org>
+
* smtp.el: Add autoload settings for `starttls-open-stream' and
`starttls-negotiate'.
(smtp-connection-set-extensions-internal): New macro.
mime mime-parse mmgeneric
mmbuffer mmcooked mmdbuffer mmexternal
mailcap
- closure tram smtp qmtp smtpmail))
+ md5 md5-el md5-dl hex-util hmac-def hmac-md5
+ sasl sasl-cram
+ smtp qmtp smtpmail))
(if (and (fboundp 'base64-encode-string)
(subrp (symbol-function 'base64-encode-string)))
--- /dev/null
+;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Daiki Ueno
+
+;; Author: Kenichi OKADA <okada@opaopa.org>
+;; Daiki Ueno <ueno@unixuser.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)
+
+(defvar sasl-cram-md5-authenticator nil)
+
+(defconst sasl-cram-md5-continuations
+ '(ignore ;no initial response
+ sasl-cram-md5-response))
+
+(unless (get 'sasl-cram 'sasl-authenticator)
+ (put 'sasl-cram 'sasl-authenticator
+ (sasl-make-authenticator "CRAM-MD5" sasl-cram-md5-continuations)))
+
+(defun sasl-cram-md5-response (principal challenge)
+ (let ((passphrase
+ (sasl-read-passphrase
+ (format "CRAM-MD5 passphrase for %s: "
+ (sasl-principal-name-internal principal)))))
+ (unwind-protect
+ (concat (sasl-principal-name-internal principal) " "
+ (encode-hex-string
+ (hmac-md5 (nth 1 challenge) passphrase)))
+ (fillarray passphrase 0))))
+
+(provide 'sasl-cram)
+
+;;; sasl-cram.el ends here
--- /dev/null
+;;; sasl.el --- SASL client framework
+
+;; Copyright (C) 2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: SASL
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+(require 'poe)
+
+(defvar sasl-mechanisms
+ '(("CRAM-MD5" sasl-cram)))
+
+(defmacro sasl-make-authenticator (mechanism continuations)
+ `(vector ,mechanism ,continuations))
+
+(defmacro sasl-authenticator-mechanism-internal (authenticator)
+ `(aref ,authenticator 0))
+
+(defmacro sasl-authenticator-continuations-internal (authenticator)
+ `(aref ,authenticator 1))
+
+(defmacro sasl-make-principal (name service server)
+ `(vector ,name ,service ,server))
+
+(defmacro sasl-principal-name-internal (principal)
+ `(aref ,principal 0))
+
+(defmacro sasl-principal-service-internal (principal)
+ `(aref ,principal 1))
+
+(defmacro sasl-principal-server-internal (principal)
+ `(aref ,principal 2))
+
+(defun sasl-find-authenticator (mechanisms)
+ "Retrieve an apropriate authenticator object from MECHANISMS hints."
+ (let (mechanism)
+ (while mechanisms
+ (if (setq mechanism (assoc (car mechanisms) sasl-mechanisms))
+ (setq mechanism (nth 1 mechanism)
+ mechanisms nil))
+ (setq mechanisms (cdr mechanisms)))
+ (when mechanism
+ (require mechanism)
+ (get mechanism 'sasl-authenticator))))
+
+(defun sasl-evaluate-challenge (authenticator principal &optional challenge)
+ "Evaluate the challenge and prepare an appropriate next response.
+The data type of the value and the CHALLENGE is nil or a cons cell of the form
+\(CONTINUATION STRING). At the first time CONTINUATION should be set to nil."
+ (let* ((continuations
+ (sasl-authenticator-continuations-internal authenticator))
+ (function
+ (if (car challenge)
+ (nth 1 (memq (car challenge) continuations))
+ (car continuations))))
+ (if function
+ (list function (funcall function principal challenge)))))
+
+(defvar sasl-read-passphrase nil)
+(defun sasl-read-passphrase (prompt &optional key)
+ (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))
+
+(provide 'sasl)
+
+;;; sasl.el ends here
:type 'boolean
:group 'smtp-extensions)
+(defcustom smtp-use-sasl nil
+ "If non-nil, use SMTP Authentication (RFC2554) if available."
+ :type 'boolean
+ :group 'smtp-extensions)
+
+(defcustom smtp-sasl-principal-name (user-login-name)
+ "Identification to be used for authorization."
+ :type 'string
+ :group 'smtp-extensions)
+
+(defcustom smtp-sasl-mechanisms nil
+ "List of authentication mechanisms."
+ :type '(repeat string)
+ :group 'smtp-extensions)
+
+(defvar sasl-mechanisms)
+
(defvar smtp-open-connection-function #'open-network-stream)
(defvar smtp-read-point nil)
(progn
(smtp-primitive-greeting package)
(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))
(smtp-connection-set-extensions-internal
connection (mapcar
(lambda (extension)
- (mapcar
- (lambda (parameter)
- (car (read-from-string (downcase parameter))))
- (split-string extension)))
+ (let ((extensions
+ (split-string extension)))
+ (setcar extensions
+ (car (read-from-string
+ (downcase (car extensions)))))
+ extensions))
(cdr response)))))
(defun smtp-primitive-helo (package)
(if (/= (car response) 250)
(smtp-response-error response))))
+(eval-and-compile
+ (autoload 'sasl-make-principal "sasl")
+ (autoload 'sasl-find-authenticator "sasl")
+ (autoload 'sasl-authenticator-mechanism-internal "sasl")
+ (autoload 'sasl-evaluate-challenge "sasl"))
+
+(defun smtp-primitive-auth (package)
+ (let* ((connection
+ (smtp-find-connection (current-buffer)))
+ (process
+ (smtp-connection-process-internal connection))
+ (mechanisms
+ (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
+ (principal
+ (sasl-make-principal
+ smtp-sasl-principal-name "smtp"
+ (smtp-connection-server-internal connection)))
+ (authenticator
+ (sasl-find-authenticator mechanisms))
+ (mechanism
+ (sasl-authenticator-mechanism-internal authenticator))
+ ;; Retrieve the initial response
+ (sasl-response
+ (sasl-evaluate-challenge authenticator principal))
+ sasl-challenge
+ response)
+ (smtp-send-command
+ process
+ (if (nth 1 sasl-response)
+ (format "AUTH %s %s" mechanism (base64-encode-string (nth 1 sasl-response)))
+ (format "AUTH %s" mechanism)))
+ (catch 'done
+ (while t
+ (setq response (smtp-read-response process))
+ (when (= (car response) 235)
+ ;; The authentication process is finished.
+ (setq sasl-response
+ (sasl-evaluate-challenge authenticator principal sasl-response))
+ (if (null sasl-response)
+ (throw 'done nil))
+ (smtp-response-error response)) ;Bogus server?
+ (if (/= (car response) 334)
+ (smtp-response-error response))
+ (setcar (cdr sasl-response) (base64-decode-string (nth 1 response)))
+ (setq sasl-response
+ (sasl-evaluate-challenge
+ authenticator principal sasl-response))
+ (smtp-send-command process (base64-encode-string sasl-response))))))
+
(defun smtp-primitive-starttls (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
;; 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)
projects / elisp / flim.git / commitdiff