cl-xmpp-cvs July 2008

cl-xmpp-cvs@common-lisp.net

1 participants
6 discussions

[cl-xmpp-cvs] CVS cl-xmpp
by ehuelsmann 13 Jul '08

13 Jul '08

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/tmp/cvs-serv5419 Modified Files: cl-xmpp.lisp Log Message: Inform user about deprecated auth mechanisms; pointing to correct ones. --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2008/07/09 21:02:40 1.34 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2008/07/13 21:43:47 1.35 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.34 2008/07/09 21:02:40 ehuelsmann Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.35 2008/07/13 21:43:47 ehuelsmann Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -521,6 +521,7 @@ result)) (defmethod %plain-auth% ((connection connection) username password resource) + (warn "RFC 3920 deprecated :PLAIN auth; use :SASL-PLAIN instead.") (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)) @@ -530,6 +531,7 @@ (add-auth-method :plain '%plain-auth%) (defmethod %digest-md5-auth% ((connection connection) username password resource) + (warn "RFC 3920 deprecated :DIGEST-MD5 auth; use :SASL-DIGEST-MD5 instead.") (with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth") (cxml:with-element "username" (cxml:text username)) (if (stream-id connection)

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by ehuelsmann 09 Jul '08

09 Jul '08

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/home/ehuelsmann/cl-xmpp-cvs Modified Files: result.lisp Log Message: Change constant to parameter because of 'Idiosyncracies'. --- /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp 2008/07/09 21:02:40 1.14 +++ /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp 2008/07/09 21:15:57 1.15 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.14 2008/07/09 21:02:40 ehuelsmann Exp $ +;;;; $Id: result.lisp,v 1.15 2008/07/09 21:15:57 ehuelsmann Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -522,7 +522,7 @@ (reason object)))) -(defconstant +invitation-node+ "http://jabber.org/protocol/muc#user") +(defparameter +invitation-node+ "http://jabber.org/protocol/muc#user") (defmethod get-invitation ((object xml-element))

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by ehuelsmann 09 Jul '08

09 Jul '08

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) ,@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)) ,@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)) + ,@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(a)macbeth.shakespeare.lit' +;; id='voice2' +;; to='crone1(a)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(a)macbeth.shakespeare.lit' + to='hecate(a)shakespeare.lit'> + <body>You have been invited to darkcave@macbeth by crone1(a)shakespeare.lit.</body> + <x xmlns='http://jabber.org/protocol/muc#user'> + <invite from='crone1(a)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(a)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(a)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(a)shakespeare.lit/desktop' ;; to='darkcave(a)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(a)shakespeare.lit/pda' ;; to='darkcave(a)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(a)shakespeare.lit/pda' ;; to='darkcave(a)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(a)shakespeare.lit/desktop' ;; to='darkcave(a)macbeth.shakespeare.lit'> ;; <x xmlns='http://jabber.org/protocol/muc#user'> ;; <invite to='hecate(a)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(a)shakespeare.lit/pda' ;; id='kick1' ;; to='harfleur(a)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(a)shakespeare.lit/desktop' ;; id='member1' ;; to='darkcave(a)macbeth.shakespeare.lit' ;; type='set'> ;; <query xmlns='http://jabber.org/protocol/muc#admin'> ;; <item affiliation='member' ;; jid='hag66(a)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(a)shakespeare.lit/pda' ;; to='darkcave(a)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(a)shakespeare.lit/laptop' ;; to='darkcave(a)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(a)shakespeare.lit/desktop' ;; id='begone' ;; to='heath(a)macbeth.shakespeare.lit' ;; type='set'> ;; <query xmlns='http://jabber.org/protocol/muc#owner'> ;; <destroy jid='darkcave(a)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(a)shakespeare.lit/desktop' ;; id='voice2' ;; to='darkcave(a)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")))))

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by ehuelsmann 09 Jul '08

09 Jul '08

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/home/ehuelsmann/cl-xmpp-cvs Modified Files: cl-xmpp.asd cl-xmpp.lisp Log Message: Move cl-xmpp from trivial-sockets to usocket. --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd 2008/07/09 19:51:17 1.8 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd 2008/07/09 19:58:50 1.9 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp.asd,v 1.8 2008/07/09 19:51:17 ehuelsmann Exp $ +;;;; $Id: cl-xmpp.asd,v 1.9 2008/07/09 19:58:50 ehuelsmann Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -16,7 +16,7 @@ :author "Erik Enge" :licence "MIT" :description "Common Lisp XMPP client implementation" - :depends-on (#+sbcl :sb-bsd-sockets :trivial-sockets :cxml :ironclad) + :depends-on (:usocket :cxml :ironclad) :components ((:file "package") (:file "variable" :depends-on ("package")) --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2008/07/09 19:51:17 1.32 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2008/07/09 19:58:50 1.33 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.32 2008/07/09 19:51:17 ehuelsmann Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.33 2008/07/09 19:58:50 ehuelsmann Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -84,8 +84,9 @@ but I'm trying not to optimize too early plus if you are going to do in-band registration (JEP0077) then you don't have a JID until after you've connected." - (let* ((stream (trivial-sockets:open-stream - hostname port :element-type '(unsigned-byte 8))) + (let* ((stream (usocket:socket-stream + (usocket:socket-connect + hostname port :element-type '(unsigned-byte 8)))) (connection (make-instance class :jid-domain-part jid-domain-part :server-stream stream

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by ehuelsmann 09 Jul '08

09 Jul '08

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/home/ehuelsmann/cl-xmpp-cvs Modified Files: cl-xmpp-sasl.lisp Log Message: Fixed stream reset after SASL authentication. Patch by lichtblau. --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp 2005/11/17 21:51:15 1.11 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp 2008/07/09 19:53:19 1.12 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.11 2005/11/17 21:51:15 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.12 2008/07/09 19:53:19 ehuelsmann Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -68,10 +68,19 @@ (if (eq (name second-challenge) :challenge) (progn (send-second-response connection) - (receive-stanza connection)) + (when (eq (receive-stanza connection) + :authentication-successful) + (begin-xml-stream connection) + (reset-stream connection))) second-challenge))))) initial-challenge)))) +(defun reset-stream (connection) + (setf (server-source connection) + (cxml:make-source + (cxml::source-xstream (server-source connection)) + :buffering nil))) + (defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client) (with-xml-stream (stream connection) (xml-output

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by ehuelsmann 09 Jul '08

09 Jul '08

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/home/ehuelsmann/cl-xmpp-cvs Modified Files: cl-xmpp.asd cl-xmpp.lisp Removed Files: cxml.lisp Log Message: Removed cxml.lisp; slow-xstream. Patch by lichtblau. --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd 2005/12/14 19:03:48 1.7 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd 2008/07/09 19:51:17 1.8 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp.asd,v 1.7 2005/12/14 19:03:48 eenge Exp $ +;;;; $Id: cl-xmpp.asd,v 1.8 2008/07/09 19:51:17 ehuelsmann Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -22,10 +22,8 @@ :depends-on ("package")) (:file "utility" :depends-on ("variable")) - (:file "cxml" - :depends-on ("utility")) (:file "result" - :depends-on ("cxml")) + :depends-on ("utility")) (:file "cl-xmpp" :depends-on ("result")))) --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2007/03/05 17:38:35 1.31 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2008/07/09 19:51:17 1.32 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.31 2007/03/05 17:38:35 jstecklina Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.32 2008/07/09 19:51:17 ehuelsmann Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -320,7 +320,8 @@ (unless (server-source connection) (setf (server-source connection) (cxml:make-source - (cxml:make-xstream (make-slow-stream (server-stream connection)) + (cxml:make-xstream (server-stream connection) + :speed 1 :name (cxml::make-stream-name :entity-name "stanza" @@ -391,7 +392,8 @@ (stream (gensym "stream"))) `(let ((,stream (server-stream ,connection))) (prog1 - (let ((,xml (cxml:with-xml-output (cxml:make-octet-vector-sink) + (let ((,xml (cxml:with-xml-output + (cxml:make-octet-vector-sink :canonical 1) ,@body))) (write-sequence (vector-to-array ,xml) ,stream) (when *debug-stream*

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cl-xmpp-cvs July 2008