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