[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp.lisp cl-xmpp/package.lisp cl-xmpp/result.lisp
Erik Enge
eenge at common-lisp.net
Thu Nov 17 21:51:17 UTC 2005
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)))
More information about the Cl-xmpp-cvs
mailing list