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