- cl-xmpp-cvs@common-lisp.net - mailman3.common-lisp.net

[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

[cl-xmpp-cvs] CVS cl-xmpp
by jstecklina 05 Mar '07

05 Mar '07

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/tmp/cvs-serv497 Modified Files: cl-xmpp-tls.lisp cl-xmpp.lisp cxml.lisp Log Message: Removed stanza-handler. (Patch by David Lichteblau) --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp 2005/11/28 15:15:46 1.8 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp 2007/03/05 17:38:35 1.9 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-tls.lisp,v 1.8 2005/11/28 15:15:46 eenge Exp $ +;;;; $Id: cl-xmpp-tls.lisp,v 1.9 2007/03/05 17:38:35 jstecklina Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -48,9 +48,9 @@ (setf (server-stream connection) (cl+ssl:make-ssl-client-stream (server-stream connection) :external-format :iso-8859-1)) - (setf (server-xstream connection) nil) + (setf (server-source connection) nil) (when begin-xml-stream (begin-xml-stream connection)) (when receive-stanzas (receive-stanza connection) - (receive-stanza connection))) \ No newline at end of file + (receive-stanza connection))) --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2007/03/04 04:26:23 1.30 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2007/03/05 17:38:35 1.31 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.30 2007/03/04 04:26:23 jstecklina Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.31 2007/03/05 17:38:35 jstecklina Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -10,8 +10,8 @@ :accessor server-stream :initarg :server-stream :initform nil) - (server-xstream - :accessor server-xstream + (server-source + :accessor server-source :initform nil) (stream-id :accessor stream-id @@ -317,23 +317,37 @@ (car (funcall stanza-callback stanza connection :dom-repr dom-repr))))))) (defun read-stanza (connection) - (unless (server-xstream connection) - (setf (server-xstream connection) - (cxml:make-xstream (make-slow-stream (server-stream connection)) - :name - (cxml::make-stream-name - :entity-name "stanza" - :entity-kind :main - :uri nil)))) + (unless (server-source connection) + (setf (server-source connection) + (cxml:make-source + (cxml:make-xstream (make-slow-stream (server-stream connection)) + :name + (cxml::make-stream-name + :entity-name "stanza" + :entity-kind :main + :uri nil)) + :buffering nil))) (force-output (server-stream connection)) - (catch 'stanza - (let ((cxml::*initial-namespace-bindings* - (acons #"stream" - #"http://etherx.jabber.org/streams" - cxml::*initial-namespace-bindings*))) - (cxml::parse-xstream (server-xstream connection) - (make-instance 'stanza-handler)) - (runes::write-xstream-buffer (server-xstream connection))))) + (let ((source (server-source connection))) + (loop + (multiple-value-bind (key uri lname qname) + (klacks:peek-next source) + (when (eq key :start-element) + (return + (if (and (equal uri "http://etherx.jabber.org/streams") + (equal lname "stream")) + ;; Create an element for DOM-TO-EVENT so we don't have to have + ;; any specialized code just to handle stream:stream. + (let* ((document (cxml-dom:create-document)) + (element (dom:create-element document qname))) + (dom:append-child document element) + (dolist (attribute (klacks:list-attributes source)) + (let ((name (sax::attribute-qname attribute)) + (value (sax::attribute-value attribute))) + (dom:set-attribute element name value))) + document) + (klacks:serialize-element source + (cxml-dom:make-dom-builder))))))))) (defmacro with-xml-stream ((stream connection) &body body) "Helper macro to make it easy to control outputting XML --- /project/cl-xmpp/cvsroot/cl-xmpp/cxml.lisp 2005/12/31 20:15:06 1.10 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cxml.lisp 2007/03/05 17:38:35 1.11 @@ -1,53 +1,17 @@ -;;;; $Id: cxml.lisp,v 1.10 2005/12/31 20:15:06 eenge Exp $ +;;;; $Id: cxml.lisp,v 1.11 2007/03/05 17:38:35 jstecklina Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cxml.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :xmpp) -(defclass stanza-handler (cxml:sax-proxy) - ((depth - :initform 0 - :accessor depth))) - -(defun start-sax-document (handler) - (let ((dom-builder (cxml-dom:make-dom-builder))) - (setf (cxml:proxy-chained-handler handler) dom-builder) - (sax:start-document dom-builder) - dom-builder)) - -(defmethod sax:start-element ((handler stanza-handler) uri lname qname attrs) - (declare (ignore uri lname)) - (when (eql (depth handler) 0) - (if (eq :stream\:stream (ensure-keyword 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 (cxml-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)) - -;;; END-ELEMENT will try and call the stanza-callback at every time -;;; it sees depth reach 0 and there is a callback to be called. -;;; This means that we can keep reading from the stream and as we -;;; close out elements we parse them and return them to users -;;; using callbacks (the one supplied to RECEIVE-STANZA-LOOP). -(defmethod sax:end-element ((handler stanza-handler) uri lname qname) - (declare (ignore uri lname qname)) - (decf (depth handler)) - (call-next-method) - (when (eql (depth handler) 0) - (throw 'stanza - (cxml-dom::document (cxml:proxy-chained-handler handler))))) - ;;; Perform single-byte reads to avoid blocking on the socket. +;;; Also print all data read to *DEBUG-STREAM*. +;;; +;;; FIXME: Is this still needed, now that cxml supports :BUFFERING NIL? +;;; The debugging output could be done using a special gray stream that +;;; dribbles input, instead of a special xstream. --david + (defstruct (slow-stream (:constructor make-slow-stream (target))) (target nil :type stream)) @@ -58,22 +22,13 @@ (when (< start end) (let ((byte (read-byte (slow-stream-target stream) nil))) (when byte + (when *debug-stream* + ;; Original comment: + ;; I'd like to see what CXML is reading from the stream + ;; and this code helps us in that regard by printing it + ;; to the *debug-stream* + (write-char (code-char byte) *debug-stream*)) (setf (elt seq start) byte) (incf start)))) start) -;; I'd like to see what CXML is reading from the stream -;; and this code helps us in that regard by printing it -;; to the *debug-stream* -(defun runes::write-xstream-buffer (xstream &optional (stream *debug-stream*)) - (when stream - (write-string (map 'string - #'code-char - (remove runes::+end+ - (subseq (runes::xstream-buffer xstream) 0 - (runes::xstream-read-ptr xstream)))) - stream) - (force-output stream))) - -(defmethod runes::xstream-underflow :before ((input runes:xstream)) - (runes::write-xstream-buffer input)) \ No newline at end of file

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by jstecklina 04 Mar '07

04 Mar '07

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/tmp/cvs-serv29735 Modified Files: cl-xmpp.lisp Log Message: Replaced fix to namespace problem by suggestion of David Lichteblau --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2007/03/03 18:42:08 1.29 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2007/03/04 04:26:23 1.30 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.29 2007/03/03 18:42:08 jstecklina Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.30 2007/03/04 04:26:23 jstecklina Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -316,16 +316,6 @@ (when stanza-callback (car (funcall stanza-callback stanza connection :dom-repr dom-repr))))))) -;;; XXX: Kludge. Newer versions of CXML rebind *namespace-bindings* -;;; inside of parse-xstream, so the old method of augmenting -;;; *namespace-bindings* inside of read-stanza does not work any -;;; longer. - Julian Stecklina (Mar 03, 2007) - -(unless (assoc #"stream" cxml::*initial-namespace-bindings* - :test #'runes:rod=) - (push (cons #"stream" #"http://etherx.jabber.org/streams") - cxml::*initial-namespace-bindings*)) - (defun read-stanza (connection) (unless (server-xstream connection) (setf (server-xstream connection) @@ -337,9 +327,13 @@ :uri nil)))) (force-output (server-stream connection)) (catch 'stanza - (cxml::parse-xstream (server-xstream connection) - (make-instance 'stanza-handler)) - (runes::write-xstream-buffer (server-xstream connection)))) + (let ((cxml::*initial-namespace-bindings* + (acons #"stream" + #"http://etherx.jabber.org/streams" + cxml::*initial-namespace-bindings*))) + (cxml::parse-xstream (server-xstream connection) + (make-instance 'stanza-handler)) + (runes::write-xstream-buffer (server-xstream connection))))) (defmacro with-xml-stream ((stream connection) &body body) "Helper macro to make it easy to control outputting XML

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by jstecklina 03 Mar '07

03 Mar '07

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/tmp/cvs-serv3081 Modified Files: cl-xmpp.lisp Log Message: Fixed READ-STANZA for recent CXML versions. Kludge. Please improve. --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/08/28 21:17:08 1.28 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2007/03/03 18:42:08 1.29 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.28 2006/08/28 21:17:08 jstecklina Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.29 2007/03/03 18:42:08 jstecklina Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -316,6 +316,16 @@ (when stanza-callback (car (funcall stanza-callback stanza connection :dom-repr dom-repr))))))) +;;; XXX: Kludge. Newer versions of CXML rebind *namespace-bindings* +;;; inside of parse-xstream, so the old method of augmenting +;;; *namespace-bindings* inside of read-stanza does not work any +;;; longer. - Julian Stecklina (Mar 03, 2007) + +(unless (assoc #"stream" cxml::*initial-namespace-bindings* + :test #'runes:rod=) + (push (cons #"stream" #"http://etherx.jabber.org/streams") + cxml::*initial-namespace-bindings*)) + (defun read-stanza (connection) (unless (server-xstream connection) (setf (server-xstream connection) @@ -327,13 +337,9 @@ :uri nil)))) (force-output (server-stream connection)) (catch 'stanza - (let ((cxml::*namespace-bindings* - (acons #"stream" - #"http://etherx.jabber.org/streams" - cxml::*namespace-bindings*))) - (cxml::parse-xstream (server-xstream connection) - (make-instance 'stanza-handler)) - (runes::write-xstream-buffer (server-xstream connection))))) + (cxml::parse-xstream (server-xstream connection) + (make-instance 'stanza-handler)) + (runes::write-xstream-buffer (server-xstream connection)))) (defmacro with-xml-stream ((stream connection) &body body) "Helper macro to make it easy to control outputting XML

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by jstecklina 28 Aug '06

28 Aug '06

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/tmp/cvs-serv20851 Modified Files: cl-xmpp.lisp Log Message: Added status messages and priority to PRESENCE. --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/05/12 17:45:49 1.27 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/08/28 21:17:08 1.28 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.27 2006/05/12 17:45:49 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.28 2006/08/28 21:17:08 jstecklina Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -487,13 +487,22 @@ (add-auth-method :digest-md5 '%digest-md5-auth%) -(defmethod presence ((connection connection) &key type to) +(defmethod presence ((connection connection) &key type to status show priority) (with-xml-output (connection) (cxml:with-element "presence" (when type (cxml:attribute "type" type)) (when to - (cxml:attribute "to" to))))) + (cxml:attribute "to" to)) + (when status + (cxml:with-element "status" + (cxml:text status))) + (when show + (cxml:with-element "show" + (cxml:text show))) + (when priority + (cxml:with-element "priority" + (cxml:text (format nil "~A" priority))))))) (defmethod message ((connection connection) to body &key id (type :chat)) (with-xml-output (connection)

1 0

[cl-xmpp-cvs] CVS public_html
by eenge 07 Aug '06

07 Aug '06

Update of /project/cl-xmpp/cvsroot/public_html In directory clnet:/home/eenge/public_html/cl-xmpp Modified Files: index.shtml Log Message: ftp -> http --- /project/cl-xmpp/cvsroot/public_html/index.shtml 2006/03/29 16:40:50 1.1 +++ /project/cl-xmpp/cvsroot/public_html/index.shtml 2006/08/07 13:34:50 1.2 @@ -86,7 +86,7 @@ <pre>$ asdf-install cl-xmpp</pre> <p>cl-xmpp can manually be downloaded from here: - <tt><a href="ftp://common-lisp.net/pub/project/cl-xmpp/cl-xmpp_latest.tar.gz"> + <tt><a href="http://common-lisp.net/project/cl-xmpp/cl-xmpp_latest.tar.gz"> cl-xmpp_latest.tar.gz</a> </tt>.</p>

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by eenge 12 May '06

12 May '06

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/tmp/cvs-serv13890 Modified Files: README cl-xmpp.lisp Log Message: commiting fixes from Robert Brown, thanks! --- /project/cl-xmpp/cvsroot/cl-xmpp/README 2005/11/28 15:15:03 1.11 +++ /project/cl-xmpp/cvsroot/cl-xmpp/README 2006/05/12 17:45:49 1.12 @@ -14,15 +14,15 @@ ;; (defvar *connection* (xmpp:connect-tls :hostname "talk.google.com" :jid-domain-part "gmail.com")) - * (xmpp:auth connection "username" "password" "resource") + * (xmpp:auth *connection* "username" "password" "resource") ;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5 ;; if you loaded cl-xmpp-sasl or cl-xmpp-tls. ;; send someone a message - * (xmpp:message connection "username@hostname" "what's going on?") + * (xmpp:message *connection* "username@hostname" "what's going on?") ;; then sit back and watch the messages roll in: - * (xmpp:receive-stanza-loop connection) + * (xmpp:receive-stanza-loop *connection*) <MESSAGE from=username@hostname to=me@myserver> [....] ;; or use xmpp:receive-stanza if you're just wanting one stanza @@ -30,7 +30,7 @@ ;; stanza) ;; That's it. Interrupt the loop to issue other commands, eg: - * (xmpp:get-roster connection) + * (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. --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/03/02 15:51:33 1.26 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/05/12 17:45:49 1.27 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.26 2006/03/02 15:51:33 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.27 2006/05/12 17:45:49 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -219,7 +219,7 @@ ((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 (get-element object :error))))))))))) (defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :error)))

1 0

[cl-xmpp-cvs] CVS cl-xmpp/test
by eenge 12 May '06

12 May '06

Update of /project/cl-xmpp/cvsroot/cl-xmpp/test In directory clnet:/tmp/cvs-serv13890/test Modified Files: cl-xmpp-test.asd Log Message: commiting fixes from Robert Brown, thanks! --- /project/cl-xmpp/cvsroot/cl-xmpp/test/cl-xmpp-test.asd 2005/12/14 19:04:07 1.4 +++ /project/cl-xmpp/cvsroot/cl-xmpp/test/cl-xmpp-test.asd 2006/05/12 17:45:50 1.5 @@ -1,5 +1,5 @@ -;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp-test.asd,v 1.4 2005/12/14 19:04:07 eenge Exp $ +;;;; $Id: cl-xmpp-test.asd,v 1.5 2006/05/12 17:45:50 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/cl-xmpp-test.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 (:cl-xmpp :rt) + :depends-on (:cl-xmpp #-sbcl :rt #+sbcl :sb-rt) :components ((:file "package") (:file "utility-test" :depends-on ("package")) @@ -25,5 +25,6 @@ (:file "cl-xmpp-test" :depends-on ("package")))) -(defmethod perform ((operation test-op) (component (eql (find-system 'cl-xmpp-test)))) - (cl-xmpp-test:do-tests)) +(defmethod perform ((operation test-op) + (component (eql (find-system 'cl-xmpp-test)))) + (funcall (intern "DO-TESTS" 'cl-xmpp-test)))

1 0

[cl-xmpp-cvs] CVS public_html
by eenge 29 Mar '06

29 Mar '06

Update of /project/cl-xmpp/cvsroot/public_html In directory clnet:/home/eenge/public_htmls/cl-xmpp Added Files: index.shtml Removed Files: index.html Log Message: renaming --- /project/cl-xmpp/cvsroot/public_html/index.shtml 2006/03/29 16:40:50 NONE +++ /project/cl-xmpp/cvsroot/public_html/index.shtml 2006/03/29 16:40:50 1.1 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> <link rel="stylesheet" href="style.css" type="text/css"> <title>cl-xmpp</title></head> <body> <div class="header"> <h1>cl-xmpp 0.7.2</h1> </div> <div class="body"> <p>cl-xmpp is a Common Lisp client implementation of the <a href="http://www.xmpp.org/">XMPP</a> RFCs. These are the RFCs which <a href="http://www.jabber.org">Jabber</a> clients and servers use to communicate with eachother (including <a href="http://talk.google.com/">Google Talk</a>). In addition cl-xmpp implements JEPs 0078, 0086, 0030 and 0070 which are all part of <a href="http://www.jabber.org/jeps/jep-0073.html">JEP-0073: Basic IM Protocol Suite</a>. The author considers the library feature complete but will happily accept patches for any other reasonably stable JEPs.</p> <p>Currently, you can chat, manage your contacts, roster and presence information using this library. You can now also use the service discovery protocol using the <code>xmpp:discover</code> operator.</p> <p>The code is released under an <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cl-xmpp/LICENSE?rev=HEAD&cvsroot…">MIT-style license</a>. </p> <h2>News</h2> <div class="level"> <ul> <li><em>2006-02-06</em>: Version 0.7.2 released (Bugfixes and updated for new CXML)</li> <li><em>2005-11-21</em>: Version 0.7.1 released (Bugfixes)</li> <li>Version 0.7.0 released (TLS support)</li> <li>Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)</li> <li>Version 0.5.0 released (Now depending on <a href="http://cliki.net/ironclad">Ironclad</a> for digest authentication)</li> <li>Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)</li> <li>Version 0.3.0 released (Added Allegro and LispWorks support)</li> <li>Version 0.2.0 released (JEP 0073 support)</li> <li>Version 0.1.0 released (Initial release)</li> </ul> </div> <h2>Requirements</h2> <div class="level"> <ul> <li>Any implementation which can run the dependencies</li> <li><a href="http://cliki.net/trivial-sockets">trivial-sockets</a></li> <li><a href="http://common-lisp.net/project/cxml">cxml</a></li> <li><a href="http://cliki.net/ironclad">Ironclad</a></li> <li><a href="http://cliki.net/cl-base64">cl-base64</a> (for cl-xmpp-{sasl,tls})</li> <li><a href="http://cliki.net/cl-sasl">cl-sasl</a> (for cl-xmpp-{sasl,tls})</li> <li><a href="http://common-lisp.net/project/cl-plus-ssl">cl+ssl</a> (for cl-xmpp-tls)</li> </ul> </div> <h2>Tested against</h2> <div class="level"> <ul> <li><a href="http://talk.google.com/">Google Talk</a></li> <li><a href="http://jabberd.jabberstudio.org/">Jabberd 1.4</a> (ie not 2)</li> <li><a href="http://ejabberd.jabber.ru/">ejabberd</a></li> </ul> </div> <h2>Features</h2> <div class="level"> <ul> <li>Implements most commands in the RFCs</li> <li>event driven model with hooks makes interfacing easy -- or</li> <li>access to DOM-ish structure with raw data from the server so you can do whatever you like</li> </ul> </div> <h2>Installation</h2> <div class="level"> <p>If you have <a href="http://www.cliki.net/asdf-install"> asdf-install</a>, just: </p> <pre>$ asdf-install cl-xmpp</pre> <p>cl-xmpp can manually be downloaded from here: <tt><a href="ftp://common-lisp.net/pub/project/cl-xmpp/cl-xmpp_latest.tar.gz"> cl-xmpp_latest.tar.gz</a> </tt>.</p> <p>There is also <a href="http://common-lisp.net/faq.shtml#checkout">anonymous CVS </a> and <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=cl-xmpp"> ViewCVS </a>. </p> </div> <h2>Contact</h2> <div class="level"> <p>Questions, feature requests, and bug-reports are welcome on <tt><a href="mailto:cl-xmpp-devel@common-lisp.net"> cl-xmpp-devel(a)common-lisp.net</a></tt> (<a href="http://common-lisp.net/pipermail/cl-xmpp-devel/">archives</a>).</p> </div> <h2>Project members</h2> <div class="level"> <pre>  </pre> </div> <h2>Sample usage</h2> <div class="level"> <pre> * (require :cl-xmpp) * (defvar *connection* (xmpp:connect :hostname "jabber.org")) ;; or xmpp:connect-tls if you loaded cl-xmpp-tls ;; note that for XMPP servers which do not have the same hostname ;; as the domain-part of the user's JID you will have to pass that ;; in. eg for Google Talk: ;; (defvar *connection* (xmpp:connect-tls :hostname "talk.google.com" :jid-domain-part "gmail.com")) * (xmpp:auth connection "password" "resource") ;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5 ;; if you loaded cl-xmpp-sasl or cl-xmpp-tls. ;; send someone a message * (xmpp:message connection "username@hostname" "what's going on?") ;; then sit back and watch the messages roll in: * (xmpp:receive-stanza-loop connection) <MESSAGE from=username@hostname to=me@myserver> [....] ;; or use xmpp:receive-stanza if you're just wanting one stanza ;; (note it will still block until you have received a complete ;; stanza) ;; 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 (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: * (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message)) (xmpp:message connection (xmpp:from message) (format nil "reply to: ~a" (xmpp:message object)))) </pre> </div> </div> </body> </html>

1 0

[cl-xmpp-cvs] CVS public_html
by eenge 29 Mar '06

29 Mar '06

Update of /project/cl-xmpp/cvsroot/public_html In directory clnet:/tmp/cvs-serv3171 Modified Files: index.html Log Message: project member listing --- /project/cl-xmpp/cvsroot/public_html/index.html 2006/02/06 15:51:32 1.30 +++ /project/cl-xmpp/cvsroot/public_html/index.html 2006/03/29 16:38:07 1.31 @@ -106,6 +106,13 @@ </div> + <h2>Project members</h2> + <div class="level"> + <pre> +  + </pre> + </div> + <h2>Sample usage</h2> <div class="level"> <pre>

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by eenge 02 Mar '06

02 Mar '06

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory clnet:/tmp/cvs-serv13898 Modified Files: cl-xmpp.lisp Log Message: fixing error handling code --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/01/23 16:41:11 1.25 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/03/02 15:51:33 1.26 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.25 2006/01/23 16:41:11 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.26 2006/03/02 15:51:33 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -196,26 +196,29 @@ (defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :iq))) (let ((id (ensure-keyword (value (get-attribute object :id)))) - (type (ensure-keyword (value (get-attribute object :type))))) - (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-successfully) - (:auth2 :authentication-successful) - (:bind_2 :bind-successful) - (:session_1 :session-initiated) - (t - (case type - (:get (warn "Don't know how to handle IQ get yet.")) - (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))) - (t ;; Assuming an error + (type (ensure-keyword (value (get-attribute object :type)))) + (errorp (get-element object :error))) + (if errorp + (make-error errorp) + (case id + (:error (make-error errorp)) + (:roster_1 (make-roster object)) + (:reg2 :registration-successful) + (:unreg_1 :registration-cancellation-successful) + (:change1 :password-changed-successfully) + (:auth2 :authentication-successful) + (:bind_2 :bind-successful) + (:session_1 :session-initiated) + (t + (case type + (:get (warn "Don't know how to handle IQ get yet.")) + (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))) + (t ;; Assuming an error (make-error (get-element object :error)))))))))) (defmethod xml-element-to-event ((connection connection)

1 0

[cl-xmpp-cvs] CVS public_html
by eenge 06 Feb '06

06 Feb '06

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp:/home/eenge/tmp/cl-xmpp-public_html Modified Files: index.html Log Message: up'ing version --- /project/cl-xmpp/cvsroot/public_html/index.html 2006/02/06 15:48:38 1.29 +++ /project/cl-xmpp/cvsroot/public_html/index.html 2006/02/06 15:51:32 1.30 @@ -7,7 +7,7 @@ <body> <div class="header"> - <h1>cl-xmpp 0.7.1</h1> + <h1>cl-xmpp 0.7.2</h1> </div> <div class="body">

1 0

[cl-xmpp-cvs] CVS public_html
by eenge 06 Feb '06

06 Feb '06

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp:/home/eenge/tmp/cl-xmpp-public_html Modified Files: index.html Log Message: new release --- /project/cl-xmpp/cvsroot/public_html/index.html 2006/01/18 15:19:39 1.28 +++ /project/cl-xmpp/cvsroot/public_html/index.html 2006/02/06 15:48:38 1.29 @@ -33,6 +33,7 @@ <h2>News</h2> <div class="level"> <ul> + <li><em>2006-02-06</em>: Version 0.7.2 released (Bugfixes and updated for new CXML)</li> <li><em>2005-11-21</em>: Version 0.7.1 released (Bugfixes)</li> <li>Version 0.7.0 released (TLS support)</li> <li>Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)</li>

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by eenge 23 Jan '06

23 Jan '06

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp:/tmp/cvs-serv30108 Modified Files: cl-xmpp.lisp Log Message: adding patch from david, thanks\! --- /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2005/12/31 20:15:06 1.24 +++ /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp 2006/01/23 16:41:11 1.25 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.24 2005/12/31 20:15:06 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.25 2006/01/23 16:41:11 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -316,7 +316,12 @@ (defun read-stanza (connection) (unless (server-xstream connection) (setf (server-xstream connection) - (cxml:make-xstream (make-slow-stream (server-stream connection))))) + (cxml:make-xstream (make-slow-stream (server-stream connection)) + :name + (cxml::make-stream-name + :entity-name "stanza" + :entity-kind :main + :uri nil)))) (force-output (server-stream connection)) (catch 'stanza (let ((cxml::*namespace-bindings*

1 0

[cl-xmpp-cvs] CVS cl-xmpp
by CVS User eenge 22 Jan '06

22 Jan '06

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp:/tmp/cvs-serv25220 Modified Files: TODO Log Message: testing new cvs log mailer --- /project/cl-xmpp/cvsroot/cl-xmpp/TODO 2005/11/18 21:43:52 1.11 +++ /project/cl-xmpp/cvsroot/cl-xmpp/TODO 2006/01/22 03:10:42 1.12 @@ -8,5 +8,6 @@ still writes into a stream. prerequisite for writing a test suite (which i should do). -- havent found a good use for IDs yet so right now they are - just what happen to be in the specs \ No newline at end of file +- avent found a good use for IDs yet so right now they are + just what happen to be in the specs +

1 0

[cl-xmpp-cvs] CVS update: public_html/index.html
by eenge＠common-lisp.net 18 Jan '06

18 Jan '06

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp:/tmp/cvs-serv14477 Modified Files: index.html Log Message: fixing broken link to jabber.org Date: Wed Jan 18 09:19:39 2006 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.27 public_html/index.html:1.28 --- public_html/index.html:1.27 Mon Nov 21 13:01:16 2005 +++ public_html/index.html Wed Jan 18 09:19:39 2006 @@ -13,7 +13,7 @@ <p>cl-xmpp is a Common Lisp client implementation of the <a href="http://www.xmpp.org/">XMPP</a> RFCs. These are the -RFCs which <a href="http://jabber.org">Jabber</a> clients and +RFCs which <a href="http://www.jabber.org">Jabber</a> clients and servers use to communicate with eachother (including <a href="http://talk.google.com/">Google Talk</a>). In addition cl-xmpp implements JEPs 0078, 0086, 0030 and 0070 which are

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/result.lisp
by eenge＠common-lisp.net 31 Dec '05

31 Dec '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv23722 Modified Files: cl-xmpp.lisp cxml.lisp result.lisp Log Message: Applying patches from David Lichteblau Adam Thorsen Julian Stecklina Date: Sat Dec 31 21:15:06 2005 Author: eenge Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.23 cl-xmpp/cl-xmpp.lisp:1.24 --- cl-xmpp/cl-xmpp.lisp:1.23 Mon Nov 21 19:58:03 2005 +++ cl-xmpp/cl-xmpp.lisp Sat Dec 31 21:15:06 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.23 2005/11/21 18:58:03 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.24 2005/12/31 20:15:06 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -66,7 +66,8 @@ ;;; or begin-xml-stream you must update that value in cl-xmpp-tls.lisp's ;;; 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) + (receive-stanzas t) (begin-xml-stream t) jid-domain-part + (class 'connection)) "Open TCP connection to hostname. By default this will set up the complete XML stream and receive the initial @@ -85,7 +86,7 @@ after you've connected." (let* ((stream (trivial-sockets:open-stream hostname port :element-type '(unsigned-byte 8))) - (connection (make-instance 'connection + (connection (make-instance class :jid-domain-part jid-domain-part :server-stream stream :hostname hostname @@ -158,14 +159,14 @@ (defmethod parse-result ((connection connection) (objects list)) (map 'list #'(lambda (x) (parse-result connection x)) objects)) -(defmethod parse-result ((connection connection) (document dom-impl::document)) +(defmethod parse-result ((connection connection) (document cxml-dom::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)) +(defmethod parse-result ((connection connection) (attribute cxml-dom::attribute)) (let* ((name (ensure-keyword (dom:node-name attribute))) (value (dom:value attribute)) (xml-attribute @@ -173,41 +174,49 @@ :name name :value value :node attribute))) xml-attribute)) -(defmethod parse-result ((connection connection) (node dom-impl::character-data)) +(defmethod parse-result ((connection connection) (node cxml-dom::character-data)) (let* ((name (ensure-keyword (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)) +(defmethod parse-result ((connection connection) (node cxml-dom::node)) (let* ((name (ensure-keyword (dom:node-name node))) (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 parse-result ((connection connection) (node cxml-dom::element)) + (let ((xml-element (call-next-method))) + (dom:do-node-map (attribute (dom:attributes node)) + (push (parse-result connection attribute) (attributes xml-element))) + xml-element)) (defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :iq))) - (let ((id (ensure-keyword (value (get-attribute object :id))))) - (if (not (eq (ensure-keyword (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) - (:bind_2 :bind-successful) - (:session_1 :session-initiated) - (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))))))))) + (let ((id (ensure-keyword (value (get-attribute object :id)))) + (type (ensure-keyword (value (get-attribute object :type))))) + (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-successfully) + (:auth2 :authentication-successful) + (:bind_2 :bind-successful) + (:session_1 :session-initiated) + (t + (case type + (:get (warn "Don't know how to handle IQ get yet.")) + (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))) + (t ;; Assuming an error + (make-error (get-element object :error)))))))))) (defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :error))) @@ -270,6 +279,8 @@ :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)))) ;; @@ -305,13 +316,13 @@ (defun read-stanza (connection) (unless (server-xstream connection) (setf (server-xstream connection) - (cxml:make-xstream (server-stream connection)))) + (cxml:make-xstream (make-slow-stream (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*))) + (let ((cxml::*namespace-bindings* + (acons #"stream" + #"http://etherx.jabber.org/streams" + cxml::*namespace-bindings*))) (cxml::parse-xstream (server-xstream connection) (make-instance 'stanza-handler)) (runes::write-xstream-buffer (server-xstream connection))))) @@ -378,7 +389,7 @@ (defmacro with-iq-query ((connection &key xmlns id to 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) (cxml:with-element "query" (cxml:attribute "xmlns" ,xmlns) (when ,node @@ -476,10 +487,12 @@ (when to (cxml:attribute "to" to))))) -(defmethod message ((connection connection) to body) +(defmethod message ((connection connection) to body &key id (type :chat)) (with-xml-output (connection) (cxml:with-element "message" (cxml:attribute "to" to) + (when id (cxml:attribute "id" id)) + (when type (cxml:attribute "type" (string-downcase (string type)))) (cxml:with-element "body" (cxml:text body))))) (defmethod bind ((connection connection) resource) Index: cl-xmpp/cxml.lisp diff -u cl-xmpp/cxml.lisp:1.9 cl-xmpp/cxml.lisp:1.10 --- cl-xmpp/cxml.lisp:1.9 Sat Nov 19 00:14:35 2005 +++ cl-xmpp/cxml.lisp Sat Dec 31 21:15:06 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cxml.lisp,v 1.9 2005/11/18 23:14:35 eenge Exp $ +;;;; $Id: cxml.lisp,v 1.10 2005/12/31 20:15:06 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cxml.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -11,7 +11,7 @@ :accessor depth))) (defun start-sax-document (handler) - (let ((dom-builder (dom:make-dom-builder))) + (let ((dom-builder (cxml-dom:make-dom-builder))) (setf (cxml:proxy-chained-handler handler) dom-builder) (sax:start-document dom-builder) dom-builder)) @@ -22,7 +22,7 @@ (if (eq :stream\:stream (ensure-keyword 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)) + (let* ((document (cxml-dom:create-document)) (element (dom:create-element document qname))) (dom:append-child document element) (dolist (attribute attrs) @@ -45,37 +45,26 @@ (call-next-method) (when (eql (depth handler) 0) (throw 'stanza - (dom-impl::document (cxml:proxy-chained-handler handler))))) + (cxml-dom::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 -;;; assumes it will be a vector. This will result in problems -;;; because I wanted to use this with return value of DOM:ATTRIBUTES -;;; which may be NIL. David Lichteblau said a specialized map -;;; function for namednodelists (which is what the return value of -;;; DOM:ATTRIBUTES) is could be added he just hadn't needed one -;;; yet. So, if you want to you can write one and send him a -;;; patch. -(defun dom:map-node-list (fn nodelist) - (when nodelist - (dotimes (i (dom:length nodelist)) - (funcall fn (dom:item nodelist i))))) - -;;; XXX: because of READ-SEQUENCE's blocking on the stream -;;; (in RUNES::READ-OCTETS) we do not call SET-TO-FULL-SPEED -;;; so that we avoid the CXML buffering layer. I think perhaps -;;; this would work if READ-N-BYTES worked properly but I -;;; don't really know at this point. -;;; -;;; Should probably email the SBCL list about this. -(defun cxml::set-full-speed (input) - (declare (ignore input)) - nil) +;;; Perform single-byte reads to avoid blocking on the socket. +(defstruct (slow-stream (:constructor make-slow-stream (target))) + (target nil :type stream)) + +(defmethod runes::figure-encoding ((stream slow-stream)) + (runes::figure-encoding (slow-stream-target stream))) + +(defmethod runes::read-octets (seq (stream slow-stream) start end) + (when (< start end) + (let ((byte (read-byte (slow-stream-target stream) nil))) + (when byte + (setf (elt seq start) byte) + (incf start)))) + start) ;; I'd like to see what CXML is reading from the stream ;; and this code helps us in that regard by printing it ;; to the *debug-stream* - (defun runes::write-xstream-buffer (xstream &optional (stream *debug-stream*)) (when stream (write-string (map 'string @@ -86,49 +75,5 @@ stream) (force-output stream))) -(defun runes::xstream-underflow (input) - (declare (type runes::xstream input)) - ;; we are about to fill new data into the buffer, so we need to - ;; adjust buffer-start. - (runes::write-xstream-buffer input) - (incf (runes::xstream-buffer-start input) - (- (runes::xstream-fill-ptr input) 0)) - (let (n m) - ;; when there is something left in the os-buffer, we move it to - ;; the start of the buffer. - (setf m (- (runes::xstream-os-left-end input) (runes::xstream-os-left-start input))) - (unless (zerop m) - (replace (runes::xstream-os-buffer input) (runes::xstream-os-buffer input) - :start1 0 :end1 m - :start2 (runes::xstream-os-left-start input) - :end2 (runes::xstream-os-left-end input)) - ;; then we take care that the buffer is large enough to carry at - ;; least 100 bytes (a random number) - (unless (>= (length (runes::xstream-os-buffer input)) 100) - (error "You lost") - ;; todo: enlarge buffer - )) - (setf n - (runes::read-octets (runes::xstream-os-buffer input) (runes::xstream-os-stream input) - m (min (1- (length (runes::xstream-os-buffer input))) - (+ m (runes::xstream-speed input))))) - (cond ((runes::%= n 0) - (setf (runes::xstream-read-ptr input) 0 - (runes::xstream-fill-ptr input) n) - (setf (aref (runes::xstream-buffer input) - (runes::xstream-fill-ptr input)) runes::+end+) - :eof) - (t - (multiple-value-bind (fnw fnr) - (encoding:decode-sequence - (runes::xstream-encoding input) - (runes::xstream-os-buffer input) 0 n - (runes::xstream-buffer input) 0 (1- (length (runes::xstream-buffer input))) - (= n m)) - (setf (runes::xstream-os-left-start input) fnr - (runes::xstream-os-left-end input) n - (runes::xstream-read-ptr input) 0 - (runes::xstream-fill-ptr input) fnw) - (setf (aref (runes::xstream-buffer input) - (runes::xstream-fill-ptr input)) runes::+end+) - (runes:read-rune input)))))) +(defmethod runes::xstream-underflow :before ((input runes:xstream)) + (runes::write-xstream-buffer input)) \ No newline at end of file Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.12 cl-xmpp/result.lisp:1.13 --- cl-xmpp/result.lisp:1.12 Thu Nov 17 22:51:16 2005 +++ cl-xmpp/result.lisp Sat Dec 31 21:15:06 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.12 2005/11/17 21:51:16 eenge Exp $ +;;;; $Id: result.lisp,v 1.13 2005/12/31 20:15:06 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -125,12 +125,24 @@ (body :accessor body :initarg :body - :initform ""))) + :initform "") + (id + :accessor id + :initarg :id + :initform nil) + (type + :accessor type- + :initarg :type + :initform nil))) (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" (to object) (from object)))) + (format stream "to:~a from:~a id:~a type:~a" + (to object) + (from object) + (id object) + (type- object)))) (defclass presence (event) ((to

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.asd
by eenge＠common-lisp.net 14 Dec '05

14 Dec '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv13432 Modified Files: cl-xmpp.asd Log Message: adding a test-op on cl-xmpp to run do-tests from cl-xmpp-test Date: Wed Dec 14 20:03:49 2005 Author: eenge Index: cl-xmpp/cl-xmpp.asd diff -u cl-xmpp/cl-xmpp.asd:1.6 cl-xmpp/cl-xmpp.asd:1.7 --- cl-xmpp/cl-xmpp.asd:1.6 Sun Nov 13 03:36:10 2005 +++ cl-xmpp/cl-xmpp.asd Wed Dec 14 20:03:48 2005 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp.asd,v 1.6 2005/11/13 02:36:10 eenge Exp $ +;;;; $Id: cl-xmpp.asd,v 1.7 2005/12/14 19:03:48 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -28,4 +28,8 @@ :depends-on ("cxml")) (:file "cl-xmpp" :depends-on ("result")))) + +(defmethod perform ((operation test-op) (component (eql (find-system 'cl-xmpp)))) + (operate 'load-op 'cl-xmpp-test) + (operate 'test-op 'cl-xmpp-test :force t))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/test/cl-xmpp-test.asd
by eenge＠common-lisp.net 14 Dec '05

14 Dec '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp/test In directory common-lisp.net:/tmp/cvs-serv13432/test Modified Files: cl-xmpp-test.asd Log Message: adding a test-op on cl-xmpp to run do-tests from cl-xmpp-test Date: Wed Dec 14 20:04:08 2005 Author: eenge Index: cl-xmpp/test/cl-xmpp-test.asd diff -u cl-xmpp/test/cl-xmpp-test.asd:1.3 cl-xmpp/test/cl-xmpp-test.asd:1.4 --- cl-xmpp/test/cl-xmpp-test.asd:1.3 Mon Nov 21 19:58:04 2005 +++ cl-xmpp/test/cl-xmpp-test.asd Wed Dec 14 20:04:07 2005 @@ -1,5 +1,5 @@ -;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp-test.asd,v 1.3 2005/11/21 18:58:04 eenge Exp $ +-;;;; -*- mode: lisp -*- +;;;; $Id: cl-xmpp-test.asd,v 1.4 2005/12/14 19:04:07 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/cl-xmpp-test.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -25,3 +25,5 @@ (:file "cl-xmpp-test" :depends-on ("package")))) +(defmethod perform ((operation test-op) (component (eql (find-system 'cl-xmpp-test)))) + (cl-xmpp-test:do-tests))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-tls.lisp
by eenge＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv3568 Modified Files: cl-xmpp-tls.lisp Log Message: patch from david lichteblau Date: Mon Nov 28 16:15:46 2005 Author: eenge Index: cl-xmpp/cl-xmpp-tls.lisp diff -u cl-xmpp/cl-xmpp-tls.lisp:1.7 cl-xmpp/cl-xmpp-tls.lisp:1.8 --- cl-xmpp/cl-xmpp-tls.lisp:1.7 Thu Nov 17 21:56:38 2005 +++ cl-xmpp/cl-xmpp-tls.lisp Mon Nov 28 16:15:46 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-tls.lisp,v 1.7 2005/11/17 20:56:38 eenge Exp $ +;;;; $Id: cl-xmpp-tls.lisp,v 1.8 2005/11/28 15:15:46 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -46,7 +46,8 @@ Turn off sending XML stream start with :begin-xml-stream nil." (setf (server-stream connection) - (cl+ssl:make-ssl-client-stream (server-stream connection))) + (cl+ssl:make-ssl-client-stream (server-stream connection) + :external-format :iso-8859-1)) (setf (server-xstream connection) nil) (when begin-xml-stream (begin-xml-stream connection))

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