Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv17629 Modified Files: cl-xmpp-sasl.lisp cl-xmpp.lisp package.lisp result.lisp Log Message: some reorganisation of the auth code, google talk still not there 100% Date: Thu Nov 17 22:51:16 2005 Author: eenge Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.10 cl-xmpp/cl-xmpp-sasl.lisp:1.11 --- cl-xmpp/cl-xmpp-sasl.lisp:1.10 Thu Nov 17 21:56:38 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Thu Nov 17 22:51:15 2005 @@ -1,10 +1,19 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.10 2005/11/17 20:56:38 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.11 2005/11/17 21:51:15 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :xmpp) +(defmethod if-successful-restart-stream ((connection connection) reply) + (if (eq reply :authentication-successful) + (progn + (begin-xml-stream connection :xml-identifier nil) + (receive-stanza connection) ; stream + (receive-stanza connection) ; features + reply) + reply)) + (defmethod %sasl-plain% ((connection connection) username password resource) (let* ((mechanism "PLAIN") (sasl-client (make-instance (sasl:get-mechanism mechanism) @@ -14,16 +23,19 @@ :host (hostname connection)))) (format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client)) (initiate-sasl-authentication connection mechanism sasl-client) - (receive-stanza connection))) + (if-successful-restart-stream connection (receive-stanza connection)))) (add-auth-method :sasl-plain '%sasl-plain%) (defmethod %sasl-digest-md5% ((connection connection) username password resource) - (handle-challenge-response connection username password "DIGEST-MD5")) + (if-successful-restart-stream + connection + (handle-challenge-response connection username password resource "DIGEST-MD5"))) (add-auth-method :sasl-digest-md5 '%sasl-digest-md5%) -(defmethod handle-challenge-response ((connection connection) username password mechanism) +(defmethod handle-challenge-response ((connection connection) username password + resource mechanism) "Helper method to the sasl authentication methods. Goes through the entire SASL challenge/response chain. Returns two values, the first is a keyword symbol (:success or :failure) and the second is the last @@ -52,12 +64,13 @@ (force-output *debug-stream*) (send-challenge-response connection base64-response) (let ((second-challenge (receive-stanza connection))) + (format *debug-stream* "second-challenge: ~a~&" second-challenge) (if (eq (name second-challenge) :challenge) (progn (send-second-response connection) - (receive-stanza connection)) - (values :failure second-challenge)))))) - (values :failure initial-challenge))))) + (receive-stanza connection)) + second-challenge))))) + initial-challenge)))) (defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client) (with-xml-stream (stream connection) Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.18 cl-xmpp/cl-xmpp.lisp:1.19 --- cl-xmpp/cl-xmpp.lisp:1.18 Thu Nov 17 21:56:38 2005 +++ cl-xmpp/cl-xmpp.lisp Thu Nov 17 22:51:15 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.18 2005/11/17 20:56:38 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.19 2005/11/17 21:51:15 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -93,8 +93,8 @@ (when begin-xml-stream (begin-xml-stream connection)) (when receive-stanzas - (receive-stanza connection) - (receive-stanza connection)) + (receive-stanza connection) ; stream + (receive-stanza connection)) ; features connection)) (defmethod connectedp ((connection connection)) @@ -337,11 +337,12 @@ ;; Operators for communicating over the XML stream ;; -(defmethod begin-xml-stream ((connection connection)) +(defmethod begin-xml-stream ((connection connection) &key (xml-identifier t)) "Begin XML stream. This should be the first thing to happen on a newly connected connection." (with-xml-stream (stream connection) - (xml-output stream "<?xml version='1.0' ?>") + (when xml-identifier + (xml-output stream "<?xml version='1.0' ?>")) (xml-output stream (fmt "<stream:stream to='~a' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>" (or (jid-domain-part connection) (hostname connection)))))) (defmethod end-xml-stream ((connection connection)) @@ -418,9 +419,19 @@ (cxml:with-element "username" (cxml:text username)))) (defmethod auth ((connection connection) username password - resource &optional (mechanism :plain)) + resource &optional (mechanism :plain) (bind-et-al t)) + "If bind-et-al is T this operator will bind, create a session and +call presence on your behalf if the authentication was successful." (setf (username connection) username) - (funcall (get-auth-method mechanism) connection username password resource)) + (let ((result (funcall (get-auth-method mechanism) connection username password resource))) + (if (and (eq result :authentication-successful) + bind-et-al) + (progn + (bind connection username resource) + (receive-stanza connection) + (session connection) + (receive-stanza connection)) + result))) (defmethod %plain-auth% ((connection connection) username password resource) (with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth") @@ -467,6 +478,11 @@ (cxml:attribute "xmlns" "urn:ietf:params:xml:ns:xmpp-bind") (cxml:with-element "resource" (cxml:text resource))))) + +(defmethod session ((connection connection)) + (with-iq (connection :id "session_1" :type "set") + (cxml:with-element "session" + (cxml:attribute "xmlns" "urn:ietf:params:xml:ns:xmpp-session")))) ;; ;; Subscription Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.10 cl-xmpp/package.lisp:1.11 --- cl-xmpp/package.lisp:1.10 Thu Nov 17 21:56:38 2005 +++ cl-xmpp/package.lisp Thu Nov 17 22:51:16 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.10 2005/11/17 20:56:38 eenge Exp $ +;;;; $Id: package.lisp,v 1.11 2005/11/17 21:51:16 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -23,7 +23,7 @@ :discover :registration-requirements :register :auth-requirements :auth - :presence :message :bind + :presence :message :bind :session ;; subscriptions :request-subscription :approve-subscription :deny/cancel-subscription :unsubscribe Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.11 cl-xmpp/result.lisp:1.12 --- cl-xmpp/result.lisp:1.11 Thu Nov 17 20:41:40 2005 +++ cl-xmpp/result.lisp Thu Nov 17 22:51:16 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.11 2005/11/17 19:41:40 eenge Exp $ +;;;; $Id: result.lisp,v 1.12 2005/11/17 21:51:16 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -316,9 +316,25 @@ ;;; XXX: Handle legacy errors (defmethod make-error ((object xml-element)) - (let* ((code (parse-integer (value (get-attribute object :code)))) - (data (get-error-data-code code)) - (name (first data)) - (type (second data)) - (class (map-error-type-to-class type))) + (let ((code-value (value (get-attribute object :code))) + (code) + (name) + (type) + (class)) + ; Slightly verbose but there are still cases I have not + ; addressed (and have no examples of, any more) so I'm going + ; to leave it like this for now. + (if code-value + (let* ((code-number (parse-integer code-value)) + (data (get-error-data-code code-number))) + (setq code code-number) + (setq name (first data)) + (setq type (second data)) + (setq class (map-error-type-to-class type))) + (let* ((name (name (first (elements object)))) + (data (get-error-data-name name))) + (format *debug-stream* "~&Name: ~a~&" name) + (setq code (first data)) + (setq type (second data)) + (setq class (map-error-type-to-class type)))) (make-instance class :code code :name name :xml-element object)))