Revision: mange@freemail.hu--2005/emacs-jabber--cvs-head--0--patch-450

Creator:  Magnus Henoch <mange@freemail.hu>

Only cache password on successful authentication

4 files changed, 61 insertions, 51 deletions

diff --git a/jabber-core.el b/jabber-core.el
index 8ff55d8..f18e569 100644
--- a/jabber-core.el
+++ b/jabber-core.el
@@ -497,9 +497,11 @@ With double prefix argument, specify more connection details."
 	(list :legacy-auth state-data))))
 
     (:authentication-success
+     (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
      (list :session-established state-data))
 
     (:authentication-failure
+     (jabber-uncache-password (jabber-connection-bare-jid fsm))
      ;; jabber-logon has already displayed a message
      (list nil (plist-put state-data
 			  :disconnection-expected t)))
@@ -543,9 +545,11 @@ With double prefix argument, specify more connection details."
      (list :legacy-auth (plist-put state-data :sasl-data nil)))
 
     (:authentication-success
+     (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
      (list :bind (plist-put state-data :sasl-data nil)))
 
     (:authentication-failure
+     (jabber-uncache-password (jabber-connection-bare-jid fsm))
      ;; jabber-sasl has already displayed a message
      (list nil (plist-put state-data
 			  :disconnection-expected t)))
diff --git a/jabber-logon.el b/jabber-logon.el
index b526ebd..62bc6ea 100644
--- a/jabber-logon.el
+++ b/jabber-logon.el
@@ -37,49 +37,43 @@
 
 (defun jabber-do-logon (jc xml-data session-id)
   "send username and password in logon attempt"
-  (let (auth)
-    (if (jabber-xml-get-children (jabber-iq-query xml-data) 'digest)
-	;; SHA1 digest passwords allowed
-	(let ((passwd (or (plist-get (fsm-get-state-data jc) :password)
-			  (jabber-read-password (jabber-connection-bare-jid jc)))))
-	  (if passwd
-	      (setq auth `(digest () ,(sha1 (concat session-id passwd))))))
-      ;; Plaintext passwords - allow on encrypted connections
-      (if (or (plist-get (fsm-get-state-data jc) :encrypted)
-	      (yes-or-no-p "Jabber server only allows cleartext password transmission!  Continue? "))
-	  (let ((passwd (or (plist-get (fsm-get-state-data jc) :password)
-			    (jabber-read-password (jabber-connection-bare-jid jc)))))
-	    (when passwd
-	      (setq auth `(password () ,passwd))))))
-      
-    ;; If auth is still nil, user cancelled process somewhere
-    (if auth
-	(progn
-	  ;; For legacy authentication we must specify a resource.
-	  (unless (plist-get (fsm-get-state-data jc) :resource)
-	    ;; Yes, this is ugly.  Where is my encapsulation?
-	    (plist-put (fsm-get-state-data jc) :resource "emacs-jabber"))
+  (let* ((digest-allowed (jabber-xml-get-children (jabber-iq-query xml-data) 'digest))
+	 (passwd (when
+		     (or digest-allowed
+			 (plist-get (fsm-get-state-data jc) :encrypted)
+			 (yes-or-no-p "Jabber server only allows cleartext password transmission!  Continue? "))
+		   (or (plist-get (fsm-get-state-data jc) :password)
+		       (jabber-read-password (jabber-connection-bare-jid jc)))))
+	 auth)
+    (if (null passwd)
+	(fsm-send jc :authentication-failure)
+      (if digest-allowed
+	  (setq auth `(digest () ,(sha1 (concat session-id passwd))))
+	(setq auth `(password () ,passwd)))
 
-	  (jabber-send-iq jc (plist-get (fsm-get-state-data jc) :server)
-			  "set"
-			  `(query ((xmlns . "jabber:iq:auth"))
-				  (username () ,(plist-get (fsm-get-state-data jc) :username))
-				  ,auth
-				  (resource () ,(plist-get (fsm-get-state-data jc) :resource)))
-			  #'jabber-process-logon t
-			  #'jabber-process-logon nil))
-      (fsm-send jc :authentication-failure))))
+      ;; For legacy authentication we must specify a resource.
+      (unless (plist-get (fsm-get-state-data jc) :resource)
+	;; Yes, this is ugly.  Where is my encapsulation?
+	(plist-put (fsm-get-state-data jc) :resource "emacs-jabber"))
+
+      (jabber-send-iq jc (plist-get (fsm-get-state-data jc) :server)
+		      "set"
+		      `(query ((xmlns . "jabber:iq:auth"))
+			      (username () ,(plist-get (fsm-get-state-data jc) :username))
+			      ,auth
+			      (resource () ,(plist-get (fsm-get-state-data jc) :resource)))
+		      #'jabber-process-logon passwd
+		      #'jabber-process-logon nil))))
 
 (defun jabber-process-logon (jc xml-data closure-data)
   "receive login success or failure, and request roster.
-CLOSURE-DATA should be t on success and nil on failure."
+CLOSURE-DATA should be the password on success and nil on failure."
   (if closure-data
       ;; Logon success
-	(fsm-send jc :authentication-success)
+      (fsm-send jc (cons :authentication-success closure-data))
 
     ;; Logon failure
     (jabber-report-success jc xml-data "Logon")
-    (jabber-uncache-password (jabber-connection-bare-jid jc))
     (fsm-send jc :authentication-failure)))
 
 (provide 'jabber-logon)
diff --git a/jabber-sasl.el b/jabber-sasl.el
index c03b774..fbcbe7c 100644
--- a/jabber-sasl.el
+++ b/jabber-sasl.el
@@ -1,6 +1,6 @@
 ;; jabber-sasl.el - SASL authentication
 
-;; Copyright (C) 2004, 2007 - Magnus Henoch - mange@freemail.hu
+;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
 
 ;; This file is a part of jabber.el.
 
@@ -67,11 +67,14 @@
 	  (fsm-send jc :authentication-failure)
 
 	;; Start authentication.
-	(let* ((client (sasl-make-client mechanism 
+	(let* (passphrase
+	       (client (sasl-make-client mechanism 
 					 (plist-get (fsm-get-state-data jc) :username)
 					 "xmpp"
 					 (plist-get (fsm-get-state-data jc) :server)))
-	       (sasl-read-passphrase (jabber-sasl-read-passphrase-closure jc))
+	       (sasl-read-passphrase (jabber-sasl-read-passphrase-closure
+				      jc
+				      (lambda (p) (setq passphrase (copy-sequence p)) p)))
 	       (step (sasl-next-step client nil)))
 	  (jabber-send-sexp
 	   jc
@@ -79,20 +82,25 @@
 		   (mechanism . ,(sasl-mechanism-name mechanism)))
 		  ,(when (sasl-step-data step)
 		     (base64-encode-string (sasl-step-data step) t))))
-	  (cons client step))))))
+	  (list client step passphrase))))))
 
-(defun jabber-sasl-read-passphrase-closure (jc)
-  "Return a lambda function suitable for `sasl-read-passphrase' for JC."
+(defun jabber-sasl-read-passphrase-closure (jc remember)
+  "Return a lambda function suitable for `sasl-read-passphrase' for JC.
+Call REMEMBER with the password.  REMEMBER is expected to return it as well."
   (lexical-let ((password (plist-get (fsm-get-state-data jc) :password))
-		(bare-jid (jabber-connection-bare-jid jc)))
+		(bare-jid (jabber-connection-bare-jid jc))
+		(remember remember))
     (if password
-	(lambda (prompt) (copy-sequence password))
-      (lambda (prompt) (jabber-read-password bare-jid)))))
+	(lambda (prompt) (funcall remember (copy-sequence password)))
+      (lambda (prompt) (funcall remember (jabber-read-password bare-jid))))))
 
 (defun jabber-sasl-process-input (jc xml-data sasl-data)
-  (let ((sasl-read-passphrase (jabber-sasl-read-passphrase-closure jc))
-	(client (car sasl-data))
-	(step (cdr sasl-data)))
+  (let* ((client (first sasl-data))
+	 (step (second sasl-data))
+	 (passphrase (third sasl-data))
+	 (sasl-read-passphrase (jabber-sasl-read-passphrase-closure 
+				jc
+				(lambda (p) (setq passphrase (copy-sequence p)) p))))
     (cond
      ((eq (car xml-data) 'challenge)
       (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data))))
@@ -106,13 +114,12 @@
      ((eq (car xml-data) 'failure)
       (message "SASL authentication failure: %s"
 	       (jabber-xml-node-name (car (jabber-xml-node-children xml-data))))
-      (jabber-uncache-password (jabber-connection-bare-jid jc))
       (fsm-send jc :authentication-failure))
 
      ((eq (car xml-data) 'success)
       (message "Authentication succeeded")
-      (fsm-send jc :authentication-success)))
-    (cons client step)))
+      (fsm-send jc (cons :authentication-success passphrase))))
+    (list client step passphrase)))
 
 (provide 'jabber-sasl)
 ;;; arch-tag: 2a4a234d-34d3-49dd-950d-518c899c0fd0
diff --git a/jabber-util.el b/jabber-util.el
index 8fe484d..1c54586 100644
--- a/jabber-util.el
+++ b/jabber-util.el
@@ -263,12 +263,17 @@ bare-or-muc Turn full JIDs to bare ones, except for in MUC"
 (defun jabber-read-password (bare-jid)
   "Read Jabber password from minibuffer."
   (let ((prompt (format "Jabber password for %s: " bare-jid)))
-    (if (fboundp 'password-read-and-add)
+    (if (fboundp 'password-read)
 	;; Need to copy the password, as sasl.el wants to erase it.
 	(copy-sequence
-	 (password-read-and-add prompt (jabber-password-key bare-jid)))
+	 (password-read prompt (jabber-password-key bare-jid)))
       (read-passwd prompt))))
 
+(defun jabber-cache-password (bare-jid password)
+  "Cache PASSWORD for BARE-JID."
+  (when (fboundp 'password-cache-add)
+    (password-cache-add (jabber-password-key bare-jid) password)))
+
 (defun jabber-uncache-password (bare-jid)
   "Uncache cached password for BARE-JID.
 Useful if the password proved to be wrong."