cl-xmpp-cvs

cl-xmpp-cvs@common-lisp.net

104 discussions

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

18 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv29817 Modified Files: README Log Message: Date: Fri Nov 18 23:01:09 2005 Author: eenge Index: cl-xmpp/README diff -u cl-xmpp/README:1.8 cl-xmpp/README:1.9 --- cl-xmpp/README:1.8 Sun Nov 13 03:55:46 2005 +++ cl-xmpp/README Fri Nov 18 23:01:08 2005 @@ -5,19 +5,11 @@ * (require :cl-xmpp) - * (defvar connection (xmpp:connect "username" :hostname "jabber.org")) -;; or use xmpp:connect-tls with the exact same arguments to initiate -;; a TLS connection. there are operators in cl-xmpp-tls.lisp you -;; can use manually if you want to check that this host supports -;; TLS connections, first. + * (defvar *connection* (xmpp:connect :hostname "jabber.org")) -;; authenticate (or use xmpp:register to make an account) * (xmpp:auth connection "password" "resource") -;; defaults to plain non-sasl authentication but sasl is also available - -;; let the server know you want to receive/send presence information -;; (this makes you "come online" if others have a subscription with you) - * (xmpp:presence connection) +;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5 +;; if you loaded cl-xmpp-sasl. ;; send someone a message * (xmpp:message connection "username@hostname" "what's going on?")

1 0

[cl-xmpp-cvs] CVS update: public_html/index.html
by eenge＠common-lisp.net 18 Nov '05

18 Nov '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv29648 Modified Files: index.html Log Message: preparing for 0.6.0 Date: Fri Nov 18 23:00:44 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.19 public_html/index.html:1.20 --- public_html/index.html:1.19 Sun Nov 13 03:55:15 2005 +++ public_html/index.html Fri Nov 18 23:00:44 2005 @@ -17,15 +17,18 @@ servers use to communicate with eachother (including <a href="http://talk.google.com/">Google Talk</a>). In addition cl-xmpp implements JEPs 0078, 0086, 0030 and 0070 which are -all part of <a href="http://www.jabber.org/jeps/jep-0073.html">JEP-0073: Basic IM Protocol Suite</a>. The author considers the library feature complete but will happily accept patches for any other reasonably stable JEPs.</p> +all part of <a href="http://www.jabber.org/jeps/jep-0073.html">JEP-0073: +Basic IM Protocol Suite</a>. The author considers the library +feature complete but will happily accept patches for any other +reasonably stable JEPs.</p> <p>Currently, you can chat, manage your contacts, roster and presence information using this library. You can now also use the service discovery protocol using the <code>xmpp:discover</code> operator.</p> <p>The code is released under an <a - href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cl-xmpp/LICENSE?rev=HEAD&cvsroot…">MIT-style - license</a>. </p> + href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cl-xmpp/LICENSE?rev=HEAD&cvsroot…">MIT-style license</a>. + </p> <h2>Requirements</h2> <div class="level"> @@ -34,16 +37,15 @@ <li><a href="http://cliki.net/trivial-sockets">trivial-sockets</a></li> <li><a href="http://common-lisp.net/project/cxml">cxml</a></li> <li><a href="http://cliki.net/ironclad">Ironclad</a></li> - <li><a href="http://cliki.net/cl-base64">cl-base64</a> (if you are using cl-xmpp-{sasl|tls}.asd)</li> - <li><a href="http://cliki.net/cl-sasl">cl-sasl</a> (if you are using cl-xmpp-{sasl|tls}.asd)</li> - <li><a href="http://common-lisp.net/project/cl-plus-ssl">cl+ssl</a> (if you are using cl-xmpp-tls.asd</li> + <li><a href="http://cliki.net/cl-base64">cl-base64</a> (if you are using cl-xmpp-sasl)</li> + <li><a href="http://cliki.net/cl-sasl">cl-sasl</a> (if you loaded cl-xmpp-sasl)</li> </ul> </div> <h2>News</h2> <div class="level"> <ul> - <li>Version 0.6.0 released (SASL and TLS support, better debugability + small test suite) + <li>Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)</li> <li>Version 0.5.0 released (Now depending on <a href="http://cliki.net/ironclad">Ironclad</a> for digest authentication)</li> <li>Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)</li> <li>Version 0.3.0 released (Added Allegro and LispWorks support)</li> @@ -96,19 +98,11 @@ <pre> * (require :cl-xmpp) - * (defvar connection (xmpp:connect "username" :hostname "jabber.org")) -;; or use xmpp:connect-tls with the exact same arguments to initiate -;; a TLS connection. there are operators in cl-xmpp-tls.lisp you -;; can use manually if you want to check that this host supports -;; TLS connections, first. + * (defvar *connection* (xmpp:connect :hostname "jabber.org")) -;; authenticate (or use xmpp:register to make an account) * (xmpp:auth connection "password" "resource") -;; defaults to plain non-sasl authentication but sasl is also available - -;; let the server know you want to receive/send presence information -;; (this makes you "come online" if others have a subscription with you) - * (xmpp:presence connection) +;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5 +;; if you loaded cl-xmpp-sasl. ;; send someone a message * (xmpp:message connection "username@hostname" "what's going on?") @@ -138,7 +132,8 @@ * (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message)) (xmpp:message connection (xmpp:from message) (format nil "reply to: ~a" (xmpp:message object)))) - </pre> + + </pre> </div>

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/LICENSE cl-xmpp/TODO cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/package.lisp cl-xmpp/variable.lisp
by eenge＠common-lisp.net 18 Nov '05

18 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv27903 Modified Files: LICENSE TODO cl-xmpp.lisp cxml.lisp package.lisp variable.lisp Log Message: Date: Fri Nov 18 22:43:52 2005 Author: eenge Index: cl-xmpp/LICENSE diff -u cl-xmpp/LICENSE:1.1.1.1 cl-xmpp/LICENSE:1.2 --- cl-xmpp/LICENSE:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/LICENSE Fri Nov 18 22:43:51 2005 @@ -1,23 +1,23 @@ Copyright (c) 2005 Erik Enge -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER EXPRESSED NOR -IMPLIED WARRANTIES - THIS INCLUDES, BUT IS NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.IN -NO WAY ARE THE AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; LOSS OF USE, -DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. For further details contact the author of this software. Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.10 cl-xmpp/TODO:1.11 --- cl-xmpp/TODO:1.10 Thu Nov 17 20:41:40 2005 +++ cl-xmpp/TODO Fri Nov 18 22:43:52 2005 @@ -7,3 +7,6 @@ - create a connect-test which makes a "fake" connection but still writes into a stream. prerequisite for writing a test suite (which i should do). + +- havent found a good use for IDs yet so right now they are + just what happen to be in the specs \ No newline at end of file Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.19 cl-xmpp/cl-xmpp.lisp:1.20 --- cl-xmpp/cl-xmpp.lisp:1.19 Thu Nov 17 22:51:15 2005 +++ cl-xmpp/cl-xmpp.lisp Fri Nov 18 22:43:52 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.19 2005/11/17 21:51:15 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.20 2005/11/18 21:43:52 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -202,6 +202,7 @@ (:change1 :password-changed-succesfully) (:auth2 :authentication-successful) (:bind_2 :bind-successful) + (:session_1 :session-initiated) (t (cond ((member id '(info1 info2 info3)) (make-disco-info (get-element object :query))) @@ -328,7 +329,7 @@ "Write string to stream as a sequence of bytes and not characters." (let ((sequence (ironclad:ascii-string-to-byte-array string))) (write-sequence sequence stream) - (finish-output stream) + (force-output stream) (when *debug-stream* (write-string string *debug-stream*) (force-output *debug-stream*)))) @@ -356,26 +357,25 @@ "Macro to make it easier to write IQ stanzas." (let ((stream (gensym))) `(let ((,stream (server-stream ,connection))) - (cxml:with-xml-output (make-octet+character-debug-stream-sink ,stream) - (cxml:with-element "iq" - (cxml:attribute "id" ,id) - (when ,to - (cxml:attribute "to" ,to)) - (cxml:attribute "type" ,type) - ,@body)) - (force-output ,stream) - ,connection))) + (prog1 + (cxml:with-xml-output (make-octet+character-debug-stream-sink ,stream) + (cxml:with-element "iq" + (when ,id + (cxml:attribute "id" ,id)) + (when ,to + (cxml:attribute "to" ,to)) + (cxml:attribute "type" ,type) + ,@body)) + (force-output ,stream))))) (defmacro with-iq-query ((connection &key xmlns id to node (type "get")) &body body) "Macro to make it easier to write QUERYs." - `(progn - (with-iq (connection :id ,id :type ,type :to ,to) - (cxml:with-element "query" + `(with-iq (connection :id ,id :type ,type :to ,to) + (cxml:with-element "query" (cxml:attribute "xmlns" ,xmlns) - (when ,node - (cxml:attribute "node" ,node)) - ,@body)) - ,connection)) + (when ,node + (cxml:attribute "node" ,node)) + ,@body))) ;; ;; Discovery @@ -418,8 +418,10 @@ (with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth") (cxml:with-element "username" (cxml:text username)))) -(defmethod auth ((connection connection) username password - resource &optional (mechanism :plain) (bind-et-al t)) +(defmethod auth ((connection connection) username password resource &key + (mechanism :plain) + (bind-et-al t) + (send-presence 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) @@ -427,10 +429,14 @@ (if (and (eq result :authentication-successful) bind-et-al) (progn - (bind connection username resource) - (receive-stanza connection) - (session connection) - (receive-stanza connection)) + (when (feature-p connection :bind) + (bind connection resource) + (receive-stanza connection)) + (when (feature-p connection :session) + (session connection) + (receive-stanza connection)) + (when send-presence + (presence connection))) result))) (defmethod %plain-auth% ((connection connection) username password resource) @@ -472,7 +478,7 @@ (cxml:with-element "body" (cxml:text body)))) connection) -(defmethod bind ((connection connection) jid resource) +(defmethod bind ((connection connection) resource) (with-iq (connection :id "bind_2" :type "set") (cxml:with-element "bind" (cxml:attribute "xmlns" "urn:ietf:params:xml:ns:xmpp-bind") Index: cl-xmpp/cxml.lisp diff -u cl-xmpp/cxml.lisp:1.6 cl-xmpp/cxml.lisp:1.7 --- cl-xmpp/cxml.lisp:1.6 Mon Nov 14 20:42:29 2005 +++ cl-xmpp/cxml.lisp Fri Nov 18 22:43:52 2005 @@ -75,21 +75,21 @@ ;; To facilitate writing to both an octet and a character stream ;; using CXML. -(defclass octet+character-debug-stream-sink (cxml::octet-stream-sink) - ((target-stream - :accessor target-stream - :initarg :target-stream))) +(defclass octet+character-debug-stream-sink (cxml::octet-stream-sink) ()) (defun make-octet+character-debug-stream-sink (octet-stream &rest initargs) - (apply #'make-instance 'octet+character-debug-stream-sink - :target-stream octet-stream - initargs)) + (apply #'make-instance 'octet+character-debug-stream-sink + :target-stream octet-stream + initargs)) (defmethod cxml::write-octet (octet (sink octet+character-debug-stream-sink)) - (write-byte octet (target-stream sink)) - (when *debug-stream* - (write-char (code-char octet) *debug-stream*) - (force-output *debug-stream*))) + (write-byte octet (slot-value sink 'cxml::target-stream)) + (when *debug-stream* + (write-char (code-char octet) *debug-stream*) + (force-output *debug-stream*))) + +;(defmethod write-octet-sequence (sequence (sink octet+character-debug-stream-sink)) +; (write-sequence sequence (slot-value sink 'cxml::target-stream))) ;; I'd like to see what CXML is reading from the stream ;; and this code helps us in that regard by printing it Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.11 cl-xmpp/package.lisp:1.12 --- cl-xmpp/package.lisp:1.11 Thu Nov 17 22:51:16 2005 +++ cl-xmpp/package.lisp Fri Nov 18 22:43:52 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.11 2005/11/17 21:51:16 eenge Exp $ +;;;; $Id: package.lisp,v 1.12 2005/11/18 21:43:52 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -17,6 +17,7 @@ :receive-stanza-loop :begin-xml-stream :end-xml-stream :with-iq :with-iq-query :connection :username :mechanisms :features :feature-p :feature-required-p :mechanism-p :receive-stanza + :server-stream ;; only available if you've loaded cl-xmpp-tls :connect-tls :connect-tls2 ;; xmpp commands @@ -52,4 +53,4 @@ ;; user-hooks for handling events :handle ;; variables - :*default-port :*default-hostname* :*errors*))) + :*default-port :*default-hostname* :*errors* :*debug-stream*))) Index: cl-xmpp/variable.lisp diff -u cl-xmpp/variable.lisp:1.4 cl-xmpp/variable.lisp:1.5 --- cl-xmpp/variable.lisp:1.4 Fri Nov 11 22:20:20 2005 +++ cl-xmpp/variable.lisp Fri Nov 18 22:43:52 2005 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.4 2005/11/11 21:20:20 eenge Exp $ +;;;; $Id: variable.lisp,v 1.5 2005/11/18 21:43:52 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -12,7 +12,7 @@ (defvar *default-hostname* "localhost") (defvar *errors* - '((:bad-request :modiy 400) + '((:bad-request :modify 400) (:conflict :cancel 409) (:feature-not-implemented :cancel 501) (:forbidden :auth 403)

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp.lisp cl-xmpp/package.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-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)))

1 0

[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

← Newer
1
2
3
4
5
6
7
8
...
11
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cl-xmpp-cvs