[cl-xmpp-cvs] CVS cl-xmpp
ehuelsmann
ehuelsmann at common-lisp.net
Wed Jul 9 21:02:40 UTC 2008
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory clnet:/home/ehuelsmann/cl-xmpp-cvs
Modified Files:
cl-xmpp-sasl.lisp cl-xmpp.asd cl-xmpp.lisp package.lisp
result.lisp variable.lisp
Added Files:
administration.lisp multi-user-chat.lisp
Log Message:
Collected Ravenpack Int'l patches as submitted by Kevin Crosbie (kcrosbie at ravenpack.com).
--- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp 2008/07/09 19:53:19 1.12
+++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp 2008/07/09 21:02:40 1.13
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-sasl.lisp,v 1.12 2008/07/09 19:53:19 ehuelsmann Exp $
+;;;; $Id: cl-xmpp-sasl.lisp,v 1.13 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -9,6 +9,9 @@
(if (eq reply :authentication-successful)
(progn
(begin-xml-stream connection :xml-identifier nil)
+ ;; Clean the server-source.
+ ;; See https://support.process-one.net/browse/EJAB-455
+ (setf (server-source connection) nil)
(receive-stanza connection) ; stream
(receive-stanza connection) ; features
reply)
--- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd 2008/07/09 19:58:50 1.9
+++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd 2008/07/09 21:02:40 1.10
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp.asd,v 1.9 2008/07/09 19:58:50 ehuelsmann Exp $
+;;;; $Id: cl-xmpp.asd,v 1.10 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -18,14 +18,12 @@
:description "Common Lisp XMPP client implementation"
:depends-on (:usocket :cxml :ironclad)
:components ((:file "package")
- (:file "variable"
- :depends-on ("package"))
- (:file "utility"
- :depends-on ("variable"))
- (:file "result"
- :depends-on ("utility"))
- (:file "cl-xmpp"
- :depends-on ("result"))))
+ (:file "variable" :depends-on ("package"))
+ (:file "utility" :depends-on ("variable"))
+ (:file "result" :depends-on ("utility"))
+ (:file "cl-xmpp" :depends-on ("result"))
+ (:file "multi-user-chat" :depends-on ("cl-xmpp"))
+ (:file "administration" :depends-on ("cl-xmpp"))))
(defmethod perform ((operation test-op) (component (eql (find-system 'cl-xmpp))))
(operate 'load-op 'cl-xmpp-test)
--- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2008/07/09 19:58:50 1.33
+++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2008/07/09 21:02:40 1.34
@@ -1,10 +1,14 @@
-;;;; $Id: cl-xmpp.lisp,v 1.33 2008/07/09 19:58:50 ehuelsmann Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.34 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
(in-package :xmpp)
+;; Define our own error condition for server disconnections
+(define-condition server-disconnect (simple-condition)
+ ())
+
(defclass connection ()
((server-stream
:accessor server-stream
@@ -47,7 +51,14 @@
(port
:accessor port
:initarg :port
- :initform *default-port*))
+ :initform *default-port*)
+ (stanza-thread
+ :accessor stanza-thread
+ :initform nil)
+ (stanza-callback
+ :accessor stanza-callback
+ :initarg :stanza-callback
+ :initform 'default-stanza-callback))
(:documentation "A TCP connection between this XMPP client and
an, assumed, XMPP compliant server. The connection does not
know whether or not the XML stream has been initiated nor whether
@@ -67,7 +78,7 @@
;;; connect-tls to be the same.
(defun connect (&key (hostname *default-hostname*) (port *default-port*)
(receive-stanzas t) (begin-xml-stream t) jid-domain-part
- (class 'connection))
+ (class 'connection) stanza-callback)
"Open TCP connection to hostname.
By default this will set up the complete XML stream and receive the initial
@@ -91,7 +102,8 @@
:jid-domain-part jid-domain-part
:server-stream stream
:hostname hostname
- :port port)))
+ :port port
+ :stanza-callback stanza-callback)))
(when begin-xml-stream
(begin-xml-stream connection))
(when receive-stanzas
@@ -202,10 +214,10 @@
(if errorp
(make-error errorp)
(case id
- (:error (make-error errorp))
+ (:error (make-error object))
(:roster_1 (make-roster object))
(:reg2 :registration-successful)
- (:unreg_1 :registration-cancellation-successful)
+ ((:unreg_1 :unreg1) :registration-cancellation-successful)
(:change1 :password-changed-successfully)
(:auth2 :authentication-successful)
(:bind_2 :bind-successful)
@@ -213,14 +225,17 @@
(t
(case type
(:get (warn "Don't know how to handle IQ get yet."))
+ (:result
+ ;; assuming a simple result (no query)
+ (make-simple-result object))
(t
(cond
- ((member id '(info1 info2 info3))
+ ((member id '(:info1 :info2 :info3))
(make-disco-info (get-element object :query)))
- ((member id '(items1 items2 items3 items4))
+ ((member id '(:items1 :items2 :items3 :items4))
(make-disco-items (get-element object :query)))
(t ;; Assuming an error
- (make-error (get-element object :error)))))))))))
+ (make-error object))))))))))
(defmethod xml-element-to-event ((connection connection)
(object xml-element) (name (eql :error)))
@@ -279,43 +294,50 @@
;;; 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))
- :id (value (get-attribute object :id))
- :type (value (get-attribute object :type))
- :body (data (get-element (get-element object :body) :\#text))))
+ (cond
+ ((get-invitation object)
+ (make-invitation object))
+ (t
+ (make-message object))))
+
;;
;; Receive stanzas
;;
-(defmethod receive-stanza-loop ((connection connection) &key
- (stanza-callback 'default-stanza-callback)
- dom-repr)
+(defmethod stop-stanza-loop ((connection connection))
+ (setf (stanza-thread connection) nil))
+
+(defmethod receive-stanza-loop ((connection connection)
+ &key stanza-callback dom-repr)
"Reads from connection's stream and parses the XML received
on-the-go. As soon as it has a complete element it calls
the stanza-callback (which by default eventually dispatches
to HANDLE)."
- (loop (receive-stanza connection
+ (setf (stanza-thread connection) t)
+ (unwind-protect
+ (loop while (stanza-thread connection)
+ do (receive-stanza connection
:stanza-callback stanza-callback
- :dom-repr dom-repr)))
+ :dom-repr dom-repr))
+ (setf (stanza-thread connection) nil)))
+
-(defmethod receive-stanza ((connection connection) &key
- (stanza-callback 'default-stanza-callback)
- dom-repr)
+(defmethod receive-stanza ((connection connection)
+ &key stanza-callback dom-repr)
"Returns one stanza. Hangs until one is received."
- (let* ((stanza (read-stanza connection))
- (tagname (dom:tag-name (dom:document-element stanza))))
- (cond
- ((equal tagname "stream:error")
- (when stanza-callback
- (car (funcall stanza-callback stanza connection :dom-repr dom-repr)))
- (error "Received error."))
- (t
- (when stanza-callback
- (car (funcall stanza-callback stanza connection :dom-repr dom-repr)))))))
+ (handler-case
+ (let ((stanza (read-stanza connection))
+ (callback (or stanza-callback (stanza-callback connection))))
+ (when callback
+ (car (funcall callback stanza connection :dom-repr dom-repr))))
+ ;; Catch the cxml well-formedness-violation and propagate it through as
+ ;; a server-disconnection. Perhaps this should be a handler bind and
+ ;; should only propagate when the cxml error has :EOF in it...
+ (cxml:well-formedness-violation (condition)
+ (error 'server-disconnect
+ :format-control (princ-to-string condition)))))
+
(defun read-stanza (connection)
(unless (server-source connection)
@@ -401,7 +423,7 @@
(write-sequence (map 'string #'code-char ,xml) *debug-stream*)))
(force-output ,stream)))))
-(defmacro with-iq ((connection &key id to (type "get")) &body body)
+(defmacro with-iq ((connection &key id to from (type "get")) &body body)
"Macro to make it easier to write IQ stanzas."
`(with-xml-output (,connection)
(cxml:with-element "iq"
@@ -409,18 +431,33 @@
(cxml:attribute "id" ,id))
(when ,to
(cxml:attribute "to" ,to))
+ (when ,from
+ (cxml:attribute "from" ,from))
(cxml:attribute "type" ,type)
, at body)))
-(defmacro with-iq-query ((connection &key xmlns id to node (type "get")) &body body)
+(defmacro with-iq-query ((connection &key xmlns id to from
+ node (type "get")) &body body)
"Macro to make it easier to write QUERYs."
- `(with-iq (,connection :id ,id :type ,type :to ,to)
+ `(with-iq (,connection :id ,id :type ,type :to ,to :from ,from)
(cxml:with-element "query"
(cxml:attribute "xmlns" ,xmlns)
(when ,node
(cxml:attribute "node" ,node))
, at body)))
+
+(defmacro with-iq-command ((connection &key xmlns id to from node action (type "get")) &body body)
+ "Macro to make it easier to write COMMANDs."
+ `(with-iq (,connection :id ,id :type ,type :to ,to :from ,from)
+ (cxml:with-element "command"
+ (cxml:attribute "xmlns" ,xmlns)
+ (when ,action
+ (cxml:attribute "action" ,action))
+ (when ,node
+ (cxml:attribute "node" ,node))
+ , at body)))
+
;;
;; Discovery
;;
@@ -470,9 +507,7 @@
call presence on your behalf if the authentication was successful."
(setf (username connection) username)
(let ((result (funcall (get-auth-method mechanism) connection username password resource)))
- (if (and (eq result :authentication-successful)
- bind-et-al)
- (progn
+ (when (and (eq result :authentication-successful) bind-et-al)
(when (feature-p connection :bind)
(bind connection resource)
(receive-stanza connection))
@@ -481,7 +516,9 @@
(receive-stanza connection))
(when send-presence
(presence connection)))
- result)))
+ ;; KC: Always return the result of the auth. Previously the result of the
+ ;; last executed form was returned, which is arbitrary
+ result))
(defmethod %plain-auth% ((connection connection) username password resource)
(with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth")
@@ -593,4 +630,3 @@
(with-iq-query (connection :id "getlist2" :xmlns "jabber:iq:privacy")
(cxml:with-element "list"
(cxml:attribute "name" name))))
-
--- /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp 2005/11/18 21:43:52 1.12
+++ /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp 2008/07/09 21:02:40 1.13
@@ -1,4 +1,4 @@
-;;;; $Id: package.lisp,v 1.12 2005/11/18 21:43:52 eenge Exp $
+;;;; $Id: package.lisp,v 1.13 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -17,7 +17,7 @@
:receive-stanza-loop :begin-xml-stream :end-xml-stream :with-iq
:with-iq-query :connection :username :mechanisms :features
:feature-p :feature-required-p :mechanism-p :receive-stanza
- :server-stream
+ :server-stream :stop-stanza-loop
;; only available if you've loaded cl-xmpp-tls
:connect-tls :connect-tls2
;; xmpp commands
@@ -48,9 +48,28 @@
:identity-
:disco :identities
:disco-items :items
- :item :jid
- :message :to :from :body
+ :item :jid :id
+ :message :to :from :body :subject :type- :chatroom :password
+ :simple-result :invitation
;; user-hooks for handling events
:handle
;; variables
- :*default-port :*default-hostname* :*errors* :*debug-stream*)))
+ :*default-port :*default-hostname* :*errors* :*debug-stream*
+ ;; multi-user-chat
+ :create-chatroom
+ :join-chatroom
+ :leave-chatroom
+ :invite-to-chatroom
+ :kick-from-chatroom
+ :grant-room-membership
+ :revoke-room-membership
+ :broadcast-room
+ :set-chatroom-subject
+ :default-room-config
+ :destroy-chatroom
+ :revoke-voice
+ :get-online-users
+ ;; errors
+ :server-disconnect
+
+ )))
--- /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp 2005/12/31 20:15:06 1.13
+++ /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp 2008/07/09 21:02:40 1.14
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.13 2005/12/31 20:15:06 eenge Exp $
+;;;; $Id: result.lisp,v 1.14 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -61,27 +61,40 @@
:initform nil)))
(defmethod data (object)
+ (declare (ignore object))
nil)
(defmethod print-object ((object xml-element) stream)
"Print the object for the Lisp reader."
(print-unreadable-object (object stream :type t :identity t)
- (format stream "~a (~aattr:~achild:~adata)"
+ (format stream "~a (~a:~_~a:~_~a)"
(name object)
- (length (attributes object))
- (length (elements object))
- (length (data object)))))
+ (attributes object)
+ (elements object)
+ (data object))))
(defmethod get-attribute ((element xml-element) name &key (test 'eq))
(dolist (attribute (attributes element))
(when (funcall test name (name attribute))
(return-from get-attribute attribute))))
+;; KC: The get-element function is not correct to use as is, because it
+;; basically returns the first element that matches in the list.
+;; It is possible to have multiple matching elements.
+;; The correct solution that I have provided is to provide a get-elements
+;; function that returns all matching elements and allows the user to choose
+;; which they want.
+;; I have not removed the old get-element function or any code that uses it.
(defmethod get-element ((element xml-element) name &key (test 'eq))
(dolist (subelement (elements element))
(when (funcall test name (name subelement))
(return-from get-element subelement))))
+(defmethod get-elements ((element xml-element) name &key (test 'eq))
+ (loop for subelement in (elements element)
+ when (funcall test name (name subelement))
+ collect subelement))
+
(defclass xml-attribute ()
((name
:accessor name
@@ -96,11 +109,12 @@
:initform nil)))
(defmethod value (object)
+ (declare (ignore object))
nil)
(defmethod print-object ((object xml-attribute) stream)
"Print the object for the Lisp reader."
- (print-unreadable-object (object stream :type t :identity t)
+ (print-unreadable-object (object stream :type nil :identity nil)
(format stream "~a=~a" (name object) (value object))))
;;
@@ -113,6 +127,10 @@
:initarg :xml-element
:initform nil)))
+(defmethod print-object ((object event) stream)
+ (print-unreadable-object (object stream :type nil :identity nil)
+ (format stream "~a" (xml-element object))))
+
(defclass message (event)
((to
:accessor to
@@ -126,6 +144,10 @@
:accessor body
:initarg :body
:initform "")
+ (subject
+ :accessor subject
+ :initarg :subject
+ :initform "")
(id
:accessor id
:initarg :id
@@ -138,11 +160,28 @@
(defmethod print-object ((object message) stream)
"Print the object for the Lisp reader."
(print-unreadable-object (object stream :type t :identity t)
- (format stream "to:~a from:~a id:~a type:~a"
+ (format stream "to:~a from:~a id:~a type:~a subject:~a"
(to object)
(from object)
(id object)
- (type- object))))
+ (type- object)
+ (subject object))))
+
+
+(defmethod make-message ((object xml-element))
+ (let ((body-element (or (get-element object :body)
+ (get-element object :x)))
+ (subject-element (get-element object :subject)))
+ (make-instance 'message
+ :xml-element object
+ :from (value (get-attribute object :from))
+ :to (value (get-attribute object :to))
+ :id (value (get-attribute object :id))
+ :type (value (get-attribute object :type))
+ :body (data (and body-element (get-element body-element :\#text)))
+ :subject (data (and subject-element
+ (get-element subject-element :\#text))))))
+
(defclass presence (event)
((to
@@ -249,6 +288,11 @@
:initarg :features
:initform nil)))
+(defmethod print-object ((object disco-info) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "~a ~_~a" (identities object) (features object))))
+
+
(defmethod make-disco-info ((object xml-element))
(let ((disco-info (make-instance 'disco-info :xml-element object)))
(dolist (element (elements object))
@@ -287,7 +331,7 @@
disco-items))
;;
-;; Error
+;; Errors
;;
(defclass xmpp-protocol-error (event)
@@ -296,26 +340,37 @@
:initarg :code)
(name
:accessor name
- :initarg :name)))
+ :initarg :name)
+ (text
+ :accessor text
+ :initarg :text)))
(defmethod print-object ((object xmpp-protocol-error) stream)
"Print the object for the Lisp reader."
(print-unreadable-object (object stream :type nil :identity t)
- (format stream "~a code:~a name:~a"
+ (format stream "~a code:~a name:~a ~_elem:~a"
(type-of object)
(code object)
- (name object))))
+ (name object)
+ (xml-element 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) ())
(defclass xmpp-protocol-error-auth (xmpp-protocol-error) ())
-(defun get-error-data-name (name)
- (assoc name *errors*))
+(defun get-legacy-error-data-code (code)
+ (rassoc code *legacy-errors* :key #'second))
-(defun get-error-data-code (code)
- (rassoc code *errors* :key #'second))
+(defun find-error-data (elements)
+ "An error can be of the form <errorname> so this function searches the
+ errors that we know about until we find one that's in our element list"
+ (or (find-if #'(lambda (elt)
+ (member elt elements :key #'name))
+ *legacy-errors* :key #'car)
+ (find-if #'(lambda (elt)
+ (member elt elements :key #'name))
+ *errors* :key #'car)))
(defun map-error-type-to-class (type)
(case type
@@ -323,30 +378,175 @@
(:cancel (find-class 'xmpp-protocol-error-cancel))
(:wait (find-class 'xmpp-protocol-error-wait))
(:auth (find-class 'xmpp-protocol-error-auth))
- (t (format *debug-stream* "~&Unable to find error class for ~w.~&" type)
+ (t (format *debug-stream* "~&Unable to find error class for ~w.~%" type)
(find-class 'xmpp-protocol-error))))
;;; XXX: Handle legacy errors
+(defmethod make-legacy-error ((object xml-element))
+ (let* ((code-value (value (get-attribute object :code)))
+ (code (parse-integer code-value))
+ (data (get-legacy-error-data-code code))
+ (name (first data))
+ (type (second data))
+ (text name)
+ (class (map-error-type-to-class type)))
+ (make-instance class
+ :xml-element object
+ :code code
+ :name name
+ :text text)))
+
(defmethod make-error ((object xml-element))
- (let ((code-value (value (get-attribute object :code)))
- (code)
- (name)
- (type)
- (class))
- ; Slightly verbose but there are still cases I have not
- ; addressed (and have no examples of, any more) so I'm going
- ; to leave it like this for now.
- (if code-value
- (let* ((code-number (parse-integer code-value))
- (data (get-error-data-code code-number)))
- (setq code code-number)
- (setq name (first data))
- (setq type (second data))
- (setq class (map-error-type-to-class type)))
- (let* ((name (name (first (elements object))))
- (data (get-error-data-name name)))
- (format *debug-stream* "~&Name: ~a~&" name)
- (setq code (first data))
- (setq type (second data))
- (setq class (map-error-type-to-class type))))
- (make-instance class :code code :name name :xml-element object)))
+ "Handle errors as defined in:
+ XEP-0086 for legacy errors
+ RFC-3920 for current standard
+ Attempts to provide the proper mappings to bridge the two."
+ (if (get-attribute object :code)
+ (make-legacy-error object)
+ ;; Slightly verbose but there are still cases I have not
+ ;; addressed (and have no examples of, any more) so I'm going
+ ;; to leave it like this for now.
+ (let* ((elements (elements object))
+ ;; KC: Fixed this. Previous code looked at the first element
+ ;; which doesn't have to be the condition.
+ (condition (find-error-data elements))
+ (text-elt (get-element object :\#text))
+ (text (and text-elt (data text-elt)))
+ (name (first condition))
+ (type (second condition))
+ (code (third condition))
+ (class (map-error-type-to-class type)))
+ (make-instance class
+ :xml-element object
+ :code code
+ :name name
+ :text text))))
+
+;;<iq from='darkcave at macbeth.shakespeare.lit'
+;; id='voice2'
+;; to='crone1 at shakespeare.lit/desktop'
+;; type='result'/>
+
+(defclass simple-result (event)
+ ((node
+ :accessor node
+ :initarg :node
+ :initform nil)
+ (to
+ :accessor to
+ :initarg :to
+ :initform nil)
+ (from
+ :accessor from
+ :initarg :from
+ :initform nil)
+ (id
+ :accessor id
+ :initarg :id
+ :initform nil)
+ (type
+ :accessor type-
+ :initarg :type
+ :initform nil)
+ (items
+ :accessor items
+ :initarg :items
+ :initform nil)))
+
+(defmethod print-object ((object simple-result) stream)
+ "Print the object for the Lisp reader."
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "node: ~a to:~a from:~a id:~a type:~a items: ~a"
+ (node object)
+ (to object)
+ (from object)
+ (id object)
+ (type- object)
+ (length (items object)))))
+
+(defmethod make-simple-result ((object xml-element))
+ (let* ((query (first (get-elements object :query)))
+ (item-list (and query (get-elements query :item))))
+ (make-instance 'simple-result
+ :xml-element object
+ :node (value (get-attribute query :node))
+ :to (value (get-attribute object :to))
+ :from (value (get-attribute object :from))
+ :id (value (get-attribute object :id))
+ :type (value (get-attribute object :type))
+ :items (mapcar #'make-item item-list))))
+
+#|
+
+<message
+ from='darkcave at macbeth.shakespeare.lit'
+ to='hecate at shakespeare.lit'>
+ <body>You have been invited to darkcave at macbeth by crone1 at shakespeare.lit.</body>
+ <x xmlns='http://jabber.org/protocol/muc#user'>
+ <invite from='crone1 at shakespeare.lit'>
+ <reason>
+ Hey Hecate, this is the place for all good witches!
+ </reason>
+ </invite>
+ <password>cauldronburn</password>
+ </x>
+</message>
+
+|#
+
+(defclass invitation (message)
+ ((chatroom
+ :accessor chatroom
+ :initarg :chatroom
+ :initform nil)
+ (password
+ :accessor password
+ :initarg :password
+ :initform nil)
+ (reason
+ :accessor reason
+ :initarg :reason
+ :initform nil)))
+
+
+(defmethod print-object ((object invitation) stream)
+ "Print the object for the Lisp reader."
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "to:~a from:~a id:~a type:~a"
+ (to object)
+ (from object)
+ (id object)
+ (type- object)
+ (chatroom object)
+ (password object)
+ (reason object))))
+
+
+(defconstant +invitation-node+ "http://jabber.org/protocol/muc#user")
+
+
+(defmethod get-invitation ((object xml-element))
+ (let ((x-elements (get-elements object :x)))
+ (find-if #'(lambda (element)
+ (let ((attr (get-attribute element :xmlns)))
+ (and attr (string-equal (value attr) +invitation-node+))))
+ x-elements)))
+
+
+(defmethod make-invitation ((object xml-element))
+ (let* ((x-element (get-invitation object))
+ (invite (and x-element (get-element x-element :invite)))
+ (reason (and invite (get-element invite :reason)))
+ (password (and x-element (get-element x-element :password)))
+ (body (get-element object :body)))
+ (make-instance 'invitation
+ :xml-element object
+ :to (value (get-attribute object :to))
+ :from (or (and invite (value (get-attribute invite :from)))
+ (value (get-attribute object :from)))
+ :id (value (get-attribute object :id))
+ :type (value (get-attribute object :type))
+ :body (and body (data (get-element body :\#text)))
+ :chatroom (value (get-attribute object :from))
+ :password (and password (data (get-element password :\#text)))
+ :reason (and reason (data (get-element reason :\#text))))))
--- /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp 2005/11/18 21:43:52 1.5
+++ /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp 2008/07/09 21:02:40 1.6
@@ -1,4 +1,4 @@
-;;;; $Id: variable.lisp,v 1.5 2005/11/18 21:43:52 eenge Exp $
+;;;; $Id: variable.lisp,v 1.6 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -11,30 +11,59 @@
(defvar *default-port* 5222)
(defvar *default-hostname* "localhost")
-(defvar *errors*
- '((:bad-request :modify 400)
- (:conflict :cancel 409)
- (:feature-not-implemented :cancel 501)
+(defvar *legacy-errors*
+ '((:undefined-condition :any 500)
(: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)
+ (:bad-auth :auth 401)
(:not-authorized :auth 401)
(:payment-required :auth 402)
- (:recipient-unavailable :wait 404)
- (:redirect :modify 302)
(:registration-required :auth 407)
+ (:subscription-required :auth 407)
+ (:redirect :modify 302)
+ (:bad-request :modify 400)
+ (:jid-malformed :modify 400)
+ (:not-acceptable :modify 406)
+ (:gone :modify 302)
+ (:conflict :cancel 409)
+ (:feature-not-implemented :cancel 501)
+ (:item-not-found :cancel 404)
+ (:not-allowed :cancel 405)
(:remote-server-not-found :cancel 404)
+ (:service-unavailable :cancel 503)
+ (:internal-server-error :wait 500)
+ (:recipient-unavailable :wait 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)))
+
+(defvar *errors*
+ '((:bad-format)
+ (:bad-namespace-prefix)
+ (:conflict)
+ (:connection-timeout)
+ (:host-gone)
+ (:host-unknown)
+ (:improper-addressing)
+ (:internal-server-error)
+ (:invalid-from)
+ (:invalid-id)
+ (:invalid-namespace)
+ (:invalid-xml)
+ (:not-authorized)
+ (:policy-violation)
+ (:remote-connection-failed)
+ (:resource-constraint)
+ (:restricted-xml)
+ (:see-other-host)
+ (:system-shutdown)
+ (:undefined-condition)
+ (:unsupported-encoding)
+ (:unsupported-stanza-type)
+ (:unsupported-version)
+ (:xml-not-well-formed)))
+
+
(defvar *auth-methods* nil
"Alist of method name to operator.
--- /project/cl-xmpp/cvsroot/cl-xmpp/administration.lisp 2008/07/09 21:02:40 NONE
+++ /project/cl-xmpp/cvsroot/cl-xmpp/administration.lisp 2008/07/09 21:02:40 1.1
;;;; $Id: administration.lisp,v 1.1 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/administration.lisp,v $
(in-package :cl-xmpp)
;;<iq from='bard at shakespeare.lit/globe'
;; id='end-user-session-1'
;; to='shakespeare.lit'
;; type='get'
;; xml:lang='en'>
;; <command xmlns='http://jabber.org/protocol/commands'
;; action='execute'
;; node='http://jabber.org/protocol/admin#end-user-session'/>
;;</iq>
;;<iq type="set" to="shakespeare.lit" id="ae23a" >
;; <command xmlns="http://jabber.org/protocol/commands"
;; node="http://jabber.org/protocol/admin#end-user-session"
;; sessionid="2007-12-04T11:56:33.920539Z" >
;; <x xmlns="jabber:x:data" type="submit" >
;; <field type="hidden" var="FORM_TYPE" >
;; <value>http://jabber.org/protocol/admin</value>
;; </field>
;; <field type="jid-single" var="accountjid" >
;; <value>bard at shakespeare.lit</value>
;; </field>
;; </x>
;; </command>
;;</iq>
(defmethod end-user-session ((connection connection) &key to server)
(with-xml-output (connection)
(with-iq-command
(connection :xmlns "http://jabber.org/protocol/commands"
:node "http://jabber.org/protocol/admin#end-user-session"
:to server
:type "set")
(cxml:with-element "x"
(cxml:attribute "xmlns" "jabber:x:data")
(cxml:attribute "type" "submit")
(with-form-field "hidden" "FORM_TYPE" "http://jabber.org/protocol/admin")
(with-form-field "jid-single" "accountjid" to)))))
;;<iq type="get"
;; to="shakespeare.lit"
;; id="ab48a" >
;; <query xmlns="http://jabber.org/protocol/disco#items"
;; node="online users" />
;;</iq>
(defmethod get-online-users ((connection connection) &key server)
(with-xml-output (connection)
(with-iq-query (connection :type "get" :to server
:xmlns "http://jabber.org/protocol/disco#items"
:node "online users"))))
--- /project/cl-xmpp/cvsroot/cl-xmpp/multi-user-chat.lisp 2008/07/09 21:02:40 NONE
+++ /project/cl-xmpp/cvsroot/cl-xmpp/multi-user-chat.lisp 2008/07/09 21:02:40 1.1
;;;; $Id: multi-user-chat.lisp,v 1.1 2008/07/09 21:02:40 ehuelsmann Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/multi-user-chat.lisp,v $
(in-package :cl-xmpp)
;;
;; Multi User Chat
;;
;;<presence
;; from='crone1 at shakespeare.lit/desktop'
;; to='darkcave at macbeth.shakespeare.lit/firstwitch'>
;; <x xmlns='http://jabber.org/protocol/muc'/>
;;</presence>
(defmethod create-chatroom ((connection connection) &key from room priority)
(with-xml-output (connection)
(cxml:with-element "presence"
(cxml:attribute "to" room)
(cxml:attribute "from" from)
(when priority
(cxml:with-element "priority"
(cxml:text "0")))
(cxml:with-element "x"
(cxml:attribute "xmlns" "http://jabber.org/protocol/muc")))))
;;<presence
;; from='hag66 at shakespeare.lit/pda'
;; to='darkcave at macbeth.shakespeare.lit/thirdwitch'/>
(defmethod join-chatroom ((connection connection) &key from room password)
(with-xml-output (connection)
(cxml:with-element "presence"
(cxml:attribute "to" room)
(cxml:attribute "from" from)
(when password
(cxml:with-element "x"
(cxml:attribute "xmlns" "http://jabber.org/protocol/muc")
(cxml:with-element "password"
(cxml:text password)))))))
;;<presence
;; from='hag66 at shakespeare.lit/pda'
;; to='darkcave at macbeth.shakespeare.lit/thirdwitch'
;; type='unavailable'/>
(defmethod leave-chatroom ((connection connection) &key from room)
(with-xml-output (connection)
(cxml:with-element "presence"
(cxml:attribute "to" room)
(cxml:attribute "from" from)
(cxml:attribute "type" "unavailable"))))
;;<message
;; from='crone1 at shakespeare.lit/desktop'
;; to='darkcave at macbeth.shakespeare.lit'>
;; <x xmlns='http://jabber.org/protocol/muc#user'>
;; <invite to='hecate at shakespeare.lit'>
;; <reason>
;; Hey Hecate, this is the place for all good witches!
;; </reason>
;; </invite>
;; </x>
;;</message>
(defmethod invite-to-chatroom ((connection connection)
&key from room to reason)
(with-xml-output (connection)
(cxml:with-element "message"
(cxml:attribute "to" room)
(cxml:attribute "from" from)
(cxml:with-element "x"
(cxml:attribute "xmlns" "http://jabber.org/protocol/muc#user")
(cxml:with-element "invite"
(cxml:attribute "to" to)
(cxml:with-element "reason"
(cxml:text reason)))))))
;;<iq from='fluellen at shakespeare.lit/pda'
;; id='kick1'
;; to='harfleur at henryv.shakespeare.lit'
;; type='set'>
;; <query xmlns=''>
;; <item nick='pistol' role='none'>
;; <reason>Avaunt, you cullion!</reason>
;; </item>
;; </query>
;;</iq>
(defmethod kick-from-chatroom ((connection connection)
&key to room reason)
(with-xml-output (connection)
(with-iq-query (connection :to room :type "set"
:xmlns "http://jabber.org/protocol/muc#admin")
(cxml:with-element "item"
(cxml:attribute "nick" to)
(cxml:attribute "role" "none")
(cxml:with-element "reason"
(cxml:text reason))))))
;;<iq from='crone1 at shakespeare.lit/desktop'
;; id='member1'
;; to='darkcave at macbeth.shakespeare.lit'
;; type='set'>
;; <query xmlns='http://jabber.org/protocol/muc#admin'>
;; <item affiliation='member'
;; jid='hag66 at shakespeare.lit'/>
;; </query>
;;</iq>
(defmethod set-room-affiliation ((connection connection)
&key room to affiliation)
(with-xml-output (connection)
(with-iq-query (connection :to room :type "set"
:xmlns "http://jabber.org/protocol/muc#admin")
(cxml:with-element "item"
(cxml:attribute "affiliation" affiliation)
(cxml:attribute "jid" to)))))
(defmethod grant-room-membership ((connection connection) &key room to)
(set-room-affiliation connection :room room :to to :affiliation "member"))
(defmethod revoke-room-membership ((connection connection) &key room to)
(set-room-affiliation connection :room room :to to :affiliation "none"))
;;<message
;; from='hag66 at shakespeare.lit/pda'
;; to='darkcave at macbeth.shakespeare.lit'
;; type='groupchat'>
;; <body>Harpier cries: 'tis time, 'tis time.</body>
;;</message>
(defmethod broadcast-room ((connection connection) &key from room message)
(with-xml-output (connection)
(cxml:with-element "message"
(cxml:attribute "from" from)
(cxml:attribute "to" room)
(cxml:attribute "type" "groupchat")
(cxml:with-element "body"
(cxml:text message)))))
(defmacro with-form-field (type var &optional (value ""))
`(cxml:with-element "field"
,(when type
`(cxml:attribute "type" ,type))
,(when var
`(cxml:attribute "var" ,var))
(cxml:with-element "value"
(cxml:text ,(or value "")))))
;; For now these are just the settings that I want to use. It would be easy
;; to change this method so that it takes a list of arguments and looks up
;; nodes/data-types in some structure.
(defmethod default-room-config ((connection connection) &key room)
(with-xml-output (connection)
(with-iq-query (connection :type "set" :to room
:xmlns "http://jabber.org/protocol/muc#owner")
(cxml:with-element "x"
(cxml:attribute "xmlns" "jabber:x:data")
(cxml:attribute "type" "submit")
(with-form-field "hidden" "FORM_TYPE"
"http://jabber.org/protocol/muc#roomconfig")
(with-form-field "text-single" "muc#roomconfig_roomname")
(with-form-field "boolean" "muc#roomconfig_persistentroom" "0")
(with-form-field "boolean" "muc#roomconfig_publicroom" "0")
(with-form-field "boolean" "public_list" "0")
(with-form-field "boolean" "muc#roomconfig_passwordprotectedroom" "0")
(with-form-field "text-private" "muc#roomconfig_roomsecret")
(with-form-field "list-single" "muc#roomconfig_whois" "moderators")
(with-form-field "boolean" "muc#roomconfig_membersonly" "1")
(with-form-field "boolean" "muc#roomconfig_moderatedroom" "0")
(with-form-field "boolean" "members_by_default" "0")
(with-form-field "boolean" "muc#roomconfig_changesubject" "0")
(with-form-field "boolean" "allow_private_messages" "0")
(with-form-field "boolean" "allow_query_users" "0")
(with-form-field "boolean" "muc#roomconfig_allowinvites" "0")))))
;;<message
;; from='wiccarocks at shakespeare.lit/laptop'
;; to='darkcave at macbeth.shakespeare.lit'
;; type='groupchat'>
;; <subject>Fire Burn and Cauldron Bubble!</subject>
;;</message>
(defmethod set-chatroom-subject ((connection connection)
&key from room subject)
(with-xml-output (connection)
(cxml:with-element "message"
(cxml:attribute "from" from)
(cxml:attribute "to" room)
(cxml:attribute "type" "groupchat")
(cxml:with-element "subject"
(cxml:text subject)))))
;;<iq from='crone1 at shakespeare.lit/desktop'
;; id='begone'
;; to='heath at macbeth.shakespeare.lit'
;; type='set'>
;; <query xmlns='http://jabber.org/protocol/muc#owner'>
;; <destroy jid='darkcave at macbeth.shakespeare.lit'>
;; <reason>Macbeth doth come.</reason>
;; </destroy>
;; </query>
;;</iq>
(defmethod destroy-chatroom ((connection connection) &key room reason)
(with-xml-output (connection)
(with-iq-query (connection :type "set" :to room
:xmlns "http://jabber.org/protocol/muc#owner")
(cxml:with-element "destroy"
(cxml:attribute "jid" room)
(when reason
(cxml:with-element "reason"
(cxml:text reason)))))))
;;<iq from='crone1 at shakespeare.lit/desktop'
;; id='voice2'
;; to='darkcave at macbeth.shakespeare.lit'
;; type='set'>
;; <query xmlns='http://jabber.org/protocol/muc#admin'>
;; <item nick='thirdwitch'
;; role='visitor'/>
;; </query>
;;</iq>
(defmethod revoke-voice ((connection connection) &key room nickname)
(with-xml-output (connection)
(with-iq-query (connection :type "set" :to room
:xmlns "http://jabber.org/protocol/muc#admin")
(cxml:with-element "item"
(cxml:attribute "nick" nickname)
(cxml:attribute "role" "visitor")))))
More information about the Cl-xmpp-cvs
mailing list