[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
Erik Enge
eenge at common-lisp.net
Sat Oct 29 03:58:09 UTC 2005
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)
-; , at 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)
, at 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)
, at 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 , at args))
More information about the Cl-xmpp-cvs
mailing list