* FLIM-ELS (flim-modules): Add `unique-id'.

[elisp/flim.git] / smtp.el

diff --git a/smtp.el b/smtp.el
index 9089d49..9d0bd64 100644 (file)
--- a/smtp.el
+++ b/smtp.el
@@ -38,7 +38,10 @@
   (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"))
                       
 (eval-when-compile (require 'cl))      ; push
 
@@ -100,6 +103,7 @@ don't define this value."
     (plain smtp-auth-plain)
     (login smtp-auth-login)
     (anonymous smtp-auth-anonymous)
+    (scram-md5 smtp-auth-scram-md5)
     ))
 
 (defcustom smtp-connection-type nil
@@ -564,6 +568,89 @@ don't define this value."
            (>= (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-authentication-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
+                (scram-md5-make-salted-pass
+                 smtp-authentication-passphrase
+                 (car
+                  (scram-md5-parse-server-msg-1 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)))) ))
+    
 (provide 'smtp)
 
 ;;; smtp.el ends here