Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv10698

Modified Files: CREDITS TODO cl-xmpp.asd cl-xmpp.lisp cxml.lisp package.lisp variable.lisp Added Files: cl-xmpp-sasl.asd cl-xmpp-sasl.lisp cl-xmpp-tls.asd cl-xmpp-tls.lisp Log Message: adding much better printing of what's happening on the stream (thanks david lichteblau)

cleaning up some minor stuff

adding beginnings of sasl and tls support

Date: Fri Nov 11 18:21:57 2005 Author: eenge

Index: cl-xmpp/CREDITS diff -u cl-xmpp/CREDITS:1.1 cl-xmpp/CREDITS:1.2 --- cl-xmpp/CREDITS:1.1 Mon Oct 31 18:02:03 2005 +++ cl-xmpp/CREDITS Fri Nov 11 18:21:56 2005 @@ -1,2 +1,4 @@ Erik Enge David Lichteblau for helping with CXML issues and testing +John Wiseman for OpenMCL support +Richard Krueter for Clisp support \ No newline at end of file

Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.5 cl-xmpp/TODO:1.6 --- cl-xmpp/TODO:1.5 Sat Oct 29 19:25:04 2005 +++ cl-xmpp/TODO Fri Nov 11 18:21:56 2005 @@ -2,6 +2,5 @@

- sasl/tls

-- also, i'm interning things which will screw up lisps with up/down +- also, i'm interning things which may screw up lisps with up/down case different. -

Index: cl-xmpp/cl-xmpp.asd diff -u cl-xmpp/cl-xmpp.asd:1.4 cl-xmpp/cl-xmpp.asd:1.5 --- cl-xmpp/cl-xmpp.asd:1.4 Mon Oct 31 22:07:14 2005 +++ cl-xmpp/cl-xmpp.asd Fri Nov 11 18:21:56 2005 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp.asd,v 1.4 2005/10/31 21:07:14 eenge Exp $ +;;;; $Id: cl-xmpp.asd,v 1.5 2005/11/11 17:21:56 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd,v $

;;;; See the LICENSE file for licensing information. @@ -17,7 +17,7 @@ :version "0.0.1" :licence "MIT" :description "Common Lisp XMPP client implementation" - :depends-on (#+sbcl :sb-bsd-sockets :cxml :ironclad) + :depends-on (#+sbcl :sb-bsd-sockets :trivial-sockets :cxml :ironclad) :components ((:file "package") (:file "variable" :depends-on ("package"))

Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.8 cl-xmpp/cl-xmpp.lisp:1.9 --- cl-xmpp/cl-xmpp.lisp:1.8 Thu Nov 3 21:55:10 2005 +++ cl-xmpp/cl-xmpp.lisp Fri Nov 11 18:21:56 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.8 2005/11/03 20:55:10 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.9 2005/11/11 17:21:56 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -10,10 +10,6 @@ :accessor server-stream :initarg :server-stream :initform nil) - (socket - :accessor socket - :initarg :socket - :initform nil) (server-xstream :accessor server-xstream :initform nil) @@ -23,6 +19,23 @@ :initform nil :documentation "Stream ID attribute of the <stream> element as gotten when we call BEGIN-XML-STREAM.") + (features + :accessor features + :initarg :features + :initform nil + :documentation "List of xml-element objects representing +the various features the host at the other end of the connection +supports.") + (mechanisms + :accessor mechanisms + :initarg :mechanisms + :initform nil + :documentation "List of xml-element objects representing +the various mechainsms the host at the other end of the connection +will accept.") + (username + :accessor username + :initarg :username) (hostname :accessor hostname :initarg :hostname @@ -50,41 +63,10 @@ ;;; CXML breaks on. (defun connect (&key (hostname *default-hostname*) (port *default-port*)) "Open TCP connection to hostname." - #+sbcl (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp)) - (ip-address (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name hostname))))) - (sb-bsd-sockets:socket-connect socket ip-address port) - (setf (sb-bsd-sockets:non-blocking-mode socket) t) - (make-instance 'connection - :server-stream (sb-bsd-sockets:socket-make-stream - socket :input t :output t :buffering :none - :element-type '(unsigned-byte 8) - :pathname #p"/tmp/not-a-pathname") - :socket socket - :hostname hostname - :port port)) - #+(or allegro openmcl) - (let ((socket (socket:make-socket :remote-host hostname :remote-port port))) - ;; fixme: (setf (sb-bsd-sockets:non-blocking-mode socket) t) - (make-instance 'connection - :server-stream socket - :socket socket - :hostname hostname - :port port)) - #+lispworks (let ((socket (comm:open-tcp-stream hostname port - :element-type '(unsigned-byte 8)))) - (make-instance 'connection - :server-stream socket - :socket socket - :hostname hostname - :port port))) - -(defmethod make-connection-and-debug-stream ((connection connection)) - "Helper function to make a broadcast stream for this connection's -server-stream and the *debug-stream*." - ;;; Hook onto this if you want the output written by CXML to be - ;;; sent to one of your streams for debugging or whatever. - (server-stream connection)) + (let ((stream (trivial-sockets:open-stream + hostname port :element-type '(unsigned-byte 8)))) + (make-instance 'connection :server-stream stream + :hostname hostname :port port)))

(defmethod connectedp ((connection connection)) "Returns t if `connection' is connected to a server and is ready for @@ -95,8 +77,7 @@

(defmethod disconnect ((connection connection)) "Disconnect TCP connection." - #+sbcl (sb-bsd-sockets:socket-close (socket connection)) - #+(or allegro openmcl lispworks) (close (socket connection)) + (close (server-stream connection)) connection)

;; @@ -104,19 +85,18 @@ ;;

(defmethod handle ((connection connection) (list list)) - (dolist (object list) - (handle connection object))) + (map 'list #'(lambda (x) (handle connection x)) list))

(defmethod handle ((connection connection) object) - (format t "~&Received: ~a~%" object)) + (format t "~&UNHANDLED: ~a~%" object) + object)

;; ;; Produce DOM-ish structure from the XML DOM returned by cxml. ;;

(defmethod parse-result ((connection connection) (objects list)) - (dolist (object objects) - (parse-result connection object))) + (map 'list #'(lambda (x) (parse-result connection x)) objects))

(defmethod parse-result ((connection connection) (document dom-impl::document)) (let (objects) @@ -180,15 +160,20 @@ (setf (stream-id connection) (value (get-attribute object :id))) object)

+(defmethod xml-element-to-event ((connection connection) + (object xml-element) (name (eql :stream:features))) + (dolist (element (elements object)) + (if (eq (name element) :mechanisms) + (setf (mechanisms connection) (elements element)) + (push element (features connection)))) + object) + (defmethod xml-element-to-event ((connection connection) (object xml-element) name) (declare (ignore name)) object)

(defmethod dom-to-event ((connection connection) (objects list)) - (let (list) - (dolist (object objects) - (push (dom-to-event connection object) list)) - list)) + (map 'list #'(lambda (x) (dom-to-event connection x)) objects))

(defmethod dom-to-event ((connection connection) (object xml-element)) (xml-element-to-event @@ -226,6 +211,10 @@ (defmethod receive-stanza-loop ((connection connection) &key (stanza-callback 'default-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 (let* ((stanza (read-stanza connection)) (tagname (dom:tag-name (dom:document-element stanza)))) @@ -249,21 +238,23 @@ "http://etherx.jabber.org/streams" cxml::*default-namespace-bindings*))) (cxml::parse-xstream (server-xstream connection) - (make-instance 'stanza-handler))))) - + (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 to the debug stream. It's not strictly /with/ xml-stream so it should probably be renamed." - `(let ((,stream (make-connection-and-debug-stream ,connection))) + `(let ((,stream (server-stream ,connection))) ,@body))

(defun xml-output (stream string) - "Write string to stream as a sequence of bytes and not -characters." - (write-sequence (string-to-array string) stream) - (finish-output stream) - string) + "Write string to stream as a sequence of bytes and not characters." + (let ((sequence (string-to-array string :element-type '(unsigned-byte 8)))) + (write-sequence sequence stream) + (finish-output stream) + (when *debug-stream* + (write-string string *debug-stream*))))

(defmethod begin-xml-stream ((connection connection)) "Begin XML stream. This should be the first thing to @@ -273,27 +264,29 @@ (xml-output stream (fmt "<stream:stream to='~a' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' -version='1.0'>" (hostname connection))))) +version='1.0'>" (hostname connection)))) + connection)

(defmethod end-xml-stream ((connection connection)) "Closes the XML stream. At this point you'd have to call BEGIN-XML-STREAM if you wished to communicate with the server again." (with-xml-stream (stream connection) - (xml-output stream "</stream:stream>"))) + (xml-output stream "</stream:stream>")) + connection)

(defmacro with-iq ((connection &key id to (type "get")) &body body) "Macro to make it easier to write IQ stanzas." (let ((stream (gensym))) - `(let ((,stream (make-connection-and-debug-stream ,connection))) - (cxml:with-xml-output (cxml:make-octet-stream-sink ,stream) + `(let ((,stream (server-stream ,connection))) + (cxml:with-xml-output (make-octet+character-debug-stream-sink ,stream) (cxml:with-element "iq" (cxml:attribute "id" ,id) (when ,to (cxml:attribute "to" ,to)) (cxml:attribute "type" ,type) ,@body)) - (finish-output ,stream) + (force-output ,stream) ,connection)))

(defmacro with-iq-query ((connection &key xmlns id to node (type "get")) &body body) @@ -336,11 +329,10 @@ (with-iq-query (connection :id "unreg1" :type "set" :xmlns "jabber:iq:register") (cxml:with-element "remove")))

-;;; XXX: connection should know about username? -(defmethod change-password ((connection connection) username new-password) +(defmethod change-password ((connection connection) new-password) (with-iq-query (connection :id "change1" :type "set" :xmlns "jabber:iq:register") (cxml:with-element "username" - (cxml:text username)) + (cxml:text (username connection))) (cxml:with-element "password" (cxml:text new-password))))

@@ -349,6 +341,7 @@ (cxml:with-element "username" (cxml:text username))))

(defmethod auth ((connection connection) username password resource &key digestp) + (setf (username connection) username) (with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth") (cxml:with-element "username" (cxml:text username)) (if digestp @@ -362,8 +355,8 @@ (cxml:with-element "resource" (cxml:text resource))))

(defmethod presence ((connection connection) &key type to) - (cxml:with-xml-output (cxml:make-octet-stream-sink - (make-connection-and-debug-stream connection)) + (cxml:with-xml-output (make-octet+character-debug-stream-sink + (server-stream connection)) (cxml:with-element "presence" (when type (cxml:attribute "type" type)) @@ -372,8 +365,8 @@ connection)

(defmethod message ((connection connection) to body) - (cxml:with-xml-output (cxml:make-octet-stream-sink - (make-connection-and-debug-stream connection)) + (cxml:with-xml-output (make-octet+character-debug-stream-sink + (server-stream connection)) (cxml:with-element "message" (cxml:attribute "to" to) (cxml:with-element "body" (cxml:text body))))

Index: cl-xmpp/cxml.lisp diff -u cl-xmpp/cxml.lisp:1.3 cl-xmpp/cxml.lisp:1.4 --- cl-xmpp/cxml.lisp:1.3 Sat Oct 29 05:58:04 2005 +++ cl-xmpp/cxml.lisp Fri Nov 11 18:21:56 2005 @@ -1,5 +1,4 @@ ;;;; cxml-stanza.lisp -- parser helper for RFC 3920 XML streams -;;;; Copyright (c) 2004 David Lichteblau, BSD-style license

;;; These are modifications to CXML which helps us deal with the ;;; incremental-style parsing required for the XML stanzas. @@ -72,3 +71,82 @@ (defun cxml::set-full-speed (input) (declare (ignore input)) nil) + +;; To facilitate writing to both an octet and a character stream +;; using CXML. + +(defclass octet+character-debug-stream-sink (cxml::octet-stream-sink) + ((target-stream + :accessor target-stream + :initarg :target-stream))) + +(defun make-octet+character-debug-stream-sink (octet-stream &rest initargs) + (apply #'make-instance 'octet+character-debug-stream-sink + :target-stream octet-stream + initargs)) + +(defmethod cxml::write-octet (octet (sink octet+character-debug-stream-sink)) + (write-byte octet (target-stream sink)) + (when *debug-stream* + (write-char (code-char octet) *debug-stream*))) + +;; 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))) + +(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))))))

Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.5 cl-xmpp/package.lisp:1.6 --- cl-xmpp/package.lisp:1.5 Mon Nov 7 20:15:51 2005 +++ cl-xmpp/package.lisp Fri Nov 11 18:21:56 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.5 2005/11/07 19:15:51 eenge Exp $ +;;;; $Id: package.lisp,v 1.6 2005/11/11 17:21:56 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -13,9 +13,9 @@ (:nicknames :xmpp) (:export ;; connection-related - :connect :disconnect :socket :stream- :hostname :port :connectedp + :connect :disconnect :stream- :hostname :port :connectedp :receive-stanza-loop :begin-xml-stream :end-xml-stream :with-iq - :with-iq-query :connection + :with-iq-query :connection :username :mechanisms :features ;; xmpp commands :discover :registration-requirements :register

Index: cl-xmpp/variable.lisp diff -u cl-xmpp/variable.lisp:1.2 cl-xmpp/variable.lisp:1.3 --- cl-xmpp/variable.lisp:1.2 Fri Oct 28 23:04:12 2005 +++ cl-xmpp/variable.lisp Fri Nov 11 18:21:56 2005 @@ -1,36 +1,37 @@ -;;;; $Id: variable.lisp,v 1.2 2005/10/28 21:04:12 eenge Exp $ +;;;; $Id: variable.lisp,v 1.3 2005/11/11 17:21:56 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp,v $

;;;; See the LICENSE file for licensing information.

(in-package :xmpp)

-(defvar *debug-stream* *standard-output*) +(defvar *debug-stream* *debug-io* + "A character stream, or nil")

(defvar *default-port* 5222) (defvar *default-hostname* "localhost")

(defvar *errors* - '((:bad-request 'modiy 400) - (:conflict 'cancel 409) - (:feature-not-implemented 'cancel 501) - (:forbidden 'auth 403) - (:gone 'modify 302) - (:internal-server-error 'wait 500) - (:item-not-found 'cancel 404) - (:jid-malformed 'modify 400) - (:not-acceptable 'modify 406) - (:not-allowed 'cancel 405) - (:not-authorized 'auth 401) - (:payment-required 'auth 402) - (:recipient-unavailable 'wait 404) - (:redirect 'modify 302) - (:registration-required 'auth 407) - (:remote-server-not-found 'cancel 404) - (:remote-server-timeout 'wait 504) - (:resource-constraint 'wait 500) - (:service-unavailable 'cancel 503) - (:subscription-required 'auth 407) - (:undefined-condition 'any 500) - (:unexpected-request 'wait 400))) + '((:bad-request :modiy 400) + (:conflict :cancel 409) + (:feature-not-implemented :cancel 501) + (:forbidden :auth 403) + (:gone :modify 302) + (:internal-server-error :wait 500) + (:item-not-found :cancel 404) + (:jid-malformed :modify 400) + (:not-acceptable :modify 406) + (:not-allowed :cancel 405) + (:not-authorized :auth 401) + (:payment-required :auth 402) + (:recipient-unavailable :wait 404) + (:redirect :modify 302) + (:registration-required :auth 407) + (:remote-server-not-found :cancel 404) + (:remote-server-timeout :wait 504) + (:resource-constraint :wait 500) + (:service-unavailable :cancel 503) + (:subscription-required :auth 407) + (:undefined-condition :any 500) + (:unexpected-request :wait 400)))