[cl-xmpp-cvs] CVS update: cl-xmpp/Makefile cl-xmpp/TODO cl-xmpp/cl-xmpp.lisp cl-xmpp/package.lisp cl-xmpp/result.lisp
Erik Enge
eenge at common-lisp.net
Sat Oct 29 17:25:08 UTC 2005
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))
, at 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))
More information about the Cl-xmpp-cvs
mailing list