[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp-tls.lisp cl-xmpp/cl-xmpp.lisp cl-xmpp/package.lisp
Erik Enge
eenge at common-lisp.net
Thu Nov 17 20:56:40 UTC 2005
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv13228
Modified Files:
cl-xmpp-sasl.lisp cl-xmpp-tls.lisp cl-xmpp.lisp package.lisp
Log Message:
sasl-digest-md5, sasl-plain, digest-md5 and plain all tested and known
to be working with google talk, jabberd and ejabberd
Date: Thu Nov 17 21:56:38 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-sasl.lisp
diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.9 cl-xmpp/cl-xmpp-sasl.lisp:1.10
--- cl-xmpp/cl-xmpp-sasl.lisp:1.9 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/cl-xmpp-sasl.lisp Thu Nov 17 21:56:38 2005
@@ -1,16 +1,27 @@
-;;;; $Id: cl-xmpp-sasl.lisp,v 1.9 2005/11/17 19:41:40 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.lisp,v 1.10 2005/11/17 20:56:38 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $
;;;; See the LICENSE file for licensing information.
(in-package :xmpp)
-;;; XXX: Remember to BIND after this, I think.
+(defmethod %sasl-plain% ((connection connection) username password resource)
+ (let* ((mechanism "PLAIN")
+ (sasl-client (make-instance (sasl:get-mechanism mechanism)
+ :authentication-id username
+ :password password
+ :service "xmpp"
+ :host (hostname connection))))
+ (format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client))
+ (initiate-sasl-authentication connection mechanism sasl-client)
+ (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"))
-(eval-when (:execute :load-toplevel :compile-toplevel)
- (add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%))
+(add-auth-method :sasl-digest-md5 '%sasl-digest-md5%)
(defmethod handle-challenge-response ((connection connection) username password mechanism)
"Helper method to the sasl authentication methods. Goes through the
@@ -44,9 +55,7 @@
(if (eq (name second-challenge) :challenge)
(progn
(send-second-response connection)
- (let ((final-reply (receive-stanza connection)))
- ; name should be either :success or :failure.
- (values (name final-reply) final-reply)))
+ (receive-stanza connection))
(values :failure second-challenge))))))
(values :failure initial-challenge)))))
@@ -54,7 +63,11 @@
(with-xml-stream (stream connection)
(xml-output
stream
- (fmt "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='~a'/>" mechanism))))
+ (if (string-equal mechanism "plain")
+ (fmt "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='~a'>~a</auth>"
+ mechanism
+ (base64:usb8-array-to-base64-string (sasl:client-step sasl-client nil)))
+ (fmt "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='~a'/>" mechanism)))))
(defmethod send-challenge-response ((connection connection) response)
(with-xml-stream (stream connection)
Index: cl-xmpp/cl-xmpp-tls.lisp
diff -u cl-xmpp/cl-xmpp-tls.lisp:1.6 cl-xmpp/cl-xmpp-tls.lisp:1.7
--- cl-xmpp/cl-xmpp-tls.lisp:1.6 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/cl-xmpp-tls.lisp Thu Nov 17 21:56:38 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-tls.lisp,v 1.6 2005/11/17 19:41:40 eenge Exp $
+;;;; $Id: cl-xmpp-tls.lisp,v 1.7 2005/11/17 20:56:38 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -7,23 +7,31 @@
(defun connect-tls (&rest args)
"Connect to the host and start a TLS stream."
- (let ((connection (apply #'connect args)))
- (send-starttls connection)
- (let ((reply (receive-stanza connection)))
- (case (name reply)
- (:proceed
- (let ((begin-xml-stream (if (member :begin-xml-stream args)
- (getf args :begin-xml-stream)
- t))
- (receive-stanzas (if (member :begin-xml-stream args)
- (getf args :begin-xml-stream)
- t)))
- (convert-to-tls-stream connection
- :begin-xml-stream begin-xml-stream
- :receive-stanzas receive-stanzas)
- (values connection :proceed reply)))
- (:failure (values connection :failure reply))
- (t (error "Unexpected reply from TLS negotiation: ~a." reply))))))
+ (let ((begin-xml-stream (if (member :begin-xml-stream args)
+ (getf args :begin-xml-stream)
+ t))
+ (receive-stanzas (if (member :begin-xml-stream args)
+ (getf args :begin-xml-stream)
+ t)))
+ (connect-tls2 (apply #'connect args)
+ :begin-xml-stream begin-xml-stream
+ :receive-stanzas receive-stanzas)))
+
+(defmethod connect-tls2 ((connection connection) &key
+ (receive-stanzas t)
+ (begin-xml-stream t))
+ "This one does all the work so if you need to use the
+regular CONNECT followed by something followed by converting
+your stream to TLS you could use this function."
+ (send-starttls connection)
+ (let ((reply (receive-stanza connection)))
+ (case (name reply)
+ (:proceed (convert-to-tls-stream connection
+ :begin-xml-stream begin-xml-stream
+ :receive-stanzas receive-stanzas)
+ (values connection :proceed reply))
+ (:failure (values connection :failure reply))
+ (t (error "Unexpected reply from TLS negotiation: ~a." reply)))))
(defmethod send-starttls ((connection connection))
"Sends a request to start a TLS stream with the server."
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.17 cl-xmpp/cl-xmpp.lisp:1.18
--- cl-xmpp/cl-xmpp.lisp:1.17 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/cl-xmpp.lisp Thu Nov 17 21:56:38 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.17 2005/11/17 19:41:40 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.18 2005/11/17 20:56:38 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -201,6 +201,7 @@
(:unreg_1 :registration-cancellation-successful)
(:change1 :password-changed-succesfully)
(:auth2 :authentication-successful)
+ (:bind_2 :bind-successful)
(t (cond
((member id '(info1 info2 info3))
(make-disco-info (get-element object :query)))
@@ -228,6 +229,13 @@
(push element (features connection))))
object)
+;;; XXX: Not sure this is correct. Could perhaps get a success element
+;;; for other things than just authentication. I can't remember right
+;;; now but I should check.
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :success)))
+ :authentication-successful)
+
(defmethod xml-element-to-event ((connection connection) (object xml-element) name)
(declare (ignore name))
object)
@@ -418,10 +426,10 @@
(with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth")
(cxml:with-element "username" (cxml:text username))
(cxml:with-element "password" (cxml:text password))
- (cxml:with-element "resource" (cxml:text resource))))
+ (cxml:with-element "resource" (cxml:text resource)))
+ (receive-stanza connection))
-(eval-when (:execute :load-toplevel :compile-toplevel)
- (add-auth-method :plain #'%plain-auth%))
+(add-auth-method :plain '%plain-auth%)
(defmethod %digest-md5-auth% ((connection connection) username password resource)
(with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth")
@@ -430,10 +438,10 @@
(cxml:with-element "digest"
(cxml:text (make-digest-password (stream-id connection) password)))
(error "stream-id on ~a not set, cannot make digest password" connection))
- (cxml:with-element "resource" (cxml:text resource))))
+ (cxml:with-element "resource" (cxml:text resource)))
+ (receive-stanza connection))
-(eval-when (:execute :load-toplevel :compile-toplevel)
- (add-auth-method :digest-md5 #'%digest-md5-auth%))
+(add-auth-method :digest-md5 '%digest-md5-auth%)
(defmethod presence ((connection connection) &key type to)
(cxml:with-xml-output (make-octet+character-debug-stream-sink
Index: cl-xmpp/package.lisp
diff -u cl-xmpp/package.lisp:1.9 cl-xmpp/package.lisp:1.10
--- cl-xmpp/package.lisp:1.9 Sun Nov 13 03:36:10 2005
+++ cl-xmpp/package.lisp Thu Nov 17 21:56:38 2005
@@ -1,4 +1,4 @@
-;;;; $Id: package.lisp,v 1.9 2005/11/13 02:36:10 eenge Exp $
+;;;; $Id: package.lisp,v 1.10 2005/11/17 20:56:38 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -18,7 +18,7 @@
:with-iq-query :connection :username :mechanisms :features
:feature-p :feature-required-p :mechanism-p :receive-stanza
;; only available if you've loaded cl-xmpp-tls
- :connect-tls
+ :connect-tls :connect-tls2
;; xmpp commands
:discover
:registration-requirements :register
More information about the Cl-xmpp-cvs
mailing list