November 2005 - cl-xmpp-cvs@common-lisp.net

[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
by eenge＠common-lisp.net 17 Nov '05

17 Nov '05

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

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/CREDITS cl-xmpp/TODO cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp-tls.lisp cl-xmpp/cl-xmpp.lisp cl-xmpp/result.lisp
by eenge＠common-lisp.net 17 Nov '05

17 Nov '05

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)))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-tls.lisp
by eenge＠common-lisp.net 16 Nov '05

16 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv29777 Modified Files: cl-xmpp-tls.lisp Log Message: fix for convert-to-tls-stream for lichteblau though currently it (the function) is not working because something is blocking, somewhere Date: Wed Nov 16 20:06:12 2005 Author: eenge Index: cl-xmpp/cl-xmpp-tls.lisp diff -u cl-xmpp/cl-xmpp-tls.lisp:1.4 cl-xmpp/cl-xmpp-tls.lisp:1.5 --- cl-xmpp/cl-xmpp-tls.lisp:1.4 Mon Nov 14 16:14:06 2005 +++ cl-xmpp/cl-xmpp-tls.lisp Wed Nov 16 20:06:12 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-tls.lisp,v 1.4 2005/11/14 15:14:06 eenge Exp $ +;;;; $Id: cl-xmpp-tls.lisp,v 1.5 2005/11/16 19:06:12 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -28,5 +28,7 @@ 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)))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/Makefile
by eenge＠common-lisp.net 15 Nov '05

15 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv4821 Modified Files: Makefile Log Message: adding clisp compiled files to make clean Date: Tue Nov 15 16:19:46 2005 Author: eenge Index: cl-xmpp/Makefile diff -u cl-xmpp/Makefile:1.4 cl-xmpp/Makefile:1.5 --- cl-xmpp/Makefile:1.4 Sun Nov 13 03:45:41 2005 +++ cl-xmpp/Makefile Tue Nov 15 16:19:46 2005 @@ -5,4 +5,6 @@ -o -name "*.err" \ -o -name "*.x86f" \ -o -name "*.nfasl" \ + -o -name "*.lib" \ + -o -name "*.fas" \ | xargs rm

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/result.lisp
by eenge＠common-lisp.net 15 Nov '05

15 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv4803 Modified Files: result.lisp Log Message: now producing the same error instance for old-style and new-style error messages Date: Tue Nov 15 16:19:08 2005 Author: eenge Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.9 cl-xmpp/result.lisp:1.10 --- cl-xmpp/result.lisp:1.9 Mon Nov 14 21:07:36 2005 +++ cl-xmpp/result.lisp Tue Nov 15 16:19:08 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.9 2005/11/14 20:07:36 eenge Exp $ +;;;; $Id: result.lisp,v 1.10 2005/11/15 15:19:08 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -296,9 +296,12 @@ (defclass xmpp-protocol-error-wait (xmpp-protocol-error) ()) (defclass xmpp-protocol-error-auth (xmpp-protocol-error) ()) -(defun get-error-data (name) +(defun get-error-data-name (name) (assoc name *errors*)) +(defun get-error-data-code (code) + (rassoc code *errors* :key #'second)) + (defun map-error-type-to-class (type) (case type (modify (find-class 'xmpp-protocol-error-modify)) @@ -308,9 +311,22 @@ (t (find-class 'xmpp-protocol-error)))) (defmethod make-error ((object xml-element)) - (let* ((name (intern (string-upcase (name (car (elements object)))) :keyword)) - (data (get-error-data name)) - (type (second data)) - (code (third data)) - (class (map-error-type-to-class type))) + (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))))) (make-instance class :code code :name name :xml-element object)))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/TODO cl-xmpp/cl-xmpp.lisp cl-xmpp/result.lisp cl-xmpp/utility.lisp
by eenge＠common-lisp.net 14 Nov '05

14 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv15793 Modified Files: TODO cl-xmpp.lisp result.lisp utility.lisp Log Message: all names on attributes and elements are now keywords (works better in lisps without wide characters due to cxml representing things as vectors) Date: Mon Nov 14 21:07:36 2005 Author: eenge Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.8 cl-xmpp/TODO:1.9 --- cl-xmpp/TODO:1.8 Sat Nov 12 21:53:17 2005 +++ cl-xmpp/TODO Mon Nov 14 21:07:36 2005 @@ -1,8 +1,5 @@ - respect stringprep/nodeprep - jid validator -- also, i'm interning things which may screw up lisps with up/down - case different. - - i hate that xmlns's are as strings and never validated - create a connect-test which makes a "fake" connection but Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.15 cl-xmpp/cl-xmpp.lisp:1.16 --- cl-xmpp/cl-xmpp.lisp:1.15 Mon Nov 14 20:21:06 2005 +++ cl-xmpp/cl-xmpp.lisp Mon Nov 14 21:07:36 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.15 2005/11/14 19:21:06 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.16 2005/11/14 20:07:36 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -163,7 +163,7 @@ objects)) (defmethod parse-result ((connection connection) (attribute dom-impl::attribute)) - (let* ((name (dom:node-name attribute)) + (let* ((name (ensure-keyword (dom:node-name attribute))) (value (dom:value attribute)) (xml-attribute (make-instance 'xml-attribute @@ -171,14 +171,14 @@ xml-attribute)) (defmethod parse-result ((connection connection) (node dom-impl::character-data)) - (let* ((name (dom:node-name node)) + (let* ((name (ensure-keyword (dom:node-name node))) (data (dom:data node)) (xml-element (make-instance 'xml-element :name name :data data :node node))) xml-element)) (defmethod parse-result ((connection connection) (node dom-impl::node)) - (let* ((name (intern (string-upcase (dom:node-name node)) :keyword)) + (let* ((name (ensure-keyword (dom:node-name node))) (xml-element (make-instance 'xml-element :name name :node node))) (dom:do-node-list (attribute (dom:attributes node)) (push (parse-result connection attribute) (attributes xml-element))) @@ -188,8 +188,8 @@ (defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :iq))) - (let ((id (intern (string-upcase (value (get-attribute object :id))) :keyword))) - (if (not (string-equal (value (get-attribute object :type)) "result")) + (let ((id (ensure-keyword (value (get-attribute object :id))))) + (if (not (eq (ensure-keyword (value (get-attribute object :type))) :result)) (make-error (get-element object :error)) (case id (:error (make-error (get-element object :error))) @@ -233,8 +233,7 @@ (map 'list #'(lambda (x) (dom-to-event connection x)) objects)) (defmethod dom-to-event ((connection connection) (object xml-element)) - (xml-element-to-event - connection object (intern (string-upcase (name object)) :keyword))) + (xml-element-to-event connection object (name object))) ;;; XXX: Is the ask attribute of the <presence/> element part of the RFC/JEP? (defmethod xml-element-to-event ((connection connection) Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.8 cl-xmpp/result.lisp:1.9 --- cl-xmpp/result.lisp:1.8 Sun Nov 13 03:55:46 2005 +++ cl-xmpp/result.lisp Mon Nov 14 21:07:36 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.8 2005/11/13 02:55:46 eenge Exp $ +;;;; $Id: result.lisp,v 1.9 2005/11/14 20:07:36 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -72,12 +72,12 @@ (length (elements object)) (length (data object))))) -(defmethod get-attribute ((element xml-element) name &key (test 'string-equal)) +(defmethod get-attribute ((element xml-element) name &key (test 'eq)) (dolist (attribute (attributes element)) (when (funcall test name (name attribute)) (return-from get-attribute attribute)))) -(defmethod get-element ((element xml-element) name &key (test 'string-equal)) +(defmethod get-element ((element xml-element) name &key (test 'eq)) (dolist (subelement (elements element)) (when (funcall test name (name subelement)) (return-from get-element subelement)))) Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.9 cl-xmpp/utility.lisp:1.10 --- cl-xmpp/utility.lisp:1.9 Mon Nov 14 20:42:29 2005 +++ cl-xmpp/utility.lisp Mon Nov 14 21:07:36 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.9 2005/11/14 19:42:29 eenge Exp $ +;;;; $Id: utility.lisp,v 1.10 2005/11/14 20:07:36 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -43,7 +43,13 @@ (push (list name operator) *auth-methods*)) (defun ensure-keyword (thing) + "Makes a keyword except when it gets nil it just returns nil." (cond - ((typep thing 'string) (intern thing :keyword)) + ((typep thing 'string) + (let ((correct-case-thing (if (eq *print-case* :upcase) + (string-upcase thing) + (string-downcase thing)))) + (intern correct-case-thing :keyword))) ((typep thing 'array) (ensure-keyword (map 'string #'code-char thing))) + ((eq thing nil) nil) (t (error "Don't know how to make keyword out of: ~a (type: ~a)" thing (type-of thing)))))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cxml.lisp cl-xmpp/utility.lisp
by eenge＠common-lisp.net 14 Nov '05

14 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv13651 Modified Files: cxml.lisp utility.lisp Log Message: fixing character issues for lisps without 16 bit wide characters Date: Mon Nov 14 20:42:29 2005 Author: eenge Index: cl-xmpp/cxml.lisp diff -u cl-xmpp/cxml.lisp:1.5 cl-xmpp/cxml.lisp:1.6 --- cl-xmpp/cxml.lisp:1.5 Sat Nov 12 05:20:21 2005 +++ cl-xmpp/cxml.lisp Mon Nov 14 20:42:29 2005 @@ -19,7 +19,7 @@ (defmethod sax:start-element ((handler stanza-handler) uri lname qname attrs) (declare (ignore uri lname)) (when (eql (depth handler) 0) - (if (string-equal "stream:stream" qname) + (if (eq :stream\:stream (ensure-keyword qname)) ;; Create an element for DOM-TO-EVENT so we don't have to have ;; any specialized code just to handle stream:stream. (let* ((document (dom:create-document)) Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.8 cl-xmpp/utility.lisp:1.9 --- cl-xmpp/utility.lisp:1.8 Mon Nov 14 16:14:07 2005 +++ cl-xmpp/utility.lisp Mon Nov 14 20:42:29 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.8 2005/11/14 15:14:07 eenge Exp $ +;;;; $Id: utility.lisp,v 1.9 2005/11/14 19:42:29 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -41,3 +41,9 @@ (defun add-auth-method (name operator) (push (list name operator) *auth-methods*)) + +(defun ensure-keyword (thing) + (cond + ((typep thing 'string) (intern thing :keyword)) + ((typep thing 'array) (ensure-keyword (map 'string #'code-char thing))) + (t (error "Don't know how to make keyword out of: ~a (type: ~a)" thing (type-of thing))))) \ No newline at end of file

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.asd cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp.lisp
by eenge＠common-lisp.net 14 Nov '05

14 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv12512 Modified Files: cl-xmpp-sasl.asd cl-xmpp-sasl.lisp cl-xmpp.lisp Log Message: cleaning up a little in the XML we output (removing newlines, etc.) Date: Mon Nov 14 20:21:06 2005 Author: eenge Index: cl-xmpp/cl-xmpp-sasl.asd diff -u cl-xmpp/cl-xmpp-sasl.asd:1.3 cl-xmpp/cl-xmpp-sasl.asd:1.4 --- cl-xmpp/cl-xmpp-sasl.asd:1.3 Sun Nov 13 03:36:10 2005 +++ cl-xmpp/cl-xmpp-sasl.asd Mon Nov 14 20:21:06 2005 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp-sasl.asd,v 1.3 2005/11/13 02:36:10 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.asd,v 1.4 2005/11/14 19:21:06 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -16,6 +16,6 @@ :author "Erik Enge" :licence "MIT" :description "Common Lisp XMPP client implementation with SASL support" - :depends-on (:cl-xmpp :cl-base64 :sasl) + :depends-on (:cl-xmpp :cl-base64 :cl-sasl) :components ((:file "cl-xmpp-sasl"))) Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.7 cl-xmpp/cl-xmpp-sasl.lisp:1.8 --- cl-xmpp/cl-xmpp-sasl.lisp:1.7 Mon Nov 14 17:08:42 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Mon Nov 14 20:21:06 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.7 2005/11/14 16:08:42 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.8 2005/11/14 19:21:06 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -59,11 +59,7 @@ (defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client) (with-xml-stream (stream connection) - (xml-output stream (fmt "<auth mechanism='~a' -xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>~a</auth>" - mechanism - (base64:usb8-array-to-base64-string - (sasl:client-step sasl-client nil)))))) + (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.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.14 cl-xmpp/cl-xmpp.lisp:1.15 --- cl-xmpp/cl-xmpp.lisp:1.14 Mon Nov 14 16:14:06 2005 +++ cl-xmpp/cl-xmpp.lisp Mon Nov 14 20:21:06 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.14 2005/11/14 15:14:06 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.15 2005/11/14 19:21:06 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -331,11 +331,8 @@ "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'?>") - (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)))))) + (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)) "Closes the XML stream. At this point you'd have to

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp
by eenge＠common-lisp.net 14 Nov '05

14 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv30186 Modified Files: cl-xmpp-sasl.lisp Log Message: TLS is now working Date: Mon Nov 14 17:08:42 2005 Author: eenge Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.6 cl-xmpp/cl-xmpp-sasl.lisp:1.7 --- cl-xmpp/cl-xmpp-sasl.lisp:1.6 Sat Nov 12 05:20:21 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Mon Nov 14 17:08:42 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.6 2005/11/12 04:20:21 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.7 2005/11/14 16:08:42 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -12,7 +12,12 @@ (add-auth-method :sasl-plain #'%sasl-plain%) (defmethod %sasl-digest-md5% ((connection connection) username password resource) - (handle-challenge-response connection username (digestify-string password) "DIGEST-MD5")) + (handle-challenge-response connection + username + (make-digest-password + (stream-id connection) + password) + "DIGEST-MD5")) (add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%) @@ -38,7 +43,8 @@ (if (eq usb8-response :failure) (values :failure initial-challenge) (let ((base64-response (base64:usb8-array-to-base64-string usb8-response))) - (format *debug-stream* "response: ~a~%" (map 'string #'code-char usb8-response)) + (format *debug-stream* "response: ~a~%" + (map 'string #'code-char usb8-response)) (force-output *debug-stream*) (send-challenge-response connection base64-response) (let ((second-challenge (receive-stanza connection))) @@ -46,7 +52,7 @@ (progn (send-second-response connection) (let ((final-reply (receive-stanza connection))) - ; This should return either :success or :failure. + ; name should be either :success or :failure. (values (name final-reply) final-reply))) (values :failure second-challenge)))))) (values :failure initial-challenge))))) @@ -67,4 +73,3 @@ (defmethod send-second-response ((connection connection)) (with-xml-stream (stream connection) (xml-output stream "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>"))) -

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/test/utility-test.lisp
by eenge＠common-lisp.net 14 Nov '05

14 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp/test In directory common-lisp.net:/tmp/cvs-serv25792/test Modified Files: utility-test.lisp Log Message: killing string-to-array and using ironclad:ascii-string-to-byte-array instead Date: Mon Nov 14 16:14:10 2005 Author: eenge Index: cl-xmpp/test/utility-test.lisp diff -u cl-xmpp/test/utility-test.lisp:1.1 cl-xmpp/test/utility-test.lisp:1.2 --- cl-xmpp/test/utility-test.lisp:1.1 Sun Nov 13 03:36:11 2005 +++ cl-xmpp/test/utility-test.lisp Mon Nov 14 16:14:10 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility-test.lisp,v 1.1 2005/11/13 02:36:11 eenge Exp $ +;;;; $Id: utility-test.lisp,v 1.2 2005/11/14 15:14:10 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/utility-test.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -7,8 +7,6 @@ (deftest flatten.1 (xmpp::flatten '(1 2 3)) (1 2 3)) (deftest flatten.2 (xmpp::flatten '(1 (2 3) 4)) (1 2 3 4)) - -(deftest string-to-array.1 (xmpp::string-to-array "test") #(116 101 115 116)) (deftest digestify-string.1 (xmpp::digestify-string "test") "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3")

1 0