Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv7442
Modified Files: CREDITS TODO cl-xmpp-sasl.lisp cl-xmpp-tls.lisp cl-xmpp.lisp result.lisp Log Message: working sasl and working tls support
still some issue talking with google talk but less important
Date: Thu Nov 17 20:41:41 2005 Author: eenge
Index: cl-xmpp/CREDITS diff -u cl-xmpp/CREDITS:1.2 cl-xmpp/CREDITS:1.3 --- cl-xmpp/CREDITS:1.2 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/CREDITS Thu Nov 17 20:41:40 2005 @@ -1,4 +1,5 @@ Erik Enge David Lichteblau for helping with CXML issues and testing John Wiseman for OpenMCL support -Richard Krueter for Clisp support \ No newline at end of file +Richard Krueter for Clisp support +Adam Thorsen for helping me debug SASL bugs \ No newline at end of file
Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.9 cl-xmpp/TODO:1.10 --- cl-xmpp/TODO:1.9 Mon Nov 14 21:07:36 2005 +++ cl-xmpp/TODO Thu Nov 17 20:41:40 2005 @@ -1,6 +1,8 @@ - respect stringprep/nodeprep - jid validator
- i hate that xmlns's are as strings and never validated + - could perhaps pass xmlns as last parameter to + xml-element-to-event
- create a connect-test which makes a "fake" connection but still writes into a stream. prerequisite for writing a test
Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.8 cl-xmpp/cl-xmpp-sasl.lisp:1.9 --- cl-xmpp/cl-xmpp-sasl.lisp:1.8 Mon Nov 14 20:21:06 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Thu Nov 17 20:41:40 2005 @@ -1,25 +1,16 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.8 2005/11/14 19:21:06 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.9 2005/11/17 19:41:40 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 these, I think. -(defmethod %sasl-plain% ((connection connection) username password resource) - (handle-challenge-response connection username password "PLAIN")) - -(add-auth-method :sasl-plain #'%sasl-plain%) - +;;; XXX: Remember to BIND after this, I think. (defmethod %sasl-digest-md5% ((connection connection) username password resource) - (handle-challenge-response connection - username - (make-digest-password - (stream-id connection) - password) - "DIGEST-MD5")) + (handle-challenge-response connection username password "DIGEST-MD5"))
-(add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%) +(eval-when (:execute :load-toplevel :compile-toplevel) + (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 @@ -31,6 +22,7 @@ :password password :service "xmpp" :host (hostname connection)))) + (format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client)) (initiate-sasl-authentication connection mechanism sasl-client) (let ((initial-challenge (receive-stanza connection))) (if (eq (name initial-challenge) :challenge) @@ -39,7 +31,8 @@ (usb8-response (sasl:client-step sasl-client (ironclad:ascii-string-to-byte-array challenge-string)))) - (format *debug-stream* "~&challenge-string: ~a~%" challenge-string) + (format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client)) + (format *debug-stream* "challenge-string: ~a~%" challenge-string) (if (eq usb8-response :failure) (values :failure initial-challenge) (let ((base64-response (base64:usb8-array-to-base64-string usb8-response))) @@ -59,7 +52,9 @@
(defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client) (with-xml-stream (stream connection) - (xml-output stream (fmt "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='~a'/>" mechanism)))) + (xml-output + stream + (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.5 cl-xmpp/cl-xmpp-tls.lisp:1.6 --- cl-xmpp/cl-xmpp-tls.lisp:1.5 Wed Nov 16 20:06:12 2005 +++ cl-xmpp/cl-xmpp-tls.lisp Thu Nov 17 20:41:40 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-tls.lisp,v 1.5 2005/11/16 19:06:12 eenge Exp $ +;;;; $Id: cl-xmpp-tls.lisp,v 1.6 2005/11/17 19:41:40 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $
;;;; See the LICENSE file for licensing information. @@ -11,8 +11,17 @@ (send-starttls connection) (let ((reply (receive-stanza connection))) (case (name reply) - (:proceed (convert-to-tls-stream connection) - (values connection :proceed 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))))))
@@ -21,14 +30,18 @@ (with-xml-stream (stream connection) (xml-output stream "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>")))
-(defmethod convert-to-tls-stream ((connection connection) &key (begin-xml-stream t)) +(defmethod convert-to-tls-stream ((connection connection) &key + (begin-xml-stream t) + (receive-stanzas t)) "Convert the existing stream to a TLS stream and issue a stream:stream open tag to start the XML stream.
Turn off sending XML stream start with :begin-xml-stream nil." (setf (server-stream connection) (cl+ssl:make-ssl-client-stream (server-stream connection))) - (setf (server-xstream connection) - (cxml:make-xstream (server-stream connection))) - (when begin-xml-stream - (begin-xml-stream connection))) + (setf (server-xstream connection) nil) + (when begin-xml-stream + (begin-xml-stream connection)) + (when receive-stanzas + (receive-stanza connection) + (receive-stanza connection))) \ No newline at end of file
Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.16 cl-xmpp/cl-xmpp.lisp:1.17 --- cl-xmpp/cl-xmpp.lisp:1.16 Mon Nov 14 21:07:36 2005 +++ cl-xmpp/cl-xmpp.lisp Thu Nov 17 20:41:40 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.16 2005/11/14 20:07:36 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.17 2005/11/17 19:41:40 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information. @@ -62,6 +62,9 @@ (format stream " (open)") (format stream " (closed)"))))
+;;; Note: If you change the default value of either receive-stanzas +;;; or begin-xml-stream you must update that value in cl-xmpp-tls.lisp's +;;; connect-tls to be the same. (defun connect (&key (hostname *default-hostname*) (port *default-port*) (receive-stanzas t) (begin-xml-stream t) jid-domain-part) "Open TCP connection to hostname. @@ -417,7 +420,8 @@ (cxml:with-element "password" (cxml:text password)) (cxml:with-element "resource" (cxml:text resource))))
-(add-auth-method :plain #'%plain-auth%) +(eval-when (:execute :load-toplevel :compile-toplevel) + (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") @@ -428,7 +432,8 @@ (error "stream-id on ~a not set, cannot make digest password" connection)) (cxml:with-element "resource" (cxml:text resource))))
-(add-auth-method :digest-md5 #'%digest-md5-auth%) +(eval-when (:execute :load-toplevel :compile-toplevel) + (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/result.lisp diff -u cl-xmpp/result.lisp:1.10 cl-xmpp/result.lisp:1.11 --- cl-xmpp/result.lisp:1.10 Tue Nov 15 16:19:08 2005 +++ cl-xmpp/result.lisp Thu Nov 17 20:41:40 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.10 2005/11/15 15:19:08 eenge Exp $ +;;;; $Id: result.lisp,v 1.11 2005/11/17 19:41:40 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information. @@ -66,7 +66,7 @@ (defmethod print-object ((object xml-element) stream) "Print the object for the Lisp reader." (print-unreadable-object (object stream :type t :identity t) - (format stream "~a (~a:~a:~a)" + (format stream "~a (~aattr:~achild:~adata)" (name object) (length (attributes object)) (length (elements object)) @@ -288,8 +288,11 @@
(defmethod print-object ((object xmpp-protocol-error) stream) "Print the object for the Lisp reader." - (print-unreadable-object (object stream :type t :identity t) - (format stream "code:~a name:~a" (code object) (name object)))) + (print-unreadable-object (object stream :type nil :identity t) + (format stream "~a code:~a name:~a" + (type-of object) + (code object) + (name object))))
(defclass xmpp-protocol-error-modify (xmpp-protocol-error) ()) (defclass xmpp-protocol-error-cancel (xmpp-protocol-error) ()) @@ -304,29 +307,18 @@
(defun map-error-type-to-class (type) (case type - (modify (find-class 'xmpp-protocol-error-modify)) - (cancel (find-class 'xmpp-protocol-error-cancel)) - (wait (find-class 'xmpp-protocol-error-wait)) - (auth (find-class 'xmpp-protocol-error-auth)) - (t (find-class 'xmpp-protocol-error)))) + (:modify (find-class 'xmpp-protocol-error-modify)) + (:cancel (find-class 'xmpp-protocol-error-cancel)) + (:wait (find-class 'xmpp-protocol-error-wait)) + (:auth (find-class 'xmpp-protocol-error-auth)) + (t (format *debug-stream* "~&Unable to find error class for ~w.~&" type) + (find-class 'xmpp-protocol-error))))
+;;; XXX: Handle legacy errors (defmethod make-error ((object xml-element)) - (let* ((first-element (car (elements object))) - (name) - (type) - (code) - (class)) - (if (eq (name first-element) :#text) ; old-style error - (progn - (setq code (parse-integer (value (get-attribute object :code)))) - (let ((data (get-error-data-code code))) - (setq name (first data)) - (setq type (second data)) - (setq class (map-error-type-to-class type)))) - (progn - (setq name (name first-element)) - (let ((data (get-error-data-name name))) - (setq type (second data)) - (setq code (third data)) - (setq class (map-error-type-to-class type))))) + (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))) (make-instance class :code code :name name :xml-element object)))