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