- cl-xmpp-cvs@common-lisp.net - mailman3.common-lisp.net

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

10 Nov '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv19710 Modified Files: index.html Log Message: adding link to mailinglist archives Date: Thu Nov 10 22:17:14 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.15 public_html/index.html:1.16 --- public_html/index.html:1.15 Mon Oct 31 22:10:34 2005 +++ public_html/index.html Thu Nov 10 22:17:13 2005 @@ -82,7 +82,7 @@ <div class="level"> <p>Questions, feature requests, and bug-reports are welcome on <tt><a href="mailto:cl-xmpp-devel@common-lisp.net"> - cl-xmpp-devel(a)common-lisp.net</a></tt>.</p> + cl-xmpp-devel(a)common-lisp.net</a></tt> (<a href="http://common-lisp.net/pipermail/cl-xmpp-devel/">archives</a>.</p> </div>

1 0

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

10 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv16485 Modified Files: utility.lisp Log Message: deleted some functions from utility.lisp which are now in ironclad 0.10 Date: Thu Nov 10 21:41:28 2005 Author: eenge Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.5 cl-xmpp/utility.lisp:1.6 --- cl-xmpp/utility.lisp:1.5 Mon Oct 31 22:07:15 2005 +++ cl-xmpp/utility.lisp Thu Nov 10 21:41:28 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.5 2005/10/31 21:07:15 eenge Exp $ +;;;; $Id: utility.lisp,v 1.6 2005/11/10 20:41:28 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -21,26 +21,10 @@ (setf (aref array position) (char-code (aref string position)))) array)) -(defun hex-array-to-ascii-string (array) - (let ((string (make-string 0))) - (dotimes (position (length array)) - (let ((element (aref array position)) - (*print-base* 16)) - (setq string (fmt "~a~a" string element)))) ; probably inefficient - string)) - -;;; borrowed from ironclad, so Copyright (C) 2004 Nathan Froyd -(defun ascii-string-to-byte-array (string) - (let ((vec (make-array (length string) :element-type '(unsigned-byte 8)))) - (dotimes (i (length string) vec) - (let ((byte (char-code (char string i)))) - (assert (< byte 256)) - (setf (aref vec i) byte))))) - (defun digestify-string (string) - (hex-array-to-ascii-string + (ironclad:byte-array-to-hex-string (ironclad:digest-sequence - :sha1 (ascii-string-to-byte-array string)))) + :sha1 (ironclad:ascii-string-to-byte-array string)))) (defun make-digest-password (stream-id password) (string-downcase (digestify-string (fmt "~a~a" stream-id password))))

1 0

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

07 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv19888 Modified Files: package.lisp Log Message: nickname xmpp had gone missing, readded Date: Mon Nov 7 20:15:51 2005 Author: eenge Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.4 cl-xmpp/package.lisp:1.5 --- cl-xmpp/package.lisp:1.4 Thu Nov 3 21:55:11 2005 +++ cl-xmpp/package.lisp Mon Nov 7 20:15:51 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.4 2005/11/03 20:55:11 eenge Exp $ +;;;; $Id: package.lisp,v 1.5 2005/11/07 19:15:51 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -10,6 +10,7 @@ (:use :cl #+allegro :socket #+openmcl :ccl) + (:nicknames :xmpp) (:export ;; connection-related :connect :disconnect :socket :stream- :hostname :port :connectedp

1 0

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

03 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv2289 Modified Files: cl-xmpp.lisp package.lisp Log Message: adding openmcl support from lemonodor Date: Thu Nov 3 21:55:11 2005 Author: eenge Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.7 cl-xmpp/cl-xmpp.lisp:1.8 --- cl-xmpp/cl-xmpp.lisp:1.7 Mon Oct 31 22:07:15 2005 +++ cl-xmpp/cl-xmpp.lisp Thu Nov 3 21:55:10 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.8 2005/11/03 20:55:10 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -63,7 +63,8 @@ :socket socket :hostname hostname :port port)) - #+allegro (let ((socket (socket:make-socket :remote-host hostname :remote-port port))) + #+(or allegro openmcl) + (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 @@ -95,7 +96,7 @@ (defmethod disconnect ((connection connection)) "Disconnect TCP connection." #+sbcl (sb-bsd-sockets:socket-close (socket connection)) - #+(or allegro lispworks) (close (socket connection)) + #+(or allegro openmcl lispworks) (close (socket connection)) connection) ;; Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.3 cl-xmpp/package.lisp:1.4 --- cl-xmpp/package.lisp:1.3 Sat Oct 29 19:25:04 2005 +++ cl-xmpp/package.lisp Thu Nov 3 21:55:11 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.3 2005/10/29 17:25:04 eenge Exp $ +;;;; $Id: package.lisp,v 1.4 2005/11/03 20:55:11 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -7,8 +7,9 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :cl-xmpp - (:use :cl) - (:nicknames :xmpp) + (:use :cl + #+allegro :socket + #+openmcl :ccl) (:export ;; connection-related :connect :disconnect :socket :stream- :hostname :port :connectedp

1 0

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

31 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv15264 Modified Files: index.html Log Message: up'ing to 0.5.0 Date: Mon Oct 31 22:10:34 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.14 public_html/index.html:1.15 --- public_html/index.html:1.14 Mon Oct 31 18:08:33 2005 +++ public_html/index.html Mon Oct 31 22:10:34 2005 @@ -7,7 +7,7 @@ <body> <div class="header"> - <h1>cl-xmpp 0.4.0</h1> + <h1>cl-xmpp 0.5.0</h1> </div> <div class="body"> @@ -32,12 +32,14 @@ <ul> <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> + <li><a href="http://cliki.net/ironclad">Ironclad</a></li> </ul> </div> <h2>News</h2> <div class="level"> <ul> + <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> <li>Version 0.2.0 released (JEP 0073 support)</li>

1 0

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

31 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv15203 Modified Files: cl-xmpp.asd cl-xmpp.lisp result.lisp utility.lisp Log Message: now depending on ironclad for sha1 generation of digest password Date: Mon Oct 31 22:07:15 2005 Author: eenge Index: cl-xmpp/cl-xmpp.asd diff -u cl-xmpp/cl-xmpp.asd:1.3 cl-xmpp/cl-xmpp.asd:1.4 --- cl-xmpp/cl-xmpp.asd:1.3 Fri Oct 28 23:04:12 2005 +++ cl-xmpp/cl-xmpp.asd Mon Oct 31 22:07:14 2005 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp.asd,v 1.3 2005/10/28 21:04:12 eenge Exp $ +;;;; $Id: cl-xmpp.asd,v 1.4 2005/10/31 21:07:14 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 (#+sbcl :sb-bsd-sockets :cxml) + :depends-on (#+sbcl :sb-bsd-sockets :cxml :ironclad) :components ((:file "package") (:file "variable" :depends-on ("package")) Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.6 cl-xmpp/cl-xmpp.lisp:1.7 --- cl-xmpp/cl-xmpp.lisp:1.6 Mon Oct 31 18:02:04 2005 +++ cl-xmpp/cl-xmpp.lisp Mon Oct 31 22:07:15 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -17,6 +17,12 @@ (server-xstream :accessor server-xstream :initform nil) + (stream-id + :accessor stream-id + :initarg :stream-id + :initform nil + :documentation "Stream ID attribute of the <stream> +element as gotten when we call BEGIN-XML-STREAM.") (hostname :accessor hostname :initarg :hostname @@ -92,17 +98,137 @@ #+(or allegro lispworks) (close (socket connection)) connection) +;; +;; Handle +;; + +(defmethod handle ((connection connection) (list list)) + (dolist (object list) + (handle connection object))) + +(defmethod handle ((connection connection) object) + (format t "~&Received: ~a~%" object)) + +;; +;; Produce DOM-ish structure from the XML DOM returned by cxml. +;; + +(defmethod parse-result ((connection connection) (objects list)) + (dolist (object objects) + (parse-result connection object))) + +(defmethod parse-result ((connection connection) (document dom-impl::document)) + (let (objects) + (dom:map-node-list #'(lambda (node) + (push (parse-result connection node) objects)) + (dom:child-nodes document)) + objects)) + +(defmethod parse-result ((connection connection) (attribute dom-impl::attribute)) + (let* ((name (dom:node-name attribute)) + (value (dom:value attribute)) + (xml-attribute + (make-instance 'xml-attribute + :name name :value value :node attribute))) + xml-attribute)) + +(defmethod parse-result ((connection connection) (node dom-impl::character-data)) + (let* ((name (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)) + (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))) + (dom:do-node-list (child (dom:child-nodes node)) + (push (parse-result connection child) (elements xml-element))) + xml-element)) + + +(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")) + (make-error (get-element object :error)) + (case id + (:error (make-error (get-element object :error))) + (:roster_1 (make-roster object)) + (:reg2 :registration-successful) + (:unreg_1 :registration-cancellation-successful) + (:change1 :password-changed-succesfully) + (:auth2 :authentication-successful) + (t (cond + ((member id '(info1 info2 info3)) + (make-disco-info (get-element object :query))) + ((member id '(items1 items2 items3 items4)) + (make-disco-items (get-element object :query))))))))) + +(defmethod xml-element-to-event ((connection connection) + (object xml-element) (name (eql :error))) + (make-error object)) + +(defmethod xml-element-to-event ((connection connection) + (object xml-element) (name (eql :stream\:error))) + (make-error object)) + +(defmethod xml-element-to-event ((connection connection) + (object xml-element) (name (eql :stream\:stream))) + (setf (stream-id connection) (value (get-attribute object :id))) + object) + +(defmethod xml-element-to-event ((connection connection) (object xml-element) name) + (declare (ignore name)) + object) + +(defmethod dom-to-event ((connection connection) (objects list)) + (let (list) + (dolist (object objects) + (push (dom-to-event connection object) list)) + list)) + +(defmethod dom-to-event ((connection connection) (object xml-element)) + (xml-element-to-event + connection object (intern (string-upcase (name object)) :keyword))) + +;;; XXX: Is the ask attribute of the <presence/> element part of the RFC/JEP? +(defmethod xml-element-to-event ((connection connection) + (object xml-element) (name (eql :presence))) + (let ((show (get-element object :show))) + (when show + (setq show (data (get-element show :\#text)))) + (make-instance 'presence + :xml-element object + :from (value (get-attribute object :from)) + :to (value (get-attribute object :to)) + :show show + :type- (value (get-attribute object :type))))) + +;;; XXX: Add support for the <thread/> element. Also note that +;;; there may be an XHTML version of the body available in the +;;; original node but as of right now I don't care about it. If +;;; you do please feel free to submit a patch. +(defmethod xml-element-to-event ((connection connection) + (object xml-element) (name (eql :message))) + (make-instance 'message + :xml-element object + :from (value (get-attribute object :from)) + :to (value (get-attribute object :to)) + :body (data (get-element (get-element object :body) :\#text)))) + +;; +;; Receive stanzas +;; + (defmethod receive-stanza-loop ((connection connection) &key (stanza-callback 'default-stanza-callback) - (init-callback 'default-init-callback) dom-repr) (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 connection :dom-repr dom-repr))) ((equal tagname "stream:error") (when stanza-callback (funcall stanza-callback stanza connection :dom-repr dom-repr)) @@ -221,11 +347,17 @@ (with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth") (cxml:with-element "username" (cxml:text username)))) -;;; XXX: Add support for digest authentication. -(defmethod auth ((connection connection) username password resource) +(defmethod auth ((connection connection) username password resource &key digestp) (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)) + (if digestp + (if (stream-id connection) + (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 "password" (cxml:text password))) (cxml:with-element "resource" (cxml:text resource)))) (defmethod presence ((connection connection) &key type to) Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.6 cl-xmpp/result.lisp:1.7 --- cl-xmpp/result.lisp:1.6 Mon Oct 31 18:02:04 2005 +++ cl-xmpp/result.lisp Mon Oct 31 22:07:15 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $ +;;;; $Id: result.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -106,44 +106,6 @@ (format stream "~a=~a" (name object) (value object)))) ;; -;; Produce DOM-ish structure from the XML DOM returned by cxml. -;; - -(defmethod parse-result ((objects list)) - (mapcar #'parse-result objects)) - -(defmethod parse-result ((document dom-impl::document)) - (let (objects) - (dom:map-node-list #'(lambda (node) - (push (parse-result node) objects)) - (dom:child-nodes document)) - objects)) - -(defmethod parse-result ((attribute dom-impl::attribute)) - (let* ((name (dom:node-name attribute)) - (value (dom:value attribute)) - (xml-attribute - (make-instance 'xml-attribute - :name name :value value :node attribute))) - xml-attribute)) - -(defmethod parse-result ((node dom-impl::character-data)) - (let* ((name (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 ((node dom-impl::node)) - (let* ((name (intern (string-upcase (dom:node-name node)) :keyword)) - (xml-element (make-instance 'xml-element :name name :node node))) - (dom:do-node-list (attribute (dom:attributes node)) - (push (parse-result attribute) (attributes xml-element))) - (dom:do-node-list (child (dom:child-nodes node)) - (push (parse-result child) (elements xml-element))) - xml-element)) - -;; ;; Event interface ;; @@ -172,17 +134,6 @@ (print-unreadable-object (object stream :type t :identity t) (format stream "to:~a from:~a" (to object) (from object)))) -;;; XXX: Add support for the <thread/> element. Also note that -;;; there may be an XHTML version of the body available in the -;;; original node but as of right now I don't care about it. If -;;; you do please feel free to submit a patch. -(defmethod xml-element-to-event ((object xml-element) (name (eql :message))) - (make-instance 'message - :xml-element object - :from (value (get-attribute object :from)) - :to (value (get-attribute object :to)) - :body (data (get-element (get-element object :body) :\#text)))) - (defclass presence (event) ((to :accessor to @@ -206,18 +157,6 @@ (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))) - (let ((show (get-element object :show))) - (when show - (setq show (data (get-element show :\#text)))) - (make-instance 'presence - :xml-element object - :from (value (get-attribute object :from)) - :to (value (get-attribute object :to)) - :show show - :type- (value (get-attribute object :type))))) - (defclass contact () ((jid :accessor jid @@ -349,6 +288,11 @@ :accessor name :initarg :name))) +(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)))) + (defclass xmpp-protocol-error-modify (xmpp-protocol-error) ()) (defclass xmpp-protocol-error-cancel (xmpp-protocol-error) ()) (defclass xmpp-protocol-error-wait (xmpp-protocol-error) ()) @@ -372,48 +316,3 @@ (code (third data)) (class (map-error-type-to-class type))) (make-instance class :code code :name name :xml-element object))) - -(defmethod xml-element-to-event ((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")) - (make-error (get-element object :error)) - (case id - (:error (make-error (get-element object :error))) - (:roster_1 (make-roster object)) - (:reg2 :registration-successful) - (:unreg_1 :registration-cancellation-successful) - (:change1 :password-changed-succesfully) - (:auth2 :authentication-successful) - (t (cond - ((member id '(info1 info2 info3)) - (make-disco-info (get-element object :query))) - ((member id '(items1 items2 items3 items4)) - (make-disco-items (get-element object :query))))))))) - -(defmethod xml-element-to-event ((object xml-element) (name (eql :error))) - (make-error object)) - -(defmethod xml-element-to-event ((object xml-element) (name (eql :stream\:error))) - (make-error object)) - -(defmethod xml-element-to-event ((object xml-element) name) - (declare (ignore name)) - object) - -(defmethod dom-to-event ((object list)) - (mapcar #'dom-to-event object)) - -(defmethod dom-to-event ((object xml-element)) - (xml-element-to-event - object (intern (string-upcase (name object)) :keyword))) - -;; -;; Handle -;; - -(defmethod handle ((connection connection) (object list)) - (dolist (object list) - (handle connection object))) - -(defmethod handle ((connection connection) object) - (format t "~&Received: ~a~%" object)) Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.4 cl-xmpp/utility.lisp:1.5 --- cl-xmpp/utility.lisp:1.4 Mon Oct 31 18:02:04 2005 +++ cl-xmpp/utility.lisp Mon Oct 31 22:07:15 2005 @@ -1,10 +1,13 @@ -;;;; $Id: utility.lisp,v 1.4 2005/10/31 17:02:04 eenge Exp $ +;;;; $Id: utility.lisp,v 1.5 2005/10/31 21:07:15 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :xmpp) +(defmacro fmt (string &rest args) + `(format nil ,string ,@args)) + (defun flatten (list) (cond ((typep list 'atom) list) @@ -12,25 +15,40 @@ (flatten (cdr list)))) ((typep (car list) 'list) (flatten (append (car list) (cdr list)))))) -(defun string-to-array (string) - (let ((array (make-array (length string)))) +(defun string-to-array (string &rest args) + (let ((array (apply #'make-array (length string) args))) (dotimes (position (length string)) (setf (aref array position) (char-code (aref string position)))) array)) -(defun default-stanza-callback (stanza connection &key dom-repr) - (let ((result (parse-result stanza))) - (if dom-repr - (handle connection result) - (handle connection (dom-to-event result))))) +(defun hex-array-to-ascii-string (array) + (let ((string (make-string 0))) + (dotimes (position (length array)) + (let ((element (aref array position)) + (*print-base* 16)) + (setq string (fmt "~a~a" string element)))) ; probably inefficient + string)) + +;;; borrowed from ironclad, so Copyright (C) 2004 Nathan Froyd +(defun ascii-string-to-byte-array (string) + (let ((vec (make-array (length string) :element-type '(unsigned-byte 8)))) + (dotimes (i (length string) vec) + (let ((byte (char-code (char string i)))) + (assert (< byte 256)) + (setf (aref vec i) byte))))) + +(defun digestify-string (string) + (hex-array-to-ascii-string + (ironclad:digest-sequence + :sha1 (ascii-string-to-byte-array string)))) + +(defun make-digest-password (stream-id password) + (string-downcase (digestify-string (fmt "~a~a" stream-id password)))) -;; um, refactor? -(defun default-init-callback (stanza connection &key dom-repr) - (let ((result (parse-result stanza))) +(defun default-stanza-callback (stanza connection &key dom-repr) + (let ((result (parse-result connection stanza))) (if dom-repr (handle connection result) - (handle connection (dom-to-event result))))) + (handle connection (dom-to-event connection result))))) -(defmacro fmt (string &rest args) - `(format nil ,string ,@args))

1 0

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

31 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv30335 Modified Files: index.html Log Message: upping version number Date: Mon Oct 31 18:08:33 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.13 public_html/index.html:1.14 --- public_html/index.html:1.13 Mon Oct 31 18:04:08 2005 +++ public_html/index.html Mon Oct 31 18:08:33 2005 @@ -7,7 +7,7 @@ <body> <div class="header"> - <h1>cl-xmpp 0.3.0</h1> + <h1>cl-xmpp 0.4.0</h1> </div> <div class="body">

1 0

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

31 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv30035 Modified Files: index.html Log Message: fixing missing connection in xmpp:handle signature in example Date: Mon Oct 31 18:04:08 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.12 public_html/index.html:1.13 --- public_html/index.html:1.12 Mon Oct 31 18:02:20 2005 +++ public_html/index.html Mon Oct 31 18:04:08 2005 @@ -117,7 +117,7 @@ ;; 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 (defmethod xmpp:handle (object) ...) to get them all. Or alternatively +;; or (defmethod xmpp:handle (connection object) ...) to get them all. Or alternatively ;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects. ;; For example, if you wanted to create an annoying reply bot:

1 0

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

31 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv30017 Modified Files: README Log Message: fixing missing connection in xmpp:handle signature in example Date: Mon Oct 31 18:03:31 2005 Author: eenge Index: cl-xmpp/README diff -u cl-xmpp/README:1.2 cl-xmpp/README:1.3 --- cl-xmpp/README:1.2 Mon Oct 31 18:02:03 2005 +++ cl-xmpp/README Mon Oct 31 18:03:30 2005 @@ -33,7 +33,7 @@ ;; 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 (defmethod xmpp:handle (object) ...) to get them all. Or alternatively +;; or (defmethod xmpp:handle (connection object) ...) to get them all. Or alternatively ;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects. ;; For example, if you wanted to create an annoying reply bot:

1 0

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

31 Oct '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv29843 Modified Files: index.html Log Message: Date: Mon Oct 31 18:02:21 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.11 public_html/index.html:1.12 --- public_html/index.html:1.11 Sat Oct 29 19:30:15 2005 +++ public_html/index.html Mon Oct 31 18:02:20 2005 @@ -119,6 +119,13 @@ ;; specify an xmpp:handle method for the objects you are interested in ;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively ;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects. + +;; For example, if you wanted to create an annoying reply bot: + + * (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message)) + (xmpp:message connection (xmpp:from message) + (format nil "reply to: ~a~%" (xmpp:message object)))) + </pre> </div>

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/CREDITS cl-xmpp/README cl-xmpp/cl-xmpp.lisp cl-xmpp/result.lisp cl-xmpp/utility.lisp
by eenge＠common-lisp.net 31 Oct '05

31 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv29674 Modified Files: README cl-xmpp.lisp result.lisp utility.lisp Added Files: CREDITS Log Message: cleaning up the handling code Date: Mon Oct 31 18:02:04 2005 Author: eenge Index: cl-xmpp/README diff -u cl-xmpp/README:1.1.1.1 cl-xmpp/README:1.2 --- cl-xmpp/README:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/README Mon Oct 31 18:02:03 2005 @@ -1,27 +1,44 @@ -This is a Common Lisp implementation of the XMPP RFCs. The -implementation is currently very immature and comments are -solicited. +This is a Common Lisp implementation of the XMPP RFCs. Please +see http://common-lisp.net/project/cl-xmpp for more information. -Non-normative example: +Example: -* (defparameter *c* (xmpp:connect :hostname "my-xmpp-server")) -#<CONNECTION open> + * (require :cl-xmpp) -* (xmpp:begin-xml-stream *c*) -... output ... + * (defvar connection (xmpp:connect :hostname "jabber.org")) -* (xmpp:auth *c* "username" "password" "resource") -... output ... +;; initiate XML stream with server + * (xmpp:begin-xml-stream connection) -* (xmpp:receive-stanzas *c*) -... output ... +;; authenticate (or use xmpp:register to make an account) + * (xmpp:auth connection "username" "password" "resource") -* (xmpp:message *c* "username" "message") -... output ... +;; 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) -; let's assume a user replies to you -* (xmpp:receive-stanzas *c*) -(#<MESSAGE>) +;; send someone a message + * (xmpp:message connection "username@hostname" "what's going on?") + +;; then sit back and watch the messages roll in: + * (xmpp:receive-stanza-loop connection) +<MESSAGE from=username@hostname to=me@myserver> +[....] + +;; That's it. Interrupt the loop to issue other commands, eg: + * (xmpp:get-roster connection) + +;; or any of the other ones you may find by looking through cl-xmpp.lisp +;; and package.lisp to see which ones are exported. + +;; 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 (defmethod xmpp:handle (object) ...) to get them all. Or alternatively +;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects. + +;; For example, if you wanted to create an annoying reply bot: + + * (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message)) + (xmpp:message connection (xmpp:from message) + (format nil "reply to: ~a~%" (xmpp:message object)))) -And so on and so forth. Check cl-xmpp.lisp and package.lisp for -symbols which are exported and might be of use. \ No newline at end of file Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.5 cl-xmpp/cl-xmpp.lisp:1.6 --- cl-xmpp/cl-xmpp.lisp:1.5 Sat Oct 29 19:25:04 2005 +++ cl-xmpp/cl-xmpp.lisp Mon Oct 31 18:02:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -64,7 +64,8 @@ :socket socket :hostname hostname :port port)) - #+lispworks (let ((socket (comm:open-tcp-stream hostname port :element-type '(unsigned-byte 8)))) + #+lispworks (let ((socket (comm:open-tcp-stream hostname port + :element-type '(unsigned-byte 8)))) (make-instance 'connection :server-stream socket :socket socket @@ -101,14 +102,14 @@ (cond ((equal tagname "stream:stream") (when init-callback - (funcall init-callback stanza :dom-repr dom-repr))) + (funcall init-callback stanza connection :dom-repr dom-repr))) ((equal tagname "stream:error") (when stanza-callback - (funcall stanza-callback stanza :dom-repr dom-repr)) + (funcall stanza-callback stanza connection :dom-repr dom-repr)) (error "Received error.")) (t (when stanza-callback - (funcall stanza-callback stanza :dom-repr dom-repr))))))) + (funcall stanza-callback stanza connection :dom-repr dom-repr))))))) (defun read-stanza (connection) (unless (server-xstream connection) @@ -245,8 +246,6 @@ (cxml:with-element "body" (cxml:text body)))) connection) -;;; XXX: this one doesn't seem to work with Jabberd 1.4 -;;; (not insinuating that I've tested it with anything else). (defmethod bind ((connection connection) jid resource) (with-iq (connection :id "bind_2" :type "set") (cxml:with-element "bind" @@ -277,7 +276,7 @@ (defmethod get-roster ((connection connection)) (with-iq-query (connection :id "roster_1" :xmlns "jabber:iq:roster"))) -;;; XXX: Adding and removing from the roster is not the same as +;;; Note: Adding and removing from the roster is not the same as ;;; adding and removing subscriptions. I have not yet decided ;;; if the library should provide convenience methods for doing ;;; both actions at once. Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.5 cl-xmpp/result.lisp:1.6 --- cl-xmpp/result.lisp:1.5 Sat Oct 29 19:25:04 2005 +++ cl-xmpp/result.lisp Mon Oct 31 18:02:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $ +;;;; $Id: result.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -257,6 +257,10 @@ (items roster)))) roster)) +;; +;; Discovery +;; + (defclass identity- (event) ((category :accessor category @@ -275,8 +279,6 @@ :type- (value (get-attribute object :type-)) :name (value (get-attribute object :name)))) -;;; XXX: must think about this for another few days and then I will -;;; decide how to represent the disco#info and disco#items data. (defclass disco (event) ((identities :accessor identities @@ -371,46 +373,22 @@ (class (map-error-type-to-class type))) (make-instance class :code code :name name :xml-element object))) -;;; XXX: this is a mess with all the IFs... fix. (defmethod xml-element-to-event ((object xml-element) (name (eql :iq))) (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)))) - (:info1 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-info (get-element object :query)) - (make-error (get-element object :error)))) - (:info2 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-info (get-element object :query)) - (make-error (get-element object :error)))) - (:info3 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-info (get-element object :query)) - (make-error (get-element object :error)))) - (:items1 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (:items2 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (:items3 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (:items4 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (t object)))) + (if (not (string-equal (value (get-attribute object :type)) "result")) + (make-error (get-element object :error)) + (case id + (:error (make-error (get-element object :error))) + (:roster_1 (make-roster object)) + (:reg2 :registration-successful) + (:unreg_1 :registration-cancellation-successful) + (:change1 :password-changed-succesfully) + (:auth2 :authentication-successful) + (t (cond + ((member id '(info1 info2 info3)) + (make-disco-info (get-element object :query))) + ((member id '(items1 items2 items3 items4)) + (make-disco-items (get-element object :query))))))))) (defmethod xml-element-to-event ((object xml-element) (name (eql :error))) (make-error object)) @@ -433,8 +411,9 @@ ;; Handle ;; -(defmethod handle ((object list)) - (mapc #'handle object)) +(defmethod handle ((connection connection) (object list)) + (dolist (object list) + (handle connection object))) -(defmethod handle (object) +(defmethod handle ((connection connection) object) (format t "~&Received: ~a~%" object)) Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.3 cl-xmpp/utility.lisp:1.4 --- cl-xmpp/utility.lisp:1.3 Sat Oct 29 05:58:04 2005 +++ cl-xmpp/utility.lisp Mon Oct 31 18:02:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.3 2005/10/29 03:58:04 eenge Exp $ +;;;; $Id: utility.lisp,v 1.4 2005/10/31 17:02:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -18,18 +18,18 @@ (setf (aref array position) (char-code (aref string position)))) array)) -(defun default-stanza-callback (stanza &key dom-repr) +(defun default-stanza-callback (stanza connection &key dom-repr) (let ((result (parse-result stanza))) (if dom-repr - (handle result) - (handle (dom-to-event result))))) + (handle connection result) + (handle connection (dom-to-event result))))) ;; um, refactor? -(defun default-init-callback (stanza &key dom-repr) +(defun default-init-callback (stanza connection &key dom-repr) (let ((result (parse-result stanza))) (if dom-repr - (handle result) - (handle (dom-to-event result))))) + (handle connection result) + (handle connection (dom-to-event result))))) (defmacro fmt (string &rest args) `(format nil ,string ,@args))

1 0

[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-serv21740 Modified Files: index.html Log Message: 0.4.0 Date: Sat Oct 29 19:30:16 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.10 public_html/index.html:1.11 --- public_html/index.html:1.10 Sat Oct 29 04:14:25 2005 +++ public_html/index.html Sat Oct 29 19:30:15 2005 @@ -20,7 +20,8 @@ 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.</p> +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 @@ -37,6 +38,7 @@ <h2>News</h2> <div class="level"> <ul> + <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> <li>Version 0.2.0 released (JEP 0073 support)</li> <li>Version 0.1.0 released (Initial release)</li>

1 0

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

29 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv21680 Modified Files: Makefile TODO cl-xmpp.lisp package.lisp result.lisp Log Message: adding better support for JEP 0030 + exporting more symbols Date: Sat Oct 29 19:25:04 2005 Author: eenge Index: cl-xmpp/Makefile diff -u cl-xmpp/Makefile:1.1.1.1 cl-xmpp/Makefile:1.2 --- cl-xmpp/Makefile:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/Makefile Sat Oct 29 19:25:04 2005 @@ -1,2 +1,2 @@ clean: - rm *~ *.fasl \ No newline at end of file + rm *~ *.fasl *.nfasl Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.4 cl-xmpp/TODO:1.5 --- cl-xmpp/TODO:1.4 Sat Oct 29 05:58:04 2005 +++ cl-xmpp/TODO Sat Oct 29 19:25:04 2005 @@ -5,5 +5,3 @@ - also, i'm interning things which will screw up lisps with up/down case different. -- add support for JEP0030 service discovery - Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.4 cl-xmpp/cl-xmpp.lisp:1.5 --- cl-xmpp/cl-xmpp.lisp:1.4 Sat Oct 29 05:58:04 2005 +++ cl-xmpp/cl-xmpp.lisp Sat Oct 29 19:25:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.4 2005/10/29 03:58:04 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -76,10 +76,6 @@ 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))) - ;; 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)) @@ -96,8 +92,8 @@ connection) (defmethod receive-stanza-loop ((connection connection) &key - (stanza-callback 'default-stanza-callback) - (init-callback 'default-init-callback) + (stanza-callback 'default-stanza-callback) + (init-callback 'default-init-callback) dom-repr) (loop (let* ((stanza (read-stanza connection)) @@ -172,12 +168,14 @@ (finish-output ,stream) ,connection))) -(defmacro with-iq-query ((connection &key xmlns id (to nil) (type "get")) &body body) +(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" (cxml:attribute "xmlns" ,xmlns) + (when ,node + (cxml:attribute "node" ,node)) ,@body)) ,connection)) @@ -185,8 +183,12 @@ ;; Discovery ;; -(defmethod discover ((connection connection) to) - (with-iq-query (connection :id "info1" :xmlns "http://jabber.org/protocol/disco#info" :to to))) +(defmethod discover ((connection connection) &key (type :info) to node) + (let ((xmlns (case type + (:info "http://jabber.org/protocol/disco#info") + (:items "http://jabber.org/protocol/disco#items") + (t (error "Unknown type: ~a (Please choose between :info and :items)" type))))) + (with-iq-query (connection :id "info1" :xmlns xmlns :to to :node node)))) ;; ;; Basic operations Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.2 cl-xmpp/package.lisp:1.3 --- cl-xmpp/package.lisp:1.2 Fri Oct 28 23:04:12 2005 +++ cl-xmpp/package.lisp Sat Oct 29 19:25:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ +;;;; $Id: package.lisp,v 1.3 2005/10/29 17:25:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -13,18 +13,38 @@ ;; connection-related :connect :disconnect :socket :stream- :hostname :port :connectedp :receive-stanza-loop :begin-xml-stream :end-xml-stream :with-iq - :with-iq-query + :with-iq-query :connection ;; xmpp commands + :discover :registration-requirements :register :auth-requirements :auth :presence :message :bind + ;; subscriptions :request-subscription :approve-subscription :deny/cancel-subscription :unsubscribe + ;; roster :get-roster :roster-add :roster-remove + ;; privacy-lists :get-privacy-lists :get-privacy-list + ;; dom-ish interface + :xml-element :name :elements :attributes :node :data + :xml-attribute :value ;; event interface :event + :presence + :roster + :xmpp-protocol-error + :xmpp-protocol-error-auth + :xmpp-protocol-error-wait + :xmpp-protocol-error-cancel + :xmpp-protocol-error-modify + :disco-info :features + :identity- + :disco :identities + :disco-items :items + :item :jid :message :to :from :body + ;; user-hooks for handling events :handle ;; variables - :*default-port :*default-hostname*))) + :*default-port :*default-hostname* :*errors*))) Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.4 cl-xmpp/result.lisp:1.5 --- cl-xmpp/result.lisp:1.4 Sat Oct 29 05:58:04 2005 +++ cl-xmpp/result.lisp Sat Oct 29 19:25:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.4 2005/10/29 03:58:04 eenge Exp $ +;;;; $Id: result.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -144,50 +144,14 @@ 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)) - (t (find-class 'xmpp-protocol-error)))) - -;;; 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))) - -;; ;; Event interface ;; -(defclass event () ()) +(defclass event () + ((xml-element + :accessor xml-element + :initarg :xml-element + :initform nil))) (defclass message (event) ((to @@ -214,6 +178,7 @@ ;;; you do please feel free to submit a patch. (defmethod xml-element-to-event ((object xml-element) (name (eql :message))) (make-instance 'message + :xml-element object :from (value (get-attribute object :from)) :to (value (get-attribute object :to)) :body (data (get-element (get-element object :body) :\#text)))) @@ -247,6 +212,7 @@ (when show (setq show (data (get-element show :\#text)))) (make-instance 'presence + :xml-element object :from (value (get-attribute object :from)) :to (value (get-attribute object :to)) :show show @@ -282,7 +248,7 @@ (format stream "~a contact(s)" (length (items object))))) (defmethod make-roster ((object xml-element)) - (let ((roster (make-instance 'roster))) + (let ((roster (make-instance 'roster :xml-element object))) (dolist (item (elements (get-element object :query))) (let ((jid (value (get-attribute item :jid))) (name (value (get-attribute item :name))) @@ -291,15 +257,119 @@ (items roster)))) roster)) +(defclass identity- (event) + ((category + :accessor category + :initarg :category) + (type- + :accessor type- + :initarg :type-) + (name + :accessor name + :initarg :name))) + +(defmethod make-identity ((object xml-element)) + (make-instance 'identity- + :xml-element object + :category (value (get-attribute object :category)) + :type- (value (get-attribute object :type-)) + :name (value (get-attribute object :name)))) + ;;; XXX: must think about this for another few days and then I will ;;; decide how to represent the disco#info and disco#items data. (defclass disco (event) - ((xml-element - :accessor xml-element - :initarg :xml-element))) + ((identities + :accessor identities + :initarg :identities + :initform nil))) -(defclass disco-info (discovery) ()) -(defclass disco-items (discovery) ()) +(defclass feature (event) + ((var + :accessor var + :initarg :var + :initform ""))) + +(defmethod make-feature ((object xml-element)) + (make-instance 'feature :xml-element object :var (value (get-attribute object :var)))) + +(defclass disco-info (disco) + ((features + :accessor features + :initarg :features + :initform nil))) + +(defmethod make-disco-info ((object xml-element)) + (let ((disco-info (make-instance 'disco-info :xml-element object))) + (dolist (element (elements object)) + (case (name element) + (:identity (push (make-identity element) (identities disco-info))) + (:feature (push (make-feature element) (features disco-info))))) + disco-info)) + +(defclass item (event) + ((jid + :accessor jid + :initarg :jid) + (name + :accessor name + :initarg :name) + (node + :accessor node + :initarg :node + :initform nil))) + +(defmethod make-item ((object xml-element)) + (make-instance 'item + :xml-element object + :jid (value (get-attribute object :jid)) + :node (value (get-attribute object :node)) + :name (value (get-attribute object :name)))) + +(defclass disco-items (disco) + ((items + :accessor items + :initarg :items + :initform nil))) + +(defmethod make-disco-items ((object xml-element)) + (let ((disco-items (make-instance 'disco-items :xml-element object))) + disco-items)) + +;; +;; Error +;; + +(defclass xmpp-protocol-error (event) + ((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)) + (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))) + (make-instance class :code code :name name :xml-element object))) ;;; XXX: this is a mess with all the IFs... fix. (defmethod xml-element-to-event ((object xml-element) (name (eql :iq))) @@ -320,25 +390,25 @@ :authentication-successful (make-error (get-element object :error)))) (:info1 (if (string-equal (value (get-attribute object :type)) "result") - (make-instance 'disco-info :xml-element xml-element) + (make-disco-info (get-element object :query)) (make-error (get-element object :error)))) (:info2 (if (string-equal (value (get-attribute object :type)) "result") - (make-instance 'disco-info :xml-element xml-element) + (make-disco-info (get-element object :query)) (make-error (get-element object :error)))) (:info3 (if (string-equal (value (get-attribute object :type)) "result") - (make-instance 'disco-info :xml-element xml-element) + (make-disco-info (get-element object :query)) (make-error (get-element object :error)))) (:items1 (if (string-equal (value (get-attribute object :type)) "result") - (make-instance 'disco-items :xml-element xml-element) + (make-disco-items (get-element object :query)) (make-error (get-element object :error)))) (:items2 (if (string-equal (value (get-attribute object :type)) "result") - (make-instance 'disco-items :xml-element xml-element) + (make-disco-items (get-element object :query)) (make-error (get-element object :error)))) (:items3 (if (string-equal (value (get-attribute object :type)) "result") - (make-instance 'disco-items :xml-element xml-element) + (make-disco-items (get-element object :query)) (make-error (get-element object :error)))) (:items4 (if (string-equal (value (get-attribute object :type)) "result") - (make-instance 'disco-items :xml-element xml-element) + (make-disco-items (get-element object :query)) (make-error (get-element object :error)))) (t object)))) @@ -349,7 +419,8 @@ (make-error object)) (defmethod xml-element-to-event ((object xml-element) name) - name) + (declare (ignore name)) + object) (defmethod dom-to-event ((object list)) (mapcar #'dom-to-event object)) @@ -366,4 +437,4 @@ (mapc #'handle object)) (defmethod handle (object) - (format t "~&Received: ~a~%" object)) \ No newline at end of file + (format t "~&Received: ~a~%" object))

1 0

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

29 Oct '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv28166 Modified Files: TODO cl-xmpp.lisp cxml.lisp result.lisp utility.lisp Log Message: adding preliminary implementation of disco#items and disco#info Date: Sat Oct 29 05:58:05 2005 Author: eenge Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.3 cl-xmpp/TODO:1.4 --- cl-xmpp/TODO:1.3 Fri Oct 28 23:24:08 2005 +++ cl-xmpp/TODO Sat Oct 29 05:58:04 2005 @@ -2,12 +2,8 @@ - sasl/tls -- don't like xmlns and query ids as strings - - also, i'm interning things which will screw up lisps with up/down - case different. +- also, i'm interning things which will screw up lisps with up/down + case different. - 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 Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.3 cl-xmpp/cl-xmpp.lisp:1.4 --- cl-xmpp/cl-xmpp.lisp:1.3 Fri Oct 28 23:17:59 2005 +++ cl-xmpp/cl-xmpp.lisp Sat Oct 29 05:58:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.3 2005/10/28 21:17:59 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.4 2005/10/29 03:58:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -42,33 +42,34 @@ ;;; 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)) - (ip-address (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name hostname))))) - (sb-bsd-sockets:socket-connect socket ip-address port) - (setf (sb-bsd-sockets:non-blocking-mode socket) t) - (make-instance 'connection - :server-stream (sb-bsd-sockets:socket-make-stream - socket :input t :output t :buffering :none - :element-type '(unsigned-byte 8) - :pathname #p"/tmp/not-a-pathname") - :socket socket - :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))) + #+sbcl (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp)) + (ip-address (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name hostname))))) + (sb-bsd-sockets:socket-connect socket ip-address port) + (setf (sb-bsd-sockets:non-blocking-mode socket) t) + (make-instance 'connection + :server-stream (sb-bsd-sockets:socket-make-stream + socket :input t :output t :buffering :none + :element-type '(unsigned-byte 8) + :pathname #p"/tmp/not-a-pathname") + :socket socket + :hostname hostname + :port port)) + #+allegro (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)) + #+lispworks (let ((socket (comm:open-tcp-stream hostname port :element-type '(unsigned-byte 8)))) + (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 @@ -88,40 +89,30 @@ (and (streamp stream) (open-stream-p stream)))) -#+sbcl -(defmethod disconnect ((connection connection)) - "Disconnect TCP connection." - (sb-bsd-sockets:socket-close (socket connection)) - connection) - -#+allegro (defmethod disconnect ((connection connection)) "Disconnect TCP connection." - (close (socket connection)) + #+sbcl (sb-bsd-sockets:socket-close (socket connection)) + #+(or allegro lispworks) (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))) + (init-callback 'default-init-callback) + dom-repr) (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))) + (funcall init-callback stanza :dom-repr dom-repr))) ((equal tagname "stream:error") - (default-stanza-callback stanza) ;print it - (error "received error")) + (when stanza-callback + (funcall stanza-callback stanza :dom-repr dom-repr)) + (error "Received error.")) (t (when stanza-callback - (funcall stanza-callback stanza))))))) + (funcall stanza-callback stanza :dom-repr dom-repr))))))) (defun read-stanza (connection) (unless (server-xstream connection) @@ -136,45 +127,6 @@ (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)) - "Read reply from connection's socket into a new stream -and return this stream. This is just a way to deal with -not getting EOFs or anything like that and should probably -be replaced with more appropriate usage of the sockets." - (let* ((output-stream (make-string-output-stream)) - (broadcast-stream (make-broadcast-stream - output-stream - *debug-stream*))) - (do ((line (sb-bsd-sockets:socket-receive (socket connection) nil 1) - (sb-bsd-sockets:socket-receive (socket connection) nil 1))) - ((or (null line) - (eq (aref line 0) #\Null))) - (write-string line broadcast-stream)) - output-stream)) - -;;; XXX: this one should go away, too -(defmethod get-string-reply ((connection connection)) - "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 to the debug stream. It's not strictly /with/ xml-stream @@ -206,41 +158,39 @@ (with-xml-stream (stream connection) (xml-output stream "</stream:stream>"))) -(defmacro with-iq ((connection &key id (type "get")) &body body) +(defmacro with-iq ((connection &key id to (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)) (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) + (when ,to + (cxml:attribute "to" ,to)) (cxml:attribute "type" ,type) ,@body)) (finish-output ,stream) ,connection))) -(defmacro with-iq-query ((connection &key xmlns id (type "get")) &body body) +(defmacro with-iq-query ((connection &key xmlns id (to nil) (type "get")) &body body) "Macro to make it easier to write QUERYs." `(progn - (with-iq (connection :id ,id :type ,type) + (with-iq (connection :id ,id :type ,type :to ,to) (cxml:with-element "query" (cxml:attribute "xmlns" ,xmlns) ,@body)) ,connection)) ;; -;; Basic operations +;; Discovery ;; -;;; XXX: Add support for handling an XMPP server which announces -;;; its features. +(defmethod discover ((connection connection) to) + (with-iq-query (connection :id "info1" :xmlns "http://jabber.org/protocol/disco#info" :to to))) + +;; +;; Basic operations +;; (defmethod registration-requirements ((connection connection)) (with-iq-query (connection :id "reg1" :xmlns "jabber:iq:register"))) @@ -354,3 +304,4 @@ (with-iq-query (connection :id "getlist2" :xmlns "jabber:iq:privacy") (cxml:with-element "list" (cxml:attribute "name" name)))) + Index: cl-xmpp/cxml.lisp diff -u cl-xmpp/cxml.lisp:1.2 cl-xmpp/cxml.lisp:1.3 --- cl-xmpp/cxml.lisp:1.2 Fri Oct 28 23:04:12 2005 +++ cl-xmpp/cxml.lisp Sat Oct 29 05:58:04 2005 @@ -20,19 +20,6 @@ (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 (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. @@ -57,10 +44,6 @@ (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)))))) (when (eql (depth handler) 0) (throw 'stanza (dom-impl::document (cxml:proxy-chained-handler handler))))) Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.3 cl-xmpp/result.lisp:1.4 --- cl-xmpp/result.lisp:1.3 Fri Oct 28 23:17:59 2005 +++ cl-xmpp/result.lisp Sat Oct 29 05:58:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.3 2005/10/28 21:17:59 eenge Exp $ +;;;; $Id: result.lisp,v 1.4 2005/10/29 03:58:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -135,7 +135,7 @@ xml-element)) (defmethod parse-result ((node dom-impl::node)) - (let* ((name (dom:node-name node)) + (let* ((name (intern (string-upcase (dom:node-name node)) :keyword)) (xml-element (make-instance 'xml-element :name name :node node))) (dom:do-node-list (attribute (dom:attributes node)) (push (parse-result attribute) (attributes xml-element))) @@ -168,7 +168,8 @@ (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)))) + (auth (find-class 'xmpp-protocol-error-auth)) + (t (find-class 'xmpp-protocol-error)))) ;;; If an error element occurs within a, say, message element ;;; do I want to include the error within the message, the @@ -180,7 +181,7 @@ (type (second data)) (code (third data)) (class (map-error-type-to-class type))) - (make-instance class :code code :name name :type type))) + (make-instance class :code code :name name))) ;; ;; Event interface @@ -213,9 +214,9 @@ ;;; you do please feel free to submit a patch. (defmethod xml-element-to-event ((object xml-element) (name (eql :message))) (make-instance 'message - :from (value (get-attribute object "from")) - :to (value (get-attribute object "to")) - :body (data (get-element (get-element object "body") "#text")))) + :from (value (get-attribute object :from)) + :to (value (get-attribute object :to)) + :body (data (get-element (get-element object :body) :\#text)))) (defclass presence (event) ((to @@ -242,14 +243,14 @@ ;;; 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))) - (let ((show (get-element object "show"))) + (let ((show (get-element object :show))) (when show - (setq show (data (get-element show "#text")))) + (setq show (data (get-element show :\#text)))) (make-instance 'presence - :from (value (get-attribute object "from")) - :to (value (get-attribute object "to")) + :from (value (get-attribute object :from)) + :to (value (get-attribute object :to)) :show show - :type- (value (get-attribute object "type"))))) + :type- (value (get-attribute object :type))))) (defclass contact () ((jid @@ -282,35 +283,69 @@ (defmethod make-roster ((object xml-element)) (let ((roster (make-instance 'roster))) - (dolist (item (elements (get-element object "query"))) - (let ((jid (value (get-attribute item "jid"))) - (name (value (get-attribute item "name"))) - (subscription (value (get-attribute item "subscription")))) + (dolist (item (elements (get-element object :query))) + (let ((jid (value (get-attribute item :jid))) + (name (value (get-attribute item :name))) + (subscription (value (get-attribute item :subscription)))) (push (make-instance 'contact :jid jid :name name :subscription subscription) (items roster)))) roster)) -;;; XXX: I think I want to make all IDs keywords. +;;; XXX: must think about this for another few days and then I will +;;; decide how to represent the disco#info and disco#items data. +(defclass disco (event) + ((xml-element + :accessor xml-element + :initarg :xml-element))) + +(defclass disco-info (discovery) ()) +(defclass disco-items (discovery) ()) + +;;; XXX: this is a mess with all the IFs... fix. (defmethod xml-element-to-event ((object xml-element) (name (eql :iq))) - (let ((id (intern (string-upcase (value (get-attribute object "id"))) :keyword))) + (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") + (: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") + (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") + (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") + (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)))) + (make-error (get-element object :error)))) + (:info1 (if (string-equal (value (get-attribute object :type)) "result") + (make-instance 'disco-info :xml-element xml-element) + (make-error (get-element object :error)))) + (:info2 (if (string-equal (value (get-attribute object :type)) "result") + (make-instance 'disco-info :xml-element xml-element) + (make-error (get-element object :error)))) + (:info3 (if (string-equal (value (get-attribute object :type)) "result") + (make-instance 'disco-info :xml-element xml-element) + (make-error (get-element object :error)))) + (:items1 (if (string-equal (value (get-attribute object :type)) "result") + (make-instance 'disco-items :xml-element xml-element) + (make-error (get-element object :error)))) + (:items2 (if (string-equal (value (get-attribute object :type)) "result") + (make-instance 'disco-items :xml-element xml-element) + (make-error (get-element object :error)))) + (:items3 (if (string-equal (value (get-attribute object :type)) "result") + (make-instance 'disco-items :xml-element xml-element) + (make-error (get-element object :error)))) + (:items4 (if (string-equal (value (get-attribute object :type)) "result") + (make-instance 'disco-items :xml-element xml-element) + (make-error (get-element object :error)))) + (t object)))) (defmethod xml-element-to-event ((object xml-element) (name (eql :error))) + (make-error object)) + +(defmethod xml-element-to-event ((object xml-element) (name (eql :stream\:error))) (make-error object)) (defmethod xml-element-to-event ((object xml-element) name) Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.2 cl-xmpp/utility.lisp:1.3 --- cl-xmpp/utility.lisp:1.2 Fri Oct 28 23:04:12 2005 +++ cl-xmpp/utility.lisp Sat Oct 29 05:58:04 2005 @@ -1,15 +1,10 @@ -;;;; $Id: utility.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ +;;;; $Id: utility.lisp,v 1.3 2005/10/29 03:58:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :xmpp) -(defun add-stream-namespace-binding () - (push '(#"stream" "http://etherx.jabber.org/streams") - cxml::*default-namespace-bindings*)) -;(add-stream-namespace-binding) - (defun flatten (list) (cond ((typep list 'atom) list) @@ -26,11 +21,15 @@ (defun default-stanza-callback (stanza &key dom-repr) (let ((result (parse-result stanza))) (if dom-repr - result + (handle result) (handle (dom-to-event result))))) -(defun default-init-callback (stanza) - (format t "default-init-callback:~a~%" stanza)) +;; um, refactor? +(defun default-init-callback (stanza &key dom-repr) + (let ((result (parse-result stanza))) + (if dom-repr + (handle result) + (handle (dom-to-event result))))) (defmacro fmt (string &rest args) `(format nil ,string ,@args))

1 0

[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

[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-serv32376 Modified Files: index.html Log Message: quoting <>'s Date: Fri Oct 28 15:47:59 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.2 public_html/index.html:1.3 --- public_html/index.html:1.2 Fri Oct 28 15:41:18 2005 +++ public_html/index.html Fri Oct 28 15:47:59 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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cl-xmpp-cvs