hmac-md5.el (hmac-md5): Specify the 4th arg to `md5' as `binary'

[elisp/flim.git] / smtp.el

diff --git a/smtp.el b/smtp.el
index c2c9937..79e4620 100644 (file)
--- a/smtp.el
+++ b/smtp.el
@@ -1,10 +1,11 @@
 ;;; smtp.el --- basic functions to send mail with SMTP server
 
-;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
 
 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
 ;;         Simon Leinen <simon@switch.ch> (ESMTP support)
-;;         Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;;         Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;;         Kenichi OKADA <okada@opaopa.org> (SASL support)
 ;; Keywords: SMTP, mail
 
 ;; This file is part of FLIM (Faithful Library about Internet Message).
@@ -20,13 +21,19 @@
 ;; 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
+;; 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.
 
 ;;; Code:
 
-(require 'mail-utils) ; pick up mail-strip-quoted-names
+(require 'poe)
+(require 'poem)
+(require 'pcustom)
+(require 'mail-utils)                  ; mail-strip-quoted-names
+(require 'sasl)
+
+(eval-when-compile (require 'cl))      ; push
 
 (defgroup smtp nil
   "SMTP protocol for sending mail."
@@ -62,7 +69,17 @@ don't define this value."
   :type '(choice (const nil) string)
   :group 'smtp)
 
-(defvar smtp-debug-info nil)
+(defcustom smtp-debug-info nil
+  "*smtp debug info printout. messages and process buffer."
+  :type 'boolean
+  :group 'smtp)
+
+(defcustom smtp-notify-success nil
+  "*If non-nil, notification for successful mail delivery is returned 
+ to user (RFC1891)."
+  :type 'boolean
+  :group 'smtp)
+ 
 (defvar smtp-read-point nil)
 
 (defun smtp-make-fqdn ()
@@ -76,7 +93,8 @@ don't define this value."
      (t
       (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
 
-(defun smtp-via-smtp (sender recipients smtp-text-buffer)
+(defun smtp-via-smtp (sender recipients smtp-text-buffer
+                            &optional auth user passphrase)
   (let ((server (if (functionp smtp-server)
                    (funcall smtp-server sender recipients)
                  smtp-server))
@@ -120,12 +138,77 @@ don't define this value."
                          (not (integerp (car response)))
                          (>= (car response) 400))
                      (throw 'done (car (cdr response)))))
-             (let ((extension-lines (cdr (cdr response))))
+             (let ((extension-lines (cdr (cdr response)))
+                   extension)
                (while extension-lines
-                 (push (intern (downcase (substring (car extension-lines) 4)))
-                       extensions)
+                 (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)))))
 
+           ;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
+           (when auth
+             (if (null (memq (intern auth) extensions))
+                 (throw 'done 
+                        (concat "AUTH mechanism " auth " not available")))
+             
+             (cond ((string= "cram-md5" auth)
+                    (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
+                     (base64-encode-string
+                      (cram-md5-encode
+                       user passphrase 
+                       (base64-decode-string
+                        (substring (car (cdr response)) 4)))))
+                    (setq response (smtp-read-response process))
+                    (if (or (null (car response))
+                            (not (integerp (car response)))
+                            (>= (car response) 400))
+                        (throw 'done (car (cdr response)))))
+
+                   ((string= "plain" auth)
+                    (smtp-send-command
+                     process
+                     (concat "AUTH PLAIN "
+                             (base64-encode-string
+                              (plain-encode "" user passphrase))))
+                    (setq response (smtp-read-response process))
+                    (if (or (null (car response))
+                            (not (integerp (car response)))
+                            (>= (car response) 400))
+                        (throw 'done (car (cdr response)))))
+
+                   ((string= "login" auth)
+                    (smtp-send-command
+                     process
+                     (concat "AUTH LOGIN " 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
+                     (base64-encode-string passphrase))
+                    (setq response (smtp-read-response process))
+                    (if (or (null (car response))
+                            (not (integerp (car response)))
+                            (>= (car response) 400))
+                        (throw 'done (car (cdr response)))))
+
+                   (t
+                    (throw 'done (concat "AUTH " auth " not supported")))))
+
            ;; ONEX --- One message transaction only (sendmail extension?)
            (if (or (memq 'onex extensions)
                    (memq 'xone extensions))
@@ -193,7 +276,11 @@ don't define this value."
            ;; RCPT TO:<recipient>
            (while recipients
              (smtp-send-command process
-                                (format "RCPT TO:<%s>" (car recipients)))
+                                (format
+                                 (if smtp-notify-success
+                                     "RCPT TO:<%s> NOTIFY=SUCCESS" 
+                                   "RCPT TO:<%s>")
+                                 (car recipients)))
              (setq recipients (cdr recipients))
              (setq response (smtp-read-response process))
              (if (or (null (car response))