This commit was manufactured by cvs2svn to create branch 'slim-1_14'.

[elisp/flim.git] / smtp.el

diff --git a/smtp.el b/smtp.el
index 8597e67..e80a68d 100644 (file)
--- a/smtp.el
+++ b/smtp.el
@@ -34,11 +34,16 @@
 (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-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
 
@@ -87,27 +92,27 @@ don't define this value."
   :type 'boolean
   :group 'smtp)
 
-(defcustom smtp-authentication-type nil
+(defcustom smtp-authenticate-type nil
   "*SMTP authentication mechanism (RFC2554)."
   :type 'symbol
   :group 'smtp)
 
-(defvar smtp-authentication-user nil)
-(defvar smtp-authentication-passphrase nil)
+(defvar smtp-authenticate-user nil)
+(defvar smtp-authenticate-passphrase nil)
 
-(defvar smtp-authentication-method-alist
+(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-connection-type nil
   "*SMTP connection type."
   :type '(choice (const nil) (const :tag "TLS" starttls))
   :group 'smtp)
- 
+
 (defvar smtp-read-point nil)
 
 (defun smtp-make-fqdn ()
@@ -197,13 +202,13 @@ don't define this value."
              (starttls-negotiate process))
 
            ;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
-           (when smtp-authentication-type
-             (let ((auth (intern smtp-authentication-type)) method)
+           (when smtp-authenticate-type
+             (let ((auth smtp-authenticate-type) method)
                (if (and 
                     (memq auth extensions)
-                    (setq method (nth 1 (assq auth smtp-authentication-method-alist))))
+                    (setq method (nth 1 (assq auth smtp-authenticate-method-alist))))
                    (funcall method process)
-                 (throw 'smtp-error
+                 (throw 'done
                         (format "AUTH mechanism %s not available" auth)))))
 
            ;; ONEX --- One message transaction only (sendmail extension?)
@@ -307,7 +312,7 @@ don't define this value."
            t)
 
        (if (and process
-                (eq (process-status process) 'open))
+                (memq (process-status process) '(open run)))
        (progn
          ;; QUIT
          (smtp-send-command process "QUIT")
@@ -475,7 +480,7 @@ don't define this value."
       (kill-buffer smtp-address-buffer))))
 
 (defun smtp-auth-cram-md5 (process)
-  (let ((secure-word (copy-sequence smtp-authentication-passphrase))
+  (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
        response)
     (smtp-send-command process "AUTH CRAM-MD5")
     (setq response (smtp-read-response process))
@@ -487,7 +492,7 @@ don't define this value."
      process
      (setq secure-word (unwind-protect
                           (sasl-cram-md5
-                           smtp-authentication-user secure-word
+                           smtp-authenticate-user secure-word
                            (base64-decode-string
                             (substring (car (cdr response)) 4)))
                         (fillarray secure-word 0))
@@ -502,12 +507,12 @@ don't define this value."
        (throw 'done (car (cdr response))))))
  
 (defun smtp-auth-plain (process)
-  (let ((secure-word (copy-sequence smtp-authentication-passphrase))
+  (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
        response)
     (smtp-send-command
      process
      (setq secure-word (unwind-protect
-                          (sasl-plain "" smtp-authentication-user secure-word)
+                          (sasl-plain "" smtp-authenticate-user secure-word)
                         (fillarray secure-word 0))
           secure-word (unwind-protect
                           (base64-encode-string secure-word)
@@ -523,11 +528,18 @@ don't define this value."
        (throw 'done (car (cdr response))))))
 
 (defun smtp-auth-login (process)
-  (let ((secure-word (copy-sequence smtp-authentication-passphrase))
+  (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
-     (concat "AUTH LOGIN " smtp-authentication-user))
+     (base64-encode-string
+      smtp-authenticate-user))
     (setq response (smtp-read-response process))
     (if (or (null (car response))
            (not (integerp (car response)))
@@ -582,7 +594,7 @@ don't define this value."
               (base64-encode-string
                (setq client-msg-1
                      (sasl-scram-md5-client-msg-1 
-                      smtp-authentication-user)))) t)
+                      smtp-authenticate-user)))) t)
       (fillarray secure-word 0))
     (setq response (smtp-read-response process))
     (if (or (null (car response))
@@ -603,10 +615,8 @@ don't define this value."
          (sasl-scram-md5-client-msg-2
           server-msg-1 client-msg-1 
           (setq salted-pass
-                (scram-md5-make-salted-pass
-                 smtp-authentication-passphrase
-                 (car
-                  (scram-md5-parse-server-msg-1 server-msg-1))))))
+                (sasl-scram-md5-make-salted-pass
+                 smtp-authenticate-passphrase server-msg-1))))
     (setq secure-word
          (unwind-protect
              (base64-encode-string secure-word)
@@ -647,6 +657,37 @@ don't define this value."
            (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)