Version 0.1.0 released (initial release)
From eenge at common-lisp.net Fri Oct 28 14:19:06 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 28 Oct 2005 16:19:06 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051028141906.7000388588@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv2337
Modified Files:
index.html
Log Message:
forgot some markup
Date: Fri Oct 28 16:19:05 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.5 public_html/index.html:1.6
--- public_html/index.html:1.5 Fri Oct 28 16:17:29 2005
+++ public_html/index.html Fri Oct 28 16:19:05 2005
@@ -40,13 +40,17 @@
Requirements
+
- A recent SBCL (need 16bit wide characters)
- cxml
+
News
+
- Version 0.1.0 released (initial release)
+
Features
From eenge at common-lisp.net Fri Oct 28 16:06:17 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 28 Oct 2005 18:06:17 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051028160617.A785D8858F@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv10087
Modified Files:
index.html
Log Message:
*** empty log message ***
Date: Fri Oct 28 18:06:16 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.6 public_html/index.html:1.7
--- public_html/index.html:1.6 Fri Oct 28 16:19:05 2005
+++ public_html/index.html Fri Oct 28 18:06:10 2005
@@ -17,17 +17,11 @@
servers use to communicate with eachother (including
Google Talk).
-
There are many features currently in use by the Jabber
-community (forms, XHTML message bodies, query extensions,
-file transfer and discovery options) which are specified as
-Jabber Enhancement Proposals
-but this library does not implement these. If they in the future become
-RFCs published by the XMPP working group they will be included
-in the library but until then I (Erik Enge) recommend you implement
-your own cl-jabber ontop of cl-xmpp and move functionality from
-the former to the latter as the JEPs become RFCs.
+
The author is still considering whether or not
+to implement Jabber Enhancement Proposals
+in addition to the RFCs.
-
That said, you can still chat, manage your contacts, roster
+
Currently, you can chat, manage your contacts, roster
and presence information using this library. The code was developed
under SBCL and currently does
not work on any other implementation due to the fact that the socket
From eenge at common-lisp.net Fri Oct 28 16:10:26 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 28 Oct 2005 18:10:26 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051028161026.14AAB8858F@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv10223
Modified Files:
index.html
Log Message:
adding comment about jep 0073
Date: Fri Oct 28 18:10:26 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.7 public_html/index.html:1.8
--- public_html/index.html:1.7 Fri Oct 28 18:06:10 2005
+++ public_html/index.html Fri Oct 28 18:10:26 2005
@@ -19,7 +19,8 @@
The author is still considering whether or not
to implement Jabber Enhancement Proposals
-in addition to the RFCs.
+in addition to the RFCs. (Specifically, I am wondering whether or not to
+implement
JEP-0073: Basic IM Protocol Suite.)
Currently, you can chat, manage your contacts, roster
and presence information using this library. The code was developed
From eenge at common-lisp.net Fri Oct 28 21:04:17 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 28 Oct 2005 23:04:17 +0200 (CEST)
Subject: [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
Message-ID: <20051028210417.4F8118859A@common-lisp.net>
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 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 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)))
+
From eenge at common-lisp.net Fri Oct 28 21:18:01 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 28 Oct 2005 23:18:01 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/TODO cl-xmpp/cl-xmpp.lisp
cl-xmpp/result.lisp
Message-ID: <20051028211801.6F48C8859A@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv32631
Modified Files:
TODO cl-xmpp.lisp result.lisp
Log Message:
Date: Fri Oct 28 23:17:59 2005
Author: eenge
Index: cl-xmpp/TODO
diff -u cl-xmpp/TODO:1.1.1.1 cl-xmpp/TODO:1.2
--- cl-xmpp/TODO:1.1.1.1 Fri Oct 28 15:16:02 2005
+++ cl-xmpp/TODO Fri Oct 28 23:17:59 2005
@@ -6,6 +6,4 @@
- also, i'm interning things which will screw up lisps with up/down
case different.
-- ok, test receive-stanza-loop with a file with contents
- which i think i'm getting and see if it blows up with
- that.
\ No newline at end of file
+- add support for JEP0030 service discovery
\ No newline at end of file
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.2 cl-xmpp/cl-xmpp.lisp:1.3
--- cl-xmpp/cl-xmpp.lisp:1.2 Fri Oct 28 23:04:12 2005
+++ cl-xmpp/cl-xmpp.lisp Fri Oct 28 23:17:59 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.3 2005/10/28 21:17:59 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -251,6 +251,18 @@
(cxml:with-element "password" (cxml:text password))
(cxml:with-element "name" (cxml:text name))
(cxml:with-element "email" (cxml:text email))))
+
+(defmethod cancel-registration ((connection connection))
+ (with-iq-query (connection :id "unreg1" :type "set" :xmlns "jabber:iq:register")
+ (cxml:with-element "remove")))
+
+;;; XXX: connection should know about username?
+(defmethod change-password ((connection connection) username new-password)
+ (with-iq-query (connection :id "change1" :type "set" :xmlns "jabber:iq:register")
+ (cxml:with-element "username"
+ (cxml:text username))
+ (cxml:with-element "password"
+ (cxml:text new-password))))
(defmethod auth-requirements ((connection connection) username)
(with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth")
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.2 cl-xmpp/result.lisp:1.3
--- cl-xmpp/result.lisp:1.2 Fri Oct 28 23:04:12 2005
+++ cl-xmpp/result.lisp Fri Oct 28 23:17:59 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $
+;;;; $Id: result.lisp,v 1.3 2005/10/28 21:17:59 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -295,6 +295,19 @@
(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")
+ :registration-successful
+ (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")
+ :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")
+ :authentication-successful
+ (make-error (get-element object "error"))))
(t name))))
(defmethod xml-element-to-event ((object xml-element) (name (eql :error)))
From eenge at common-lisp.net Fri Oct 28 21:22:06 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 28 Oct 2005 23:22:06 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051028212206.43EA98859A@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv32675
Modified Files:
index.html
Log Message:
adding comment about jeps
Date: Fri Oct 28 23:22:05 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.8 public_html/index.html:1.9
--- public_html/index.html:1.8 Fri Oct 28 18:10:26 2005
+++ public_html/index.html Fri Oct 28 23:22:05 2005
@@ -15,12 +15,9 @@
XMPP RFCs. These are the
RFCs which Jabber clients and
servers use to communicate with eachother (including
-Google Talk).
-
-
The author is still considering whether or not
-to implement Jabber Enhancement Proposals
-in addition to the RFCs. (Specifically, I am wondering whether or not to
-implement JEP-0073: Basic IM Protocol Suite.)
+
Google Talk). In addition
+cl-xmpp implements JEPs 0078, 0086, 0030 and 0070 which are
+all part of
JEP-0073: Basic IM Protocol Suite. The author considers the library feature complete but will happily accept patches for any other reasonably stable JEPs.
Currently, you can chat, manage your contacts, roster
and presence information using this library. The code was developed
From eenge at common-lisp.net Fri Oct 28 21:24:08 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 28 Oct 2005 23:24:08 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/TODO
Message-ID: <20051028212408.BA2CF8859A@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv32714
Modified Files:
TODO
Log Message:
*** empty log message ***
Date: Fri Oct 28 23:24:08 2005
Author: eenge
Index: cl-xmpp/TODO
diff -u cl-xmpp/TODO:1.2 cl-xmpp/TODO:1.3
--- cl-xmpp/TODO:1.2 Fri Oct 28 23:17:59 2005
+++ cl-xmpp/TODO Fri Oct 28 23:24:08 2005
@@ -6,4 +6,8 @@
- also, i'm interning things which will screw up lisps with up/down
case different.
-- add support for JEP0030 service discovery
\ No newline at end of file
+- 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
From eenge at common-lisp.net Sat Oct 29 02:14:30 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 29 Oct 2005 04:14:30 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051029021430.85AA98859B@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv20669
Modified Files:
index.html
Log Message:
adding info about lispworks
Date: Sat Oct 29 04:14:26 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.9 public_html/index.html:1.10
--- public_html/index.html:1.9 Fri Oct 28 23:22:05 2005
+++ public_html/index.html Sat Oct 29 04:14:25 2005
@@ -7,7 +7,7 @@
@@ -20,11 +20,7 @@
all part of
JEP-0073: Basic IM Protocol Suite. The author considers the library feature complete but will happily accept patches for any other reasonably stable JEPs.
Currently, you can chat, manage your contacts, roster
-and presence information using this library. The code was developed
-under SBCL and currently does
-not work on any other implementation due to the fact that the socket
-code is all SBCL specific. However, for someone sufficiently motivated,
-it probably takes 10 minutes to add support for another implementation.
+and presence information using this library.
The code is released under an MIT-style
@@ -33,7 +29,7 @@
Requirements
- - A recent SBCL (need 16bit wide characters)
+ - A recent SBCL (need 16bit wide characters), LispWorks or Allegro (patches welcome for others)
- cxml
@@ -41,7 +37,9 @@
News
- - Version 0.1.0 released (initial release)
+ - Version 0.3.0 released (Added Allegro and LispWorks support)
+ - Version 0.2.0 released (JEP 0073 support)
+ - Version 0.1.0 released (Initial release)
@@ -49,7 +47,7 @@
- - implements most commands in the RFCs
+ - Implements most commands in the RFCs
- event driven model with hooks makes interfacing easy -- or
- access to DOM-ish structure with raw data from the server so you can do whatever you like
@@ -117,8 +115,8 @@
;; If you wish to handle the incoming messages or other objects simply
;; specify an xmpp:handle method for the objects you are interested in
-;; or xmpp:handle on xmpp:event to get them all. Or alternatively specify
-;; :dom-repr t to receive-stanza-loop to get DOM-ish objects.
+;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively
+;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects.
From eenge at common-lisp.net Sat Oct 29 03:58:09 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 29 Oct 2005 05:58:09 +0200 (CEST)
Subject: [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
Message-ID: <20051029035809.637C18859B@common-lisp.net>
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 "")))
-(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 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))
From eenge at common-lisp.net Sat Oct 29 17:25:08 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 29 Oct 2005 19:25:08 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/Makefile cl-xmpp/TODO
cl-xmpp/cl-xmpp.lisp cl-xmpp/package.lisp cl-xmpp/result.lisp
Message-ID: <20051029172508.04B1688031@common-lisp.net>
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))
From eenge at common-lisp.net Sat Oct 29 17:30:18 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 29 Oct 2005 19:30:18 +0200 (CEST)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051029173018.76CBF88031@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv21740
Modified Files:
index.html
Log Message:
0.4.0
Date: Sat Oct 29 19:30:16 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.10 public_html/index.html:1.11
--- public_html/index.html:1.10 Sat Oct 29 04:14:25 2005
+++ public_html/index.html Sat Oct 29 19:30:15 2005
@@ -20,7 +20,8 @@
all part of JEP-0073: Basic IM Protocol Suite. The author considers the library feature complete but will happily accept patches for any other reasonably stable JEPs.
Currently, you can chat, manage your contacts, roster
-and presence information using this library.
+and presence information using this library. You can now also
+use the service discovery protocol using the
xmpp:discover operator.
The code is released under an MIT-style
@@ -37,6 +38,7 @@
News
+ - Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)
- Version 0.3.0 released (Added Allegro and LispWorks support)
- Version 0.2.0 released (JEP 0073 support)
- Version 0.1.0 released (Initial release)
From eenge at common-lisp.net Mon Oct 31 17:02:06 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 31 Oct 2005 18:02:06 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/CREDITS cl-xmpp/README
cl-xmpp/cl-xmpp.lisp cl-xmpp/result.lisp cl-xmpp/utility.lisp
Message-ID: <20051031170206.59F1488579@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv29674
Modified Files:
README cl-xmpp.lisp result.lisp utility.lisp
Added Files:
CREDITS
Log Message:
cleaning up the handling code
Date: Mon Oct 31 18:02:04 2005
Author: eenge
Index: cl-xmpp/README
diff -u cl-xmpp/README:1.1.1.1 cl-xmpp/README:1.2
--- cl-xmpp/README:1.1.1.1 Fri Oct 28 15:16:02 2005
+++ cl-xmpp/README Mon Oct 31 18:02:03 2005
@@ -1,27 +1,44 @@
-This is a Common Lisp implementation of the XMPP RFCs. The
-implementation is currently very immature and comments are
-solicited.
+This is a Common Lisp implementation of the XMPP RFCs. Please
+see http://common-lisp.net/project/cl-xmpp for more information.
-Non-normative example:
+Example:
-* (defparameter *c* (xmpp:connect :hostname "my-xmpp-server"))
-#
+ * (require :cl-xmpp)
-* (xmpp:begin-xml-stream *c*)
-... output ...
+ * (defvar connection (xmpp:connect :hostname "jabber.org"))
-* (xmpp:auth *c* "username" "password" "resource")
-... output ...
+;; initiate XML stream with server
+ * (xmpp:begin-xml-stream connection)
-* (xmpp:receive-stanzas *c*)
-... output ...
+;; authenticate (or use xmpp:register to make an account)
+ * (xmpp:auth connection "username" "password" "resource")
-* (xmpp:message *c* "username" "message")
-... output ...
+;; let the server know you want to receive/send presence information
+;; (this makes you "come online" if others have a subscription with you
+ * (xmpp:presence connection)
-; let's assume a user replies to you
-* (xmpp:receive-stanzas *c*)
-(#)
+;; send someone a message
+ * (xmpp:message connection "username at hostname" "what's going on?")
+
+;; then sit back and watch the messages roll in:
+ * (xmpp:receive-stanza-loop connection)
+
+[....]
+
+;; That's it. Interrupt the loop to issue other commands, eg:
+ * (xmpp:get-roster connection)
+
+;; or any of the other ones you may find by looking through cl-xmpp.lisp
+;; and package.lisp to see which ones are exported.
+
+;; If you wish to handle the incoming messages or other objects simply
+;; specify an xmpp:handle method for the objects you are interested in
+;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively
+;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects.
+
+;; For example, if you wanted to create an annoying reply bot:
+
+ * (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message))
+ (xmpp:message connection (xmpp:from message)
+ (format nil "reply to: ~a~%" (xmpp:message object))))
-And so on and so forth. Check cl-xmpp.lisp and package.lisp for
-symbols which are exported and might be of use.
\ No newline at end of file
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.5 cl-xmpp/cl-xmpp.lisp:1.6
--- cl-xmpp/cl-xmpp.lisp:1.5 Sat Oct 29 19:25:04 2005
+++ cl-xmpp/cl-xmpp.lisp Mon Oct 31 18:02:04 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -64,7 +64,8 @@
:socket socket
:hostname hostname
:port port))
- #+lispworks (let ((socket (comm:open-tcp-stream hostname port :element-type '(unsigned-byte 8))))
+ #+lispworks (let ((socket (comm:open-tcp-stream hostname port
+ :element-type '(unsigned-byte 8))))
(make-instance 'connection
:server-stream socket
:socket socket
@@ -101,14 +102,14 @@
(cond
((equal tagname "stream:stream")
(when init-callback
- (funcall init-callback stanza :dom-repr dom-repr)))
+ (funcall init-callback stanza connection :dom-repr dom-repr)))
((equal tagname "stream:error")
(when stanza-callback
- (funcall stanza-callback stanza :dom-repr dom-repr))
+ (funcall stanza-callback stanza connection :dom-repr dom-repr))
(error "Received error."))
(t
(when stanza-callback
- (funcall stanza-callback stanza :dom-repr dom-repr)))))))
+ (funcall stanza-callback stanza connection :dom-repr dom-repr)))))))
(defun read-stanza (connection)
(unless (server-xstream connection)
@@ -245,8 +246,6 @@
(cxml:with-element "body" (cxml:text body))))
connection)
-;;; XXX: this one doesn't seem to work with Jabberd 1.4
-;;; (not insinuating that I've tested it with anything else).
(defmethod bind ((connection connection) jid resource)
(with-iq (connection :id "bind_2" :type "set")
(cxml:with-element "bind"
@@ -277,7 +276,7 @@
(defmethod get-roster ((connection connection))
(with-iq-query (connection :id "roster_1" :xmlns "jabber:iq:roster")))
-;;; XXX: Adding and removing from the roster is not the same as
+;;; Note: Adding and removing from the roster is not the same as
;;; adding and removing subscriptions. I have not yet decided
;;; if the library should provide convenience methods for doing
;;; both actions at once.
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.5 cl-xmpp/result.lisp:1.6
--- cl-xmpp/result.lisp:1.5 Sat Oct 29 19:25:04 2005
+++ cl-xmpp/result.lisp Mon Oct 31 18:02:04 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $
+;;;; $Id: result.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -257,6 +257,10 @@
(items roster))))
roster))
+;;
+;; Discovery
+;;
+
(defclass identity- (event)
((category
:accessor category
@@ -275,8 +279,6 @@
: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)
((identities
:accessor identities
@@ -371,46 +373,22 @@
(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)))
(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")
- :registration-successful
- (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")
- :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")
- :authentication-successful
- (make-error (get-element object :error))))
- (:info1 (if (string-equal (value (get-attribute object :type)) "result")
- (make-disco-info (get-element object :query))
- (make-error (get-element object :error))))
- (:info2 (if (string-equal (value (get-attribute object :type)) "result")
- (make-disco-info (get-element object :query))
- (make-error (get-element object :error))))
- (:info3 (if (string-equal (value (get-attribute object :type)) "result")
- (make-disco-info (get-element object :query))
- (make-error (get-element object :error))))
- (:items1 (if (string-equal (value (get-attribute object :type)) "result")
- (make-disco-items (get-element object :query))
- (make-error (get-element object :error))))
- (:items2 (if (string-equal (value (get-attribute object :type)) "result")
- (make-disco-items (get-element object :query))
- (make-error (get-element object :error))))
- (:items3 (if (string-equal (value (get-attribute object :type)) "result")
- (make-disco-items (get-element object :query))
- (make-error (get-element object :error))))
- (:items4 (if (string-equal (value (get-attribute object :type)) "result")
- (make-disco-items (get-element object :query))
- (make-error (get-element object :error))))
- (t object))))
+ (if (not (string-equal (value (get-attribute object :type)) "result"))
+ (make-error (get-element object :error))
+ (case id
+ (:error (make-error (get-element object :error)))
+ (:roster_1 (make-roster object))
+ (:reg2 :registration-successful)
+ (:unreg_1 :registration-cancellation-successful)
+ (:change1 :password-changed-succesfully)
+ (:auth2 :authentication-successful)
+ (t (cond
+ ((member id '(info1 info2 info3))
+ (make-disco-info (get-element object :query)))
+ ((member id '(items1 items2 items3 items4))
+ (make-disco-items (get-element object :query)))))))))
(defmethod xml-element-to-event ((object xml-element) (name (eql :error)))
(make-error object))
@@ -433,8 +411,9 @@
;; Handle
;;
-(defmethod handle ((object list))
- (mapc #'handle object))
+(defmethod handle ((connection connection) (object list))
+ (dolist (object list)
+ (handle connection object)))
-(defmethod handle (object)
+(defmethod handle ((connection connection) object)
(format t "~&Received: ~a~%" object))
Index: cl-xmpp/utility.lisp
diff -u cl-xmpp/utility.lisp:1.3 cl-xmpp/utility.lisp:1.4
--- cl-xmpp/utility.lisp:1.3 Sat Oct 29 05:58:04 2005
+++ cl-xmpp/utility.lisp Mon Oct 31 18:02:04 2005
@@ -1,4 +1,4 @@
-;;;; $Id: utility.lisp,v 1.3 2005/10/29 03:58:04 eenge Exp $
+;;;; $Id: utility.lisp,v 1.4 2005/10/31 17:02:04 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -18,18 +18,18 @@
(setf (aref array position) (char-code (aref string position))))
array))
-(defun default-stanza-callback (stanza &key dom-repr)
+(defun default-stanza-callback (stanza connection &key dom-repr)
(let ((result (parse-result stanza)))
(if dom-repr
- (handle result)
- (handle (dom-to-event result)))))
+ (handle connection result)
+ (handle connection (dom-to-event result)))))
;; um, refactor?
-(defun default-init-callback (stanza &key dom-repr)
+(defun default-init-callback (stanza connection &key dom-repr)
(let ((result (parse-result stanza)))
(if dom-repr
- (handle result)
- (handle (dom-to-event result)))))
+ (handle connection result)
+ (handle connection (dom-to-event result)))))
(defmacro fmt (string &rest args)
`(format nil ,string , at args))
From eenge at common-lisp.net Mon Oct 31 17:02:21 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 31 Oct 2005 18:02:21 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051031170221.E9CE088579@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv29843
Modified Files:
index.html
Log Message:
Date: Mon Oct 31 18:02:21 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.11 public_html/index.html:1.12
--- public_html/index.html:1.11 Sat Oct 29 19:30:15 2005
+++ public_html/index.html Mon Oct 31 18:02:20 2005
@@ -119,6 +119,13 @@
;; specify an xmpp:handle method for the objects you are interested in
;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively
;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects.
+
+;; For example, if you wanted to create an annoying reply bot:
+
+ * (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message))
+ (xmpp:message connection (xmpp:from message)
+ (format nil "reply to: ~a~%" (xmpp:message object))))
+
From eenge at common-lisp.net Mon Oct 31 17:03:42 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 31 Oct 2005 18:03:42 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/README
Message-ID: <20051031170342.F24F688579@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv30017
Modified Files:
README
Log Message:
fixing missing connection in xmpp:handle signature in example
Date: Mon Oct 31 18:03:31 2005
Author: eenge
Index: cl-xmpp/README
diff -u cl-xmpp/README:1.2 cl-xmpp/README:1.3
--- cl-xmpp/README:1.2 Mon Oct 31 18:02:03 2005
+++ cl-xmpp/README Mon Oct 31 18:03:30 2005
@@ -33,7 +33,7 @@
;; If you wish to handle the incoming messages or other objects simply
;; specify an xmpp:handle method for the objects you are interested in
-;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively
+;; or (defmethod xmpp:handle (connection object) ...) to get them all. Or alternatively
;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects.
;; For example, if you wanted to create an annoying reply bot:
From eenge at common-lisp.net Mon Oct 31 17:04:09 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 31 Oct 2005 18:04:09 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051031170409.6C47988579@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv30035
Modified Files:
index.html
Log Message:
fixing missing connection in xmpp:handle signature in example
Date: Mon Oct 31 18:04:08 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.12 public_html/index.html:1.13
--- public_html/index.html:1.12 Mon Oct 31 18:02:20 2005
+++ public_html/index.html Mon Oct 31 18:04:08 2005
@@ -117,7 +117,7 @@
;; If you wish to handle the incoming messages or other objects simply
;; specify an xmpp:handle method for the objects you are interested in
-;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively
+;; or (defmethod xmpp:handle (connection object) ...) to get them all. Or alternatively
;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects.
;; For example, if you wanted to create an annoying reply bot:
From eenge at common-lisp.net Mon Oct 31 17:08:35 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 31 Oct 2005 18:08:35 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051031170835.442CA88579@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv30335
Modified Files:
index.html
Log Message:
upping version number
Date: Mon Oct 31 18:08:33 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.13 public_html/index.html:1.14
--- public_html/index.html:1.13 Mon Oct 31 18:04:08 2005
+++ public_html/index.html Mon Oct 31 18:08:33 2005
@@ -7,7 +7,7 @@
From eenge at common-lisp.net Mon Oct 31 21:07:16 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 31 Oct 2005 22:07:16 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.asd cl-xmpp/cl-xmpp.lisp
cl-xmpp/result.lisp cl-xmpp/utility.lisp
Message-ID: <20051031210716.817EE880DB@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv15203
Modified Files:
cl-xmpp.asd cl-xmpp.lisp result.lisp utility.lisp
Log Message:
now depending on ironclad for sha1 generation of digest password
Date: Mon Oct 31 22:07:15 2005
Author: eenge
Index: cl-xmpp/cl-xmpp.asd
diff -u cl-xmpp/cl-xmpp.asd:1.3 cl-xmpp/cl-xmpp.asd:1.4
--- cl-xmpp/cl-xmpp.asd:1.3 Fri Oct 28 23:04:12 2005
+++ cl-xmpp/cl-xmpp.asd Mon Oct 31 22:07:14 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp.asd,v 1.3 2005/10/28 21:04:12 eenge Exp $
+;;;; $Id: cl-xmpp.asd,v 1.4 2005/10/31 21:07:14 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 (#+sbcl :sb-bsd-sockets :cxml)
+ :depends-on (#+sbcl :sb-bsd-sockets :cxml :ironclad)
:components ((:file "package")
(:file "variable"
:depends-on ("package"))
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.6 cl-xmpp/cl-xmpp.lisp:1.7
--- cl-xmpp/cl-xmpp.lisp:1.6 Mon Oct 31 18:02:04 2005
+++ cl-xmpp/cl-xmpp.lisp Mon Oct 31 22:07:15 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -17,6 +17,12 @@
(server-xstream
:accessor server-xstream
:initform nil)
+ (stream-id
+ :accessor stream-id
+ :initarg :stream-id
+ :initform nil
+ :documentation "Stream ID attribute of the
+element as gotten when we call BEGIN-XML-STREAM.")
(hostname
:accessor hostname
:initarg :hostname
@@ -92,17 +98,137 @@
#+(or allegro lispworks) (close (socket connection))
connection)
+;;
+;; Handle
+;;
+
+(defmethod handle ((connection connection) (list list))
+ (dolist (object list)
+ (handle connection object)))
+
+(defmethod handle ((connection connection) object)
+ (format t "~&Received: ~a~%" object))
+
+;;
+;; Produce DOM-ish structure from the XML DOM returned by cxml.
+;;
+
+(defmethod parse-result ((connection connection) (objects list))
+ (dolist (object objects)
+ (parse-result connection object)))
+
+(defmethod parse-result ((connection connection) (document dom-impl::document))
+ (let (objects)
+ (dom:map-node-list #'(lambda (node)
+ (push (parse-result connection node) objects))
+ (dom:child-nodes document))
+ objects))
+
+(defmethod parse-result ((connection connection) (attribute dom-impl::attribute))
+ (let* ((name (dom:node-name attribute))
+ (value (dom:value attribute))
+ (xml-attribute
+ (make-instance 'xml-attribute
+ :name name :value value :node attribute)))
+ xml-attribute))
+
+(defmethod parse-result ((connection connection) (node dom-impl::character-data))
+ (let* ((name (dom:node-name node))
+ (data (dom:data node))
+ (xml-element (make-instance 'xml-element
+ :name name :data data :node node)))
+ xml-element))
+
+(defmethod parse-result ((connection connection) (node dom-impl::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 connection attribute) (attributes xml-element)))
+ (dom:do-node-list (child (dom:child-nodes node))
+ (push (parse-result connection child) (elements xml-element)))
+ xml-element))
+
+
+(defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :iq)))
+ (let ((id (intern (string-upcase (value (get-attribute object :id))) :keyword)))
+ (if (not (string-equal (value (get-attribute object :type)) "result"))
+ (make-error (get-element object :error))
+ (case id
+ (:error (make-error (get-element object :error)))
+ (:roster_1 (make-roster object))
+ (:reg2 :registration-successful)
+ (:unreg_1 :registration-cancellation-successful)
+ (:change1 :password-changed-succesfully)
+ (:auth2 :authentication-successful)
+ (t (cond
+ ((member id '(info1 info2 info3))
+ (make-disco-info (get-element object :query)))
+ ((member id '(items1 items2 items3 items4))
+ (make-disco-items (get-element object :query)))))))))
+
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :error)))
+ (make-error object))
+
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :stream\:error)))
+ (make-error object))
+
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :stream\:stream)))
+ (setf (stream-id connection) (value (get-attribute object :id)))
+ object)
+
+(defmethod xml-element-to-event ((connection connection) (object xml-element) name)
+ (declare (ignore name))
+ object)
+
+(defmethod dom-to-event ((connection connection) (objects list))
+ (let (list)
+ (dolist (object objects)
+ (push (dom-to-event connection object) list))
+ list))
+
+(defmethod dom-to-event ((connection connection) (object xml-element))
+ (xml-element-to-event
+ connection object (intern (string-upcase (name object)) :keyword)))
+
+;;; XXX: Is the ask attribute of the element part of the RFC/JEP?
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :presence)))
+ (let ((show (get-element object :show)))
+ (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
+ :type- (value (get-attribute object :type)))))
+
+;;; XXX: Add support for the element. Also note that
+;;; there may be an XHTML version of the body available in the
+;;; original node but as of right now I don't care about it. If
+;;; you do please feel free to submit a patch.
+(defmethod xml-element-to-event ((connection connection)
+ (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))))
+
+;;
+;; Receive stanzas
+;;
+
(defmethod receive-stanza-loop ((connection connection) &key
(stanza-callback 'default-stanza-callback)
- (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 connection :dom-repr dom-repr)))
((equal tagname "stream:error")
(when stanza-callback
(funcall stanza-callback stanza connection :dom-repr dom-repr))
@@ -221,11 +347,17 @@
(with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth")
(cxml:with-element "username" (cxml:text username))))
-;;; XXX: Add support for digest authentication.
-(defmethod auth ((connection connection) username password resource)
+(defmethod auth ((connection connection) username password resource &key digestp)
(with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth")
(cxml:with-element "username" (cxml:text username))
- (cxml:with-element "password" (cxml:text password))
+ (if digestp
+ (if (stream-id connection)
+ (cxml:with-element "digest" (cxml:text
+ (make-digest-password
+ (stream-id connection)
+ password)))
+ (error "stream-id on ~a not set, cannot make digest password" connection))
+ (cxml:with-element "password" (cxml:text password)))
(cxml:with-element "resource" (cxml:text resource))))
(defmethod presence ((connection connection) &key type to)
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.6 cl-xmpp/result.lisp:1.7
--- cl-xmpp/result.lisp:1.6 Mon Oct 31 18:02:04 2005
+++ cl-xmpp/result.lisp Mon Oct 31 22:07:15 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $
+;;;; $Id: result.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -106,44 +106,6 @@
(format stream "~a=~a" (name object) (value object))))
;;
-;; Produce DOM-ish structure from the XML DOM returned by cxml.
-;;
-
-(defmethod parse-result ((objects list))
- (mapcar #'parse-result objects))
-
-(defmethod parse-result ((document dom-impl::document))
- (let (objects)
- (dom:map-node-list #'(lambda (node)
- (push (parse-result node) objects))
- (dom:child-nodes document))
- objects))
-
-(defmethod parse-result ((attribute dom-impl::attribute))
- (let* ((name (dom:node-name attribute))
- (value (dom:value attribute))
- (xml-attribute
- (make-instance 'xml-attribute
- :name name :value value :node attribute)))
- xml-attribute))
-
-(defmethod parse-result ((node dom-impl::character-data))
- (let* ((name (dom:node-name node))
- (data (dom:data node))
- (xml-element (make-instance 'xml-element
- :name name :data data :node node)))
- xml-element))
-
-(defmethod parse-result ((node dom-impl::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)))
- (dom:do-node-list (child (dom:child-nodes node))
- (push (parse-result child) (elements xml-element)))
- xml-element))
-
-;;
;; Event interface
;;
@@ -172,17 +134,6 @@
(print-unreadable-object (object stream :type t :identity t)
(format stream "to:~a from:~a" (to object) (from object))))
-;;; XXX: Add support for the element. Also note that
-;;; there may be an XHTML version of the body available in the
-;;; original node but as of right now I don't care about it. If
-;;; 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))))
-
(defclass presence (event)
((to
:accessor to
@@ -206,18 +157,6 @@
(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 element part of the RFC/JEP?
-(defmethod xml-element-to-event ((object xml-element) (name (eql :presence)))
- (let ((show (get-element object :show)))
- (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
- :type- (value (get-attribute object :type)))))
-
(defclass contact ()
((jid
:accessor jid
@@ -349,6 +288,11 @@
:accessor name
:initarg :name)))
+(defmethod print-object ((object xmpp-protocol-error) stream)
+ "Print the object for the Lisp reader."
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "code:~a name:~a" (code object) (name object))))
+
(defclass xmpp-protocol-error-modify (xmpp-protocol-error) ())
(defclass xmpp-protocol-error-cancel (xmpp-protocol-error) ())
(defclass xmpp-protocol-error-wait (xmpp-protocol-error) ())
@@ -372,48 +316,3 @@
(code (third data))
(class (map-error-type-to-class type)))
(make-instance class :code code :name name :xml-element object)))
-
-(defmethod xml-element-to-event ((object xml-element) (name (eql :iq)))
- (let ((id (intern (string-upcase (value (get-attribute object :id))) :keyword)))
- (if (not (string-equal (value (get-attribute object :type)) "result"))
- (make-error (get-element object :error))
- (case id
- (:error (make-error (get-element object :error)))
- (:roster_1 (make-roster object))
- (:reg2 :registration-successful)
- (:unreg_1 :registration-cancellation-successful)
- (:change1 :password-changed-succesfully)
- (:auth2 :authentication-successful)
- (t (cond
- ((member id '(info1 info2 info3))
- (make-disco-info (get-element object :query)))
- ((member id '(items1 items2 items3 items4))
- (make-disco-items (get-element object :query)))))))))
-
-(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)
- (declare (ignore name))
- object)
-
-(defmethod dom-to-event ((object list))
- (mapcar #'dom-to-event object))
-
-(defmethod dom-to-event ((object xml-element))
- (xml-element-to-event
- object (intern (string-upcase (name object)) :keyword)))
-
-;;
-;; Handle
-;;
-
-(defmethod handle ((connection connection) (object list))
- (dolist (object list)
- (handle connection object)))
-
-(defmethod handle ((connection connection) object)
- (format t "~&Received: ~a~%" object))
Index: cl-xmpp/utility.lisp
diff -u cl-xmpp/utility.lisp:1.4 cl-xmpp/utility.lisp:1.5
--- cl-xmpp/utility.lisp:1.4 Mon Oct 31 18:02:04 2005
+++ cl-xmpp/utility.lisp Mon Oct 31 22:07:15 2005
@@ -1,10 +1,13 @@
-;;;; $Id: utility.lisp,v 1.4 2005/10/31 17:02:04 eenge Exp $
+;;;; $Id: utility.lisp,v 1.5 2005/10/31 21:07:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $
;;;; See the LICENSE file for licensing information.
(in-package :xmpp)
+(defmacro fmt (string &rest args)
+ `(format nil ,string , at args))
+
(defun flatten (list)
(cond
((typep list 'atom) list)
@@ -12,25 +15,40 @@
(flatten (cdr list))))
((typep (car list) 'list) (flatten (append (car list) (cdr list))))))
-(defun string-to-array (string)
- (let ((array (make-array (length string))))
+(defun string-to-array (string &rest args)
+ (let ((array (apply #'make-array (length string) args)))
(dotimes (position (length string))
(setf (aref array position) (char-code (aref string position))))
array))
-(defun default-stanza-callback (stanza connection &key dom-repr)
- (let ((result (parse-result stanza)))
- (if dom-repr
- (handle connection result)
- (handle connection (dom-to-event result)))))
+(defun hex-array-to-ascii-string (array)
+ (let ((string (make-string 0)))
+ (dotimes (position (length array))
+ (let ((element (aref array position))
+ (*print-base* 16))
+ (setq string (fmt "~a~a" string element)))) ; probably inefficient
+ string))
+
+;;; borrowed from ironclad, so Copyright (C) 2004 Nathan Froyd
+(defun ascii-string-to-byte-array (string)
+ (let ((vec (make-array (length string) :element-type '(unsigned-byte 8))))
+ (dotimes (i (length string) vec)
+ (let ((byte (char-code (char string i))))
+ (assert (< byte 256))
+ (setf (aref vec i) byte)))))
+
+(defun digestify-string (string)
+ (hex-array-to-ascii-string
+ (ironclad:digest-sequence
+ :sha1 (ascii-string-to-byte-array string))))
+
+(defun make-digest-password (stream-id password)
+ (string-downcase (digestify-string (fmt "~a~a" stream-id password))))
-;; um, refactor?
-(defun default-init-callback (stanza connection &key dom-repr)
- (let ((result (parse-result stanza)))
+(defun default-stanza-callback (stanza connection &key dom-repr)
+ (let ((result (parse-result connection stanza)))
(if dom-repr
(handle connection result)
- (handle connection (dom-to-event result)))))
+ (handle connection (dom-to-event connection result)))))
-(defmacro fmt (string &rest args)
- `(format nil ,string , at args))
From eenge at common-lisp.net Mon Oct 31 21:10:34 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 31 Oct 2005 22:10:34 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051031211034.DB76C880DB@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv15264
Modified Files:
index.html
Log Message:
up'ing to 0.5.0
Date: Mon Oct 31 22:10:34 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.14 public_html/index.html:1.15
--- public_html/index.html:1.14 Mon Oct 31 18:08:33 2005
+++ public_html/index.html Mon Oct 31 22:10:34 2005
@@ -7,7 +7,7 @@
@@ -32,12 +32,14 @@
- A recent SBCL (need 16bit wide characters), LispWorks or Allegro (patches welcome for others)
- cxml
+ - Ironclad
News
+ - Version 0.5.0 released (Now depending on Ironclad for digest authentication)
- Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)
- Version 0.3.0 released (Added Allegro and LispWorks support)
- Version 0.2.0 released (JEP 0073 support)