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

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

29 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv20669 Modified Files: index.html Log Message: adding info about lispworks Date: Sat Oct 29 04:14:26 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.9 public_html/index.html:1.10 --- public_html/index.html:1.9 Fri Oct 28 23:22:05 2005 +++ public_html/index.html Sat Oct 29 04:14:25 2005 @@ -7,7 +7,7 @@ <body> <div class="header"> - <h1>cl-xmpp 0.1.0</h1> + <h1>cl-xmpp 0.3.0</h1> </div> <div class="body"> @@ -20,11 +20,7 @@ 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. The code was developed -under <a href="http://www.sbcl.org">SBCL</a> and currently does -not work on any other implementation due to the fact that the socket -code is all SBCL specific. However, for someone sufficiently motivated, -it probably takes 10 minutes to add support for another implementation.</p> +and presence information using this library.</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 @@ -33,7 +29,7 @@ <h2>Requirements</h2> <div class="level"> <ul> - <li>A recent SBCL (need 16bit wide characters)</li> + <li>A recent SBCL (need 16bit wide characters), LispWorks or Allegro (patches welcome for others)</li> <li><a href="http://common-lisp.net/project/cxml">cxml</a></li> </ul> </div> @@ -41,7 +37,9 @@ <h2>News</h2> <div class="level"> <ul> - <li>Version 0.1.0 released (initial release)</li> + <li>Version 0.3.0 released (Added Allegro and LispWorks support)</li> + <li>Version 0.2.0 released (JEP 0073 support)</li> + <li>Version 0.1.0 released (Initial release)</li> </ul> </div> @@ -49,7 +47,7 @@ <div class="level"> <ul> - <li>implements most commands in the RFCs</li> + <li>Implements most commands in the RFCs</li> <li>event driven model with hooks makes interfacing easy -- or</li> <li>access to DOM-ish structure with raw data from the server so you can do whatever you like</li> </ul> @@ -117,8 +115,8 @@ ;; If you wish to handle the incoming messages or other objects simply ;; specify an xmpp:handle method for the objects you are interested in -;; or xmpp:handle on xmpp:event to get them all. Or alternatively specify -;; :dom-repr t to receive-stanza-loop to get DOM-ish objects. +;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively +;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects. </pre> </div>

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/TODO
by eenge＠common-lisp.net 28 Oct '05

28 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv32714 Modified Files: TODO Log Message: *** empty log message *** Date: Fri Oct 28 23:24:08 2005 Author: eenge Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.2 cl-xmpp/TODO:1.3 --- cl-xmpp/TODO:1.2 Fri Oct 28 23:17:59 2005 +++ cl-xmpp/TODO Fri Oct 28 23:24:08 2005 @@ -6,4 +6,8 @@ - also, i'm interning things which will screw up lisps with up/down case different. -- add support for JEP0030 service discovery \ No newline at end of file +- add support for JEP0030 service discovery + +- also flesh out the HANDLE mechanism better and go over + and make sure correct symbols are exported and remove + no longer needed code. \ No newline at end of file

1 0

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

28 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv32675 Modified Files: index.html Log Message: adding comment about jeps Date: Fri Oct 28 23:22:05 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.8 public_html/index.html:1.9 --- public_html/index.html:1.8 Fri Oct 28 18:10:26 2005 +++ public_html/index.html Fri Oct 28 23:22:05 2005 @@ -15,12 +15,9 @@ <a href="http://www.xmpp.org/">XMPP</a> RFCs. These are the RFCs which <a href="http://jabber.org">Jabber</a> clients and servers use to communicate with eachother (including -<a href="http://talk.google.com/">Google Talk</a>).</p> - - <p>The author is still considering whether or not -to implement <a href="http://www.jabber.org/jeps">Jabber Enhancement Proposals</a> -in addition to the RFCs. (Specifically, I am wondering whether or not to -implement <a href="http://www.jabber.org/jeps/jep-0073.html">JEP-0073: Basic IM Protocol Suite</a>.)</p> +<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> <p>Currently, you can chat, manage your contacts, roster and presence information using this library. The code was developed

1 0

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

28 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv32631 Modified Files: TODO cl-xmpp.lisp result.lisp Log Message: Date: Fri Oct 28 23:17:59 2005 Author: eenge Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.1.1.1 cl-xmpp/TODO:1.2 --- cl-xmpp/TODO:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/TODO Fri Oct 28 23:17:59 2005 @@ -6,6 +6,4 @@ - also, i'm interning things which will screw up lisps with up/down case different. -- ok, test receive-stanza-loop with a file with contents - which i think i'm getting and see if it blows up with - that. \ No newline at end of file +- add support for JEP0030 service discovery \ No newline at end of file Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.2 cl-xmpp/cl-xmpp.lisp:1.3 --- cl-xmpp/cl-xmpp.lisp:1.2 Fri Oct 28 23:04:12 2005 +++ cl-xmpp/cl-xmpp.lisp Fri Oct 28 23:17:59 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.3 2005/10/28 21:17:59 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -251,6 +251,18 @@ (cxml:with-element "password" (cxml:text password)) (cxml:with-element "name" (cxml:text name)) (cxml:with-element "email" (cxml:text email)))) + +(defmethod cancel-registration ((connection connection)) + (with-iq-query (connection :id "unreg1" :type "set" :xmlns "jabber:iq:register") + (cxml:with-element "remove"))) + +;;; XXX: connection should know about username? +(defmethod change-password ((connection connection) username new-password) + (with-iq-query (connection :id "change1" :type "set" :xmlns "jabber:iq:register") + (cxml:with-element "username" + (cxml:text username)) + (cxml:with-element "password" + (cxml:text new-password)))) (defmethod auth-requirements ((connection connection) username) (with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth") Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.2 cl-xmpp/result.lisp:1.3 --- cl-xmpp/result.lisp:1.2 Fri Oct 28 23:04:12 2005 +++ cl-xmpp/result.lisp Fri Oct 28 23:17:59 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ +;;;; $Id: result.lisp,v 1.3 2005/10/28 21:17:59 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -295,6 +295,19 @@ (let ((id (intern (string-upcase (value (get-attribute object "id"))) :keyword))) (case id (:roster_1 (make-roster object)) + (:reg2 (if (string-equal (value (get-attribute object "type")) "result") + :registration-successful + (make-error (get-element object "error")))) + (:unreg_1 (if (string-equal (value (get-attribute object "type")) "result") + :registration-cancellation-successful + (make-error (get-element object "error")))) + (:change1 (if (string-equal (value (get-attribute object "type")) "result") + :password-changed-succesfully + (make-error (get-element object "error")))) + (:error (make-error (get-element object "error"))) + (:auth2 (if (string-equal (value (get-attribute object "type")) "result") + :authentication-successful + (make-error (get-element object "error")))) (t name)))) (defmethod xml-element-to-event ((object xml-element) (name (eql :error)))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.asd cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/package.lisp cl-xmpp/result.lisp cl-xmpp/utility.lisp cl-xmpp/variable.lisp
by eenge＠common-lisp.net 28 Oct '05

28 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv31537 Modified Files: cl-xmpp.asd cl-xmpp.lisp cxml.lisp package.lisp result.lisp utility.lisp variable.lisp Log Message: integrating new stanza-hanlding code from david lichteblau (thanks!) Date: Fri Oct 28 23:04:12 2005 Author: eenge Index: cl-xmpp/cl-xmpp.asd diff -u cl-xmpp/cl-xmpp.asd:1.2 cl-xmpp/cl-xmpp.asd:1.3 --- cl-xmpp/cl-xmpp.asd:1.2 Fri Oct 28 15:18:04 2005 +++ cl-xmpp/cl-xmpp.asd Fri Oct 28 23:04:12 2005 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp.asd,v 1.2 2005/10/28 13:18:04 eenge Exp $ +;;;; $Id: cl-xmpp.asd,v 1.3 2005/10/28 21:04:12 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -17,7 +17,7 @@ :version "0.0.1" :licence "MIT" :description "Common Lisp XMPP client implementation" - :depends-on (:sb-bsd-sockets :cxml) + :depends-on (#+sbcl :sb-bsd-sockets :cxml) :components ((:file "package") (:file "variable" :depends-on ("package")) Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.1.1.1 cl-xmpp/cl-xmpp.lisp:1.2 --- cl-xmpp/cl-xmpp.lisp:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/cl-xmpp.lisp Fri Oct 28 23:04:12 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.1.1.1 2005/10/28 13:16:02 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -14,6 +14,9 @@ :accessor socket :initarg :socket :initform nil) + (server-xstream + :accessor server-xstream + :initform nil) (hostname :accessor hostname :initarg :hostname @@ -36,7 +39,10 @@ (format stream " (open)") (format stream " (closed)")))) -;;; XXX: "not-a-pathname"? blech. +;;; XXX: "not-a-pathname"? Need it because CXML wants to call +;;; pathname on the stream and without one it returns NIL which +;;; CXML breaks on. +#+sbcl (defun connect (&key (hostname *default-hostname*) (port *default-port*)) "Open TCP connection to hostname." (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp)) @@ -53,12 +59,27 @@ :hostname hostname :port port))) +#+allegro +(defun connect (&key (hostname *default-hostname*) (port *default-port*)) + "Open TCP connection to hostname." + (let ((socket (socket:make-socket :remote-host hostname :remote-port port))) + ;; fixme: (setf (sb-bsd-sockets:non-blocking-mode socket) t) + (make-instance 'connection + :server-stream socket + :socket socket + :hostname hostname + :port port))) + (defmethod make-connection-and-debug-stream ((connection connection)) "Helper function to make a broadcast stream for this connection's server-stream and the *debug-stream*." ;;; Hook onto this if you want the output written by CXML to be ;;; sent to one of your streams for debugging or whatever. - (make-broadcast-stream (server-stream connection))) + ;(make-broadcast-stream (server-stream connection))) + ;; FIXME: BROADCAST-STREAM doesn't actually work here because it is a + ;; character stream, not a binary stream. Need to come up with a + ;; replacement. + (server-stream connection)) (defmethod connectedp ((connection connection)) "Returns t if `connection' is connected to a server and is ready for @@ -67,19 +88,53 @@ (and (streamp stream) (open-stream-p stream)))) +#+sbcl (defmethod disconnect ((connection connection)) "Disconnect TCP connection." (sb-bsd-sockets:socket-close (socket connection)) connection) -(defmethod receive-stanza-loop ((connection connection) - &key stanza-callback init-callback) - (let ((handler (make-instance 'stanza-handler))) - (when stanza-callback - (setf (stanza-callback handler) stanza-callback)) - (when init-callback - (setf (init-callback handler) init-callback)) - (cxml:parse-stream (server-stream connection) handler))) +#+allegro +(defmethod disconnect ((connection connection)) + "Disconnect TCP connection." + (close (socket connection)) + connection) + +(defmethod receive-stanza-loop ((connection connection) &key + (stanza-callback 'default-stanza-callback) + (init-callback 'default-init-callback)) +; (let ((handler (make-instance 'stanza-handler))) +; (when stanza-callback +; (setf (stanza-callback handler) stanza-callback)) +; (when init-callback +; (setf (init-callback handler) init-callback)) +; (cxml:parse-stream (server-stream connection) handler))) + (loop + (let* ((stanza (read-stanza connection)) + (tagname (dom:tag-name (dom:document-element stanza)))) + (cond + ((equal tagname "stream:stream") + (when init-callback + (funcall init-callback stanza))) + ((equal tagname "stream:error") + (default-stanza-callback stanza) ;print it + (error "received error")) + (t + (when stanza-callback + (funcall stanza-callback stanza))))))) + +(defun read-stanza (connection) + (unless (server-xstream connection) + (setf (server-xstream connection) + (cxml:make-xstream (server-stream connection)))) + (force-output (server-stream connection)) + (catch 'stanza + (let ((cxml::*default-namespace-bindings* + (acons "stream" + "http://etherx.jabber.org/streams" + cxml::*default-namespace-bindings*))) + (cxml::parse-xstream (server-xstream connection) + (make-instance 'stanza-handler))))) ;;; This is mostly useful for debugging output from servers. (defmethod get-stream-reply ((connection connection)) @@ -103,6 +158,22 @@ "Read reply from connection's socket and return it as a string." (get-output-stream-string (get-stream-reply connection))) +(defmethod receive-stanzas ((connection connection) &key dom-repr) + "Read reply from connection's socket and parse the result +as XML data. Return DOM object. If dom-repr is T the return +value will be a DOM-ish structure of xml-element/xml-attribute +objects." + (let ((objects nil) + (xml-string (get-string-reply connection))) + (handler-case (push (cxml::parse-string xml-string + (make-instance 'stanza-handler)) + objects) + (type-error () objects) + (sb-kernel::arg-count-error () objects)) + (let ((result (remove nil (flatten (parse-result objects))))) + (if dom-repr + result + (dom-to-event result))))) (defmacro with-xml-stream ((stream connection) &body body) "Helper macro to make it easy to control outputting XML @@ -115,6 +186,7 @@ "Write string to stream as a sequence of bytes and not characters." (write-sequence (string-to-array string) stream) + (finish-output stream) string) (defmethod begin-xml-stream ((connection connection)) @@ -136,14 +208,23 @@ (defmacro with-iq ((connection &key id (type "get")) &body body) "Macro to make it easier to write IQ stanzas." - `(progn - (cxml:with-xml-output (cxml:make-octet-stream-sink - (make-connection-and-debug-stream ,connection)) - (cxml:with-element "iq" - (cxml:attribute "id" ,id) - (cxml:attribute "type" ,type) - ,@body)) - ,connection)) +; `(progn +; (cxml:with-xml-output (cxml:make-octet-stream-sink +; (make-connection-and-debug-stream ,connection)) +; (cxml:with-element "iq" +; (cxml:attribute "id" ,id) +; (cxml:attribute "type" ,type) +; ,@body)) +; ,connection)) + (let ((stream (gensym))) + `(let ((,stream (make-connection-and-debug-stream ,connection))) + (cxml:with-xml-output (cxml:make-octet-stream-sink ,stream) + (cxml:with-element "iq" + (cxml:attribute "id" ,id) + (cxml:attribute "type" ,type) + ,@body)) + (finish-output ,stream) + ,connection))) (defmacro with-iq-query ((connection &key xmlns id (type "get")) &body body) "Macro to make it easier to write QUERYs." Index: cl-xmpp/cxml.lisp diff -u cl-xmpp/cxml.lisp:1.1.1.1 cl-xmpp/cxml.lisp:1.2 --- cl-xmpp/cxml.lisp:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/cxml.lisp Fri Oct 28 23:04:12 2005 @@ -7,15 +7,7 @@ (in-package :xmpp) (defclass stanza-handler (cxml:sax-proxy) - ((init-callback - :initarg :init-callback - :accessor init-callback - :initform 'default-init-callback) - (stanza-callback - :initarg :stanza-callback - :accessor stanza-callback - :initform 'default-stanza-callback) - (depth + ((depth :initform 0 :accessor depth))) @@ -28,19 +20,31 @@ (defmethod sax:start-element ((handler stanza-handler) uri lname qname attrs) (declare (ignore uri lname)) (when (eql (depth handler) 0) - (if (and qname (string-equal "stream:stream" 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)) - (element (dom:create-element document qname)) - (callback (init-callback handler))) - (dolist (attribute attrs) - (let ((name (sax::attribute-qname attribute)) - (value (sax::attribute-value attribute))) - (dom:set-attribute element name value))) - (when callback - (funcall callback element))) - (start-sax-document handler))) +; (if (and qname (string-equal "stream:stream" 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)) +; (element (dom:create-element document qname)) +; (callback (init-callback handler))) +; (dolist (attribute attrs) +; (let ((name (sax::attribute-qname attribute)) +; (value (sax::attribute-value attribute))) +; (dom:set-attribute element name value))) +; (when callback +; (funcall callback element))) +; (start-sax-document handler))) + (if (string-equal "stream:stream" 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)) + (element (dom:create-element document qname))) + (dom:append-child document element) + (dolist (attribute attrs) + (let ((name (sax::attribute-qname attribute)) + (value (sax::attribute-value attribute))) + (dom:set-attribute element name value))) + (throw 'stanza document)) + (start-sax-document handler))) (incf (depth handler)) (call-next-method)) @@ -53,10 +57,13 @@ (declare (ignore uri lname qname)) (decf (depth handler)) (call-next-method) - (let ((callback (stanza-callback handler))) - (when (and (eql (depth handler) 0) callback) - (funcall callback (dom-impl::document - (cxml:proxy-chained-handler handler)))))) +; (let ((callback (stanza-callback handler))) +; (when (and (eql (depth handler) 0) callback) +; (funcall callback (dom-impl::document +; (cxml:proxy-chained-handler handler)))))) + (when (eql (depth handler) 0) + (throw 'stanza + (dom-impl::document (cxml:proxy-chained-handler handler))))) ;;; The default implementation of this function in CXML does not ;;; check whether or not the nodelist is NIL and dom:length et al Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.1.1.1 cl-xmpp/package.lisp:1.2 --- cl-xmpp/package.lisp:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/package.lisp Fri Oct 28 23:04:12 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.1.1.1 2005/10/28 13:16:02 eenge Exp $ +;;;; $Id: package.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -25,5 +25,6 @@ ;; event interface :event :message :to :from :body + :handle ;; variables :*default-port :*default-hostname*))) Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.1 cl-xmpp/result.lisp:1.2 --- cl-xmpp/result.lisp:1.1 Fri Oct 28 15:18:04 2005 +++ cl-xmpp/result.lisp Fri Oct 28 23:04:12 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.1 2005/10/28 13:18:04 eenge Exp $ +;;;; $Id: result.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -144,6 +144,45 @@ xml-element)) ;; +;; Error +;; + +(defclass xmpp-protocol-error () + ((code + :accessor code + :initarg :code) + (name + :accessor name + :initarg :name))) + +(defclass xmpp-protocol-error-modify (xmpp-protocol-error) ()) +(defclass xmpp-protocol-error-cancel (xmpp-protocol-error) ()) +(defclass xmpp-protocol-error-wait (xmpp-protocol-error) ()) +(defclass xmpp-protocol-error-auth (xmpp-protocol-error) ()) + +(defun get-error-data (name) + (assoc name *errors*)) + +(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)))) + +;;; If an error element occurs within a, say, message element +;;; do I want to include the error within the message, the +;;; message within the error, or discard the message and just +;;; return the error? I'm thinking the second option. +(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))) + (make-instance class :code code :name name :type type))) + +;; ;; Event interface ;; @@ -187,17 +226,30 @@ :accessor from :initarg :from :initform nil) + (show + :accessor show + :initarg :show + :initform nil) (type- :accessor type- :initarg :type- :initform nil))) -;;; XXX: Is the ask attribute of the <presence/> element part of the RFC? +(defmethod print-object ((object presence) stream) + "Print the object for the Lisp reader." + (print-unreadable-object (object stream :type t :identity t) + (format stream "from:~a show:~a" (from object) (show object)))) + +;;; XXX: Is the ask attribute of the <presence/> element part of the RFC/JEP? (defmethod xml-element-to-event ((object xml-element) (name (eql :presence))) - (make-instance 'presence - :from (value (get-attribute object "from")) - :to (value (get-attribute object "to")) - :type (value (get-attribute object "type")))) + (let ((show (get-element object "show"))) + (when show + (setq show (data (get-element show "#text")))) + (make-instance 'presence + :from (value (get-attribute object "from")) + :to (value (get-attribute object "to")) + :show show + :type- (value (get-attribute object "type"))))) (defclass contact () ((jid @@ -217,7 +269,7 @@ (print-unreadable-object (object stream :type t :identity t) (format stream "~a (~a)" (jid object) (name object)))) -(defclass roster () +(defclass roster (event) ((items :accessor items :initarg :items @@ -244,9 +296,9 @@ (case id (:roster_1 (make-roster object)) (t name)))) - ;;; XXX: should catch stream errors here. not sure if i want to - ;;; make them into conditions and signal them or just make instances - ;;; of an error class and return them. leaning towards latter. + +(defmethod xml-element-to-event ((object xml-element) (name (eql :error))) + (make-error object)) (defmethod xml-element-to-event ((object xml-element) name) name) @@ -258,3 +310,12 @@ (xml-element-to-event object (intern (string-upcase (name object)) :keyword))) +;; +;; Handle +;; + +(defmethod handle ((object list)) + (mapc #'handle object)) + +(defmethod handle (object) + (format t "~&Received: ~a~%" object)) \ No newline at end of file Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.1.1.1 cl-xmpp/utility.lisp:1.2 --- cl-xmpp/utility.lisp:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/utility.lisp Fri Oct 28 23:04:12 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.1.1.1 2005/10/28 13:16:02 eenge Exp $ +;;;; $Id: utility.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -23,8 +23,11 @@ (setf (aref array position) (char-code (aref string position)))) array)) -(defun default-stanza-callback (stanza) - (format t "default-stanza-callback:~a~%" stanza)) +(defun default-stanza-callback (stanza &key dom-repr) + (let ((result (parse-result stanza))) + (if dom-repr + result + (handle (dom-to-event result))))) (defun default-init-callback (stanza) (format t "default-init-callback:~a~%" stanza)) Index: cl-xmpp/variable.lisp diff -u cl-xmpp/variable.lisp:1.1.1.1 cl-xmpp/variable.lisp:1.2 --- cl-xmpp/variable.lisp:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/variable.lisp Fri Oct 28 23:04:12 2005 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.1.1.1 2005/10/28 13:16:02 eenge Exp $ +;;;; $Id: variable.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,4 +8,29 @@ (defvar *debug-stream* *standard-output*) (defvar *default-port* 5222) -(defvar *default-hostname* "localhost") \ No newline at end of file +(defvar *default-hostname* "localhost") + +(defvar *errors* + '((:bad-request 'modiy 400) + (:conflict 'cancel 409) + (:feature-not-implemented 'cancel 501) + (:forbidden 'auth 403) + (:gone 'modify 302) + (:internal-server-error 'wait 500) + (:item-not-found 'cancel 404) + (:jid-malformed 'modify 400) + (:not-acceptable 'modify 406) + (:not-allowed 'cancel 405) + (:not-authorized 'auth 401) + (:payment-required 'auth 402) + (:recipient-unavailable 'wait 404) + (:redirect 'modify 302) + (:registration-required 'auth 407) + (:remote-server-not-found 'cancel 404) + (:remote-server-timeout 'wait 504) + (:resource-constraint 'wait 500) + (:service-unavailable 'cancel 503) + (:subscription-required 'auth 407) + (:undefined-condition 'any 500) + (:unexpected-request 'wait 400))) +

1 0

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

28 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv10223 Modified Files: index.html Log Message: adding comment about jep 0073 Date: Fri Oct 28 18:10:26 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.7 public_html/index.html:1.8 --- public_html/index.html:1.7 Fri Oct 28 18:06:10 2005 +++ public_html/index.html Fri Oct 28 18:10:26 2005 @@ -19,7 +19,8 @@ <p>The author is still considering whether or not to implement <a href="http://www.jabber.org/jeps">Jabber Enhancement Proposals</a> -in addition to the RFCs.</p> +in addition to the RFCs. (Specifically, I am wondering whether or not to +implement <a href="http://www.jabber.org/jeps/jep-0073.html">JEP-0073: Basic IM Protocol Suite</a>.)</p> <p>Currently, you can chat, manage your contacts, roster and presence information using this library. The code was developed

1 0

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

28 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv10087 Modified Files: index.html Log Message: *** empty log message *** Date: Fri Oct 28 18:06:16 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.6 public_html/index.html:1.7 --- public_html/index.html:1.6 Fri Oct 28 16:19:05 2005 +++ public_html/index.html Fri Oct 28 18:06:10 2005 @@ -17,17 +17,11 @@ servers use to communicate with eachother (including <a href="http://talk.google.com/">Google Talk</a>).</p> - <p>There are many features currently in use by the Jabber -community (forms, XHTML message bodies, query extensions, -file transfer and discovery options) which are specified as -<a href="http://www.jabber.org/jeps">Jabber Enhancement Proposals</a> -but this library does not implement these. If they in the future become -RFCs published by the XMPP working group they will be included -in the library but until then I (Erik Enge) recommend you implement -your own cl-jabber ontop of cl-xmpp and move functionality from -the former to the latter as the JEPs become RFCs.</p> + <p>The author is still considering whether or not +to implement <a href="http://www.jabber.org/jeps">Jabber Enhancement Proposals</a> +in addition to the RFCs.</p> - <p>That said, you can still chat, manage your contacts, roster + <p>Currently, you can chat, manage your contacts, roster and presence information using this library. The code was developed under <a href="http://www.sbcl.org">SBCL</a> and currently does not work on any other implementation due to the fact that the socket

1 0

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

28 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv2337 Modified Files: index.html Log Message: forgot some markup Date: Fri Oct 28 16:19:05 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.5 public_html/index.html:1.6 --- public_html/index.html:1.5 Fri Oct 28 16:17:29 2005 +++ public_html/index.html Fri Oct 28 16:19:05 2005 @@ -40,13 +40,17 @@ <h2>Requirements</h2> <div class="level"> + <ul> <li>A recent SBCL (need 16bit wide characters)</li> <li><a href="http://common-lisp.net/project/cxml">cxml</a></li> + </ul> </div> <h2>News</h2> <div class="level"> + <ul> <li>Version 0.1.0 released (initial release)</li> + </ul> </div> <h2>Features</h2>

1 0

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

28 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv2314 Modified Files: index.html Log Message: adding requirements Date: Fri Oct 28 16:17:29 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.4 public_html/index.html:1.5 --- public_html/index.html:1.4 Fri Oct 28 15:48:28 2005 +++ public_html/index.html Fri Oct 28 16:17:29 2005 @@ -38,6 +38,12 @@ 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"> + <li>A recent SBCL (need 16bit wide characters)</li> + <li><a href="http://common-lisp.net/project/cxml">cxml</a></li> + </div> + <h2>News</h2> <div class="level"> <li>Version 0.1.0 released (initial release)</li>

1 0

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

28 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv32398 Modified Files: index.html Log Message: *** empty log message *** Date: Fri Oct 28 15:48:28 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.3 public_html/index.html:1.4 --- public_html/index.html:1.3 Fri Oct 28 15:47:59 2005 +++ public_html/index.html Fri Oct 28 15:48:28 2005 @@ -104,7 +104,7 @@ ;; then sit back and watch the messages roll in: * (xmpp:receive-stanza-loop connection) -#>MESSAGE from=username@hostname to=me@myserver< +#<MESSAGE from=username@hostname to=me@myserver> [....] ;; That's it. Interrupt the loop to issue other commands, eg:

1 0