[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.asd cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/package.lisp cl-xmpp/result.lisp cl-xmpp/utility.lisp cl-xmpp/variable.lisp
Erik Enge
eenge at common-lisp.net
Fri Oct 28 21:04:17 UTC 2005
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)
- , at 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)
+; , 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)
+ (cxml:attribute "type" ,type)
+ , at 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)))
+
More information about the Cl-xmpp-cvs
mailing list