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