From: ueno Date: Wed, 1 Nov 2000 14:56:20 +0000 (+0000) Subject: * smtp.el: Bind `sasl-mechanisms'; add autoload settings for X-Git-Tag: deisui-1_14_0-1~24 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c19f8a29243b84b8a0ce3bf41d9d63fcd74a2f55;p=elisp%2Fflim.git * 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'. --- diff --git a/ChangeLog b/ChangeLog index f890625..5658c9d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,27 @@ 2000-11-01 Daiki Ueno + * smtp.el: Bind `sasl-mechanisms'; add autoload settings for + `sasl-make-principal', `sasl-find-authenticator', + `sasl-authenticator-mechanism-internal' and + `sasl-evaluate-challenge'. + (smtp-use-sasl): New user option. + (smtp-sasl-principal-name): New user option. + (smtp-sasl-mechanisms): New user option. + (smtp-submit-package): Call `smtp-primitive-starttls' and + `smtp-primitive-auth'. + (smtp-primitive-ehlo): Don't modify the rest of a extension line. + (smtp-primitive-auth): New function. + (smtp-primitive-starttls): Check the response code. + + * sasl.el: New implementation. + + * sasl-cram.el: New file. + + * FLIM-ELS (flim-modules): Add `md5', `md5-el', `md5-dl', + `hex-util', `hmac-def', `hmac-md5', `sasl' and `sasl-cram'. + +2000-11-01 Daiki Ueno + * smtp.el: Add autoload settings for `starttls-open-stream' and `starttls-negotiate'. (smtp-connection-set-extensions-internal): New macro. diff --git a/FLIM-ELS b/FLIM-ELS index 8f1a90b..0095e6c 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -11,7 +11,9 @@ 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))) diff --git a/sasl-cram.el b/sasl-cram.el new file mode 100644 index 0000000..233b05a --- /dev/null +++ b/sasl-cram.el @@ -0,0 +1,54 @@ +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Daiki Ueno + +;; Author: Kenichi OKADA +;; Daiki Ueno +;; Keywords: SASL, CRAM-MD5 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(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 diff --git a/sasl.el b/sasl.el new file mode 100644 index 0000000..94e133d --- /dev/null +++ b/sasl.el @@ -0,0 +1,91 @@ +;;; sasl.el --- SASL client framework + +;; Copyright (C) 2000 Daiki Ueno + +;; Author: Daiki Ueno +;; Keywords: SASL + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +(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 diff --git a/smtp.el b/smtp.el index 136e030..0162538 100644 --- a/smtp.el +++ b/smtp.el @@ -84,6 +84,23 @@ don't define this value." :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) @@ -239,6 +256,10 @@ or `smtp-local-domain' correctly.")))))) (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)) @@ -272,10 +293,12 @@ or `smtp-local-domain' correctly.")))))) (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) @@ -289,6 +312,55 @@ or `smtp-local-domain' correctly.")))))) (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))) @@ -298,6 +370,8 @@ or `smtp-local-domain' correctly.")))))) ;; 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)