November 2005 - cl-xmpp-cvs@common-lisp.net

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

12 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv2934 Modified Files: TODO Log Message: comment about testing Date: Sat Nov 12 21:53:17 2005 Author: eenge Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.7 cl-xmpp/TODO:1.8 --- cl-xmpp/TODO:1.7 Fri Nov 11 22:20:20 2005 +++ cl-xmpp/TODO Sat Nov 12 21:53:17 2005 @@ -1,8 +1,10 @@ - respect stringprep/nodeprep - jid validator -- sasl/tls - - also, i'm interning things which may screw up lisps with up/down case different. -- i hate that xmlns's are as strings and never validated \ No newline at end of file +- i hate that xmlns's are as strings and never validated + +- create a connect-test which makes a "fake" connection but + still writes into a stream. prerequisite for writing a test + suite (which i should do).

1 0

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

12 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv28229 Modified Files: cl-xmpp-tls.lisp Log Message: begin-tls-stream -> convert-to-tls-stream Date: Sat Nov 12 05:30:57 2005 Author: eenge Index: cl-xmpp/cl-xmpp-tls.lisp diff -u cl-xmpp/cl-xmpp-tls.lisp:1.2 cl-xmpp/cl-xmpp-tls.lisp:1.3 --- cl-xmpp/cl-xmpp-tls.lisp:1.2 Sat Nov 12 05:20:21 2005 +++ cl-xmpp/cl-xmpp-tls.lisp Sat Nov 12 05:30:57 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-tls.lisp,v 1.2 2005/11/12 04:20:21 eenge Exp $ +;;;; $Id: cl-xmpp-tls.lisp,v 1.3 2005/11/12 04:30:57 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -9,7 +9,7 @@ "Connect to the host and start a TLS stream." (let ((connection (apply #'connect args))) (send-starttls connection) - (begin-tls-stream connection) + (convert-to-tls-stream connection) connection)) (defmethod send-starttls ((connection connection))

1 0

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

12 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv27623 Modified Files: README Log Message: note about connect-tls Date: Sat Nov 12 05:22:03 2005 Author: eenge Index: cl-xmpp/README diff -u cl-xmpp/README:1.6 cl-xmpp/README:1.7 --- cl-xmpp/README:1.6 Sat Nov 12 05:20:21 2005 +++ cl-xmpp/README Sat Nov 12 05:22:03 2005 @@ -6,6 +6,10 @@ * (require :cl-xmpp) * (defvar connection (xmpp:connect "username" :hostname "jabber.org")) +;; or use xmpp:connect-tls with the exact same arguments to initiate +;; a TLS connection. there are operators in cl-xmpp-tls.lisp you +;; can use manually if you want to check that this host supports +;; TLS connections, first. ;; authenticate (or use xmpp:register to make an account) * (xmpp:auth connection "password" "resource")

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/README cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp-tls.lisp cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/package.lisp
by eenge＠common-lisp.net 12 Nov '05

12 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv27583 Modified Files: README cl-xmpp-sasl.lisp cl-xmpp-tls.lisp cl-xmpp.lisp cxml.lisp package.lisp Log Message: I think the TLS code should work now but until I get a new LW to work with CFFI I can't test on this computer. Date: Sat Nov 12 05:20:22 2005 Author: eenge Index: cl-xmpp/README diff -u cl-xmpp/README:1.5 cl-xmpp/README:1.6 --- cl-xmpp/README:1.5 Sat Nov 12 03:29:51 2005 +++ cl-xmpp/README Sat Nov 12 05:20:21 2005 @@ -9,9 +9,10 @@ ;; authenticate (or use xmpp:register to make an account) * (xmpp:auth connection "password" "resource") +;; defaults to plain non-sasl authentication but sasl is also available ;; let the server know you want to receive/send presence information -;; (this makes you "come online" if others have a subscription with you +;; (this makes you "come online" if others have a subscription with you) * (xmpp:presence connection) ;; send someone a message @@ -21,6 +22,9 @@ * (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) @@ -30,8 +34,9 @@ ;; 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. +;; 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: Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.5 cl-xmpp/cl-xmpp-sasl.lisp:1.6 --- cl-xmpp/cl-xmpp-sasl.lisp:1.5 Sat Nov 12 03:37:29 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Sat Nov 12 05:20:21 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.5 2005/11/12 02:37:29 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.6 2005/11/12 04:20:21 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -21,39 +21,43 @@ entire SASL challenge/response chain. Returns two values, the first is a keyword symbol (:success or :failure) and the second is the last stanza received from the server." - (initiate-sasl-authentication connection mechanism) - (let ((initial-challenge (receive-stanza connection))) - (if (eq (name initial-challenge) :challenge) - (let* ((challenge-string (base64:base64-string-to-string - (data (get-element initial-challenge :\#text)))) - (sasl-client (make-instance (sasl:get-mechanism mechanism) - :authentication-id username - :password password - :service "xmpp" - :realm (hostname connection) - :host (hostname connection))) - (response (sasl:client-step sasl-client (ironclad:ascii-string-to-byte-array challenge-string))) - (base64-response (base64:string-to-base64-string response))) - (format *debug-stream* "~&challenge-string: ~a~%" challenge-string) - (format *debug-stream* "response: ~a~%" response) - (if (eq response :failure) - (values :failure initial-challenge) - (progn - (send-challenge-response connection base64-response) - (let ((second-challenge (receive-stanza connection))) - (if (eq (name second-challenge) :challenge) - (progn - (send-second-response connection) - (let ((final-reply (receive-stanza connection))) - ; This should return either :success or :failure. - (values (name final-reply) final-reply))) - (values :failure second-challenge)))))) - (values :failure initial-challenge)))) + (let ((sasl-client (make-instance (sasl:get-mechanism mechanism) + :authentication-id username + :password password + :service "xmpp" + :host (hostname connection)))) + (initiate-sasl-authentication connection mechanism sasl-client) + (let ((initial-challenge (receive-stanza connection))) + (if (eq (name initial-challenge) :challenge) + (let* ((challenge-string (base64:base64-string-to-string + (data (get-element initial-challenge :\#text)))) + (usb8-response (sasl:client-step + sasl-client + (ironclad:ascii-string-to-byte-array challenge-string)))) + (format *debug-stream* "~&challenge-string: ~a~%" challenge-string) + (if (eq usb8-response :failure) + (values :failure initial-challenge) + (let ((base64-response (base64:usb8-array-to-base64-string usb8-response))) + (format *debug-stream* "response: ~a~%" (map 'string #'code-char usb8-response)) + (force-output *debug-stream*) + (send-challenge-response connection base64-response) + (let ((second-challenge (receive-stanza connection))) + (if (eq (name second-challenge) :challenge) + (progn + (send-second-response connection) + (let ((final-reply (receive-stanza connection))) + ; This should return either :success or :failure. + (values (name final-reply) final-reply))) + (values :failure second-challenge)))))) + (values :failure initial-challenge))))) -(defmethod initiate-sasl-authentication ((connection connection) mechanism) +(defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client) (with-xml-stream (stream connection) (xml-output stream (fmt "<auth mechanism='~a' -xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" mechanism)))) +xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>~a</auth>" + mechanism + (base64:usb8-array-to-base64-string + (sasl:client-step sasl-client nil)))))) (defmethod send-challenge-response ((connection connection) response) (with-xml-stream (stream connection) Index: cl-xmpp/cl-xmpp-tls.lisp diff -u cl-xmpp/cl-xmpp-tls.lisp:1.1 cl-xmpp/cl-xmpp-tls.lisp:1.2 --- cl-xmpp/cl-xmpp-tls.lisp:1.1 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/cl-xmpp-tls.lisp Sat Nov 12 05:20:21 2005 @@ -1,39 +1,25 @@ -;;;; $Id: cl-xmpp-tls.lisp,v 1.1 2005/11/11 17:21:56 eenge Exp $ +;;;; $Id: cl-xmpp-tls.lisp,v 1.2 2005/11/12 04:20:21 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :xmpp) -(defmethod send-starttls ((connection connection)) - "Sends a request to start a TLS stream with the server. -There are some things you as a user of this library need -to know about this: - - 1) You should test for the presence of a starttls element - in the features slot of the connection and only call this - method if it is present. - - 2) Following your call to this method you should look for - either a proceed or a failure from the server. - - a) If you get a proceed you may call begin-tls-stream and - your connection is now secure (though read step 3). +(defun connect-tls (&rest args) + "Connect to the host and start a TLS stream." + (let ((connection (apply #'connect args))) + (send-starttls connection) + (begin-tls-stream connection) + connection)) - b) If you get a failure your connection is automatically - torn down by the server and you lose. - - 3) After begin-tls-stream you must proceed with sasl-auth - instead of the regular auth." +(defmethod send-starttls ((connection connection)) + "Sends a request to start a TLS stream with the server." (with-xml-stream (stream connection) (xml-output stream "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"))) -(defmethod begin-tls-stream ((connection connection)) +(defmethod convert-to-tls-stream ((connection connection)) "Convert the existing stream to a TLS stream and issue a stream:stream open tag to start the XML stream." (setf (server-stream connection) (cl+ssl:make-ssl-client-stream (server-stream connection))) (begin-xml-stream connection)) - -(defmethod sasl-auth ((connection) username password resource) - nil) \ No newline at end of file Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.12 cl-xmpp/cl-xmpp.lisp:1.13 --- cl-xmpp/cl-xmpp.lisp:1.12 Sat Nov 12 03:37:29 2005 +++ cl-xmpp/cl-xmpp.lisp Sat Nov 12 05:20:21 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.12 2005/11/12 02:37:29 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.13 2005/11/12 04:20:21 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -33,6 +33,10 @@ :documentation "List of xml-element objects representing the various mechainsms the host at the other end of the connection will accept.") + (jid-domain-part + :accessor jid-domain-part + :initarg :jid-domain-part + :initform nil) (username :accessor username :initarg :username) @@ -58,15 +62,36 @@ (format stream " (open)") (format stream " (closed)")))) -(defun connect (&key (hostname *default-hostname*) (port *default-port*)) - "Open TCP connection to hostname." +(defun connect (&key (hostname *default-hostname*) (port *default-port*) + (receive-stanzas t) (begin-xml-stream t) jid-domain-part) + "Open TCP connection to hostname. + +By default this will set up the complete XML stream and receive the initial +two stanzas (which would typically be stream:stream and stream:features) +to make sure the connection object is fully loaded with the features, +mechanisms and stream-id. If this is causing a problem for you just +specify :receive-stanzas nil. + +Using the same idea, you can disable the calling to begin-xml-stream. + +Some XMPP server's addresses are not the same as the domain part of +the JID (eg. talk.google.com vs gmail.com) so we provide the option of +passing that in here. Could perhaps be taken care of by the library +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))) (connection (make-instance 'connection + :jid-domain-part jid-domain-part :server-stream stream :hostname hostname :port port))) - (begin-xml-stream connection) + (when begin-xml-stream + (begin-xml-stream connection)) + (when receive-stanzas + (receive-stanza connection) + (receive-stanza connection)) connection)) (defmethod connectedp ((connection connection)) @@ -120,6 +145,7 @@ (defmethod handle ((connection connection) object) (format *debug-stream* "~&UNHANDLED: ~a~%" object) + (force-output *debug-stream*) object) ;; @@ -294,26 +320,22 @@ (write-sequence sequence stream) (finish-output stream) (when *debug-stream* - (write-string string *debug-stream*)))) + (write-string string *debug-stream*) + (force-output *debug-stream*)))) ;; ;; Operators for communicating over the XML stream ;; -(defmethod begin-xml-stream ((connection connection) &optional jid-domain-part) +(defmethod begin-xml-stream ((connection connection)) "Begin XML stream. This should be the first thing to happen on a -newly connected connection. - -Some XMPP server's addresses are not the same as the domain part of -the JID (eg. talk.google.com vs gmail.com) so we provide the option of -passing that in here. Could perhaps be taken care of by the library -but I'm trying not to optimize too early." +newly connected connection." (with-xml-stream (stream connection) (xml-output stream "<?xml version='1.0'?>") (xml-output stream (fmt "<stream:stream to='~a' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' -version='1.0'>" (or jid-domain-part (hostname connection)))))) +version='1.0'>" (or (jid-domain-part connection) (hostname connection)))))) (defmethod end-xml-stream ((connection connection)) "Closes the XML stream. At this point you'd have to Index: cl-xmpp/cxml.lisp diff -u cl-xmpp/cxml.lisp:1.4 cl-xmpp/cxml.lisp:1.5 --- cl-xmpp/cxml.lisp:1.4 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/cxml.lisp Sat Nov 12 05:20:21 2005 @@ -88,7 +88,8 @@ (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*))) + (write-char (code-char octet) *debug-stream*) + (force-output *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 Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.7 cl-xmpp/package.lisp:1.8 --- cl-xmpp/package.lisp:1.7 Fri Nov 11 22:20:20 2005 +++ cl-xmpp/package.lisp Sat Nov 12 05:20:21 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.7 2005/11/11 21:20:20 eenge Exp $ +;;;; $Id: package.lisp,v 1.8 2005/11/12 04:20:21 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -17,6 +17,8 @@ :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 + ;; only available if you've loaded cl-xmpp-tls + :connect-tls ;; xmpp commands :discover :registration-requirements :register

1 0

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

12 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv19607 Modified Files: cl-xmpp-sasl.lisp cl-xmpp.lisp Log Message: making handle write to *debug-stream* and now using cl-sasl 0.2 so passing it a byte-array, not a string of characters Date: Sat Nov 12 03:37:29 2005 Author: eenge Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.4 cl-xmpp/cl-xmpp-sasl.lisp:1.5 --- cl-xmpp/cl-xmpp-sasl.lisp:1.4 Sat Nov 12 03:29:51 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Sat Nov 12 03:37:29 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.4 2005/11/12 02:29:51 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.5 2005/11/12 02:37:29 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -32,7 +32,7 @@ :service "xmpp" :realm (hostname connection) :host (hostname connection))) - (response (sasl:client-step sasl-client challenge-string)) + (response (sasl:client-step sasl-client (ironclad:ascii-string-to-byte-array challenge-string))) (base64-response (base64:string-to-base64-string response))) (format *debug-stream* "~&challenge-string: ~a~%" challenge-string) (format *debug-stream* "response: ~a~%" response) Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.11 cl-xmpp/cl-xmpp.lisp:1.12 --- cl-xmpp/cl-xmpp.lisp:1.11 Sat Nov 12 03:29:51 2005 +++ cl-xmpp/cl-xmpp.lisp Sat Nov 12 03:37:29 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.11 2005/11/12 02:29:51 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.12 2005/11/12 02:37:29 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -119,7 +119,7 @@ (map 'list #'(lambda (x) (handle connection x)) list)) (defmethod handle ((connection connection) object) - (format t "~&UNHANDLED: ~a~%" object) + (format *debug-stream* "~&UNHANDLED: ~a~%" object) object) ;; @@ -389,7 +389,7 @@ (cxml:with-element "username" (cxml:text username)))) (defmethod auth ((connection connection) username password - resource &key (mechanism :plain)) + resource &optional (mechanism :plain)) (setf (username connection) username) (funcall (get-auth-method mechanism) connection username password resource))

1 0

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

12 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv18563 Modified Files: README cl-xmpp-sasl.lisp cl-xmpp.lisp Log Message: fixing a minor bug and making connect do begin-xml-stream for convenience's sake Date: Sat Nov 12 03:29:51 2005 Author: eenge Index: cl-xmpp/README diff -u cl-xmpp/README:1.4 cl-xmpp/README:1.5 --- cl-xmpp/README:1.4 Fri Nov 11 22:20:20 2005 +++ cl-xmpp/README Sat Nov 12 03:29:51 2005 @@ -7,9 +7,6 @@ * (defvar connection (xmpp:connect "username" :hostname "jabber.org")) -;; initiate XML stream with server - * (xmpp:begin-xml-stream connection) - ;; authenticate (or use xmpp:register to make an account) * (xmpp:auth connection "password" "resource") Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.3 cl-xmpp/cl-xmpp-sasl.lisp:1.4 --- cl-xmpp/cl-xmpp-sasl.lisp:1.3 Fri Nov 11 23:31:38 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Sat Nov 12 03:29:51 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.3 2005/11/11 22:31:38 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.4 2005/11/12 02:29:51 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -17,6 +17,10 @@ (add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%) (defmethod handle-challenge-response ((connection connection) username password mechanism) + "Helper method to the sasl authentication methods. Goes through the +entire SASL challenge/response chain. Returns two values, the first +is a keyword symbol (:success or :failure) and the second is the last +stanza received from the server." (initiate-sasl-authentication connection mechanism) (let ((initial-challenge (receive-stanza connection))) (if (eq (name initial-challenge) :challenge) @@ -33,17 +37,18 @@ (format *debug-stream* "~&challenge-string: ~a~%" challenge-string) (format *debug-stream* "response: ~a~%" response) (if (eq response :failure) - (error "SASL failure: ~a." challenge-string) + (values :failure initial-challenge) (progn (send-challenge-response connection base64-response) (let ((second-challenge (receive-stanza connection))) (if (eq (name second-challenge) :challenge) (progn (send-second-response connection) - ; This should return either :success or :failure. - (name (receive-stanza connection))) - (error "Expected second challenge, got: ~a." second-challenge)))))) - (error "Expected initial challenge, got: ~a." initial-challenge)))) + (let ((final-reply (receive-stanza connection))) + ; This should return either :success or :failure. + (values (name final-reply) final-reply))) + (values :failure second-challenge)))))) + (values :failure initial-challenge)))) (defmethod initiate-sasl-authentication ((connection connection) mechanism) (with-xml-stream (stream connection) Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.10 cl-xmpp/cl-xmpp.lisp:1.11 --- cl-xmpp/cl-xmpp.lisp:1.10 Fri Nov 11 22:20:20 2005 +++ cl-xmpp/cl-xmpp.lisp Sat Nov 12 03:29:51 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.10 2005/11/11 21:20:20 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.11 2005/11/12 02:29:51 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -58,14 +58,16 @@ (format stream " (open)") (format stream " (closed)")))) -(defun connect (username &key (hostname *default-hostname*) (port *default-port*)) +(defun connect (&key (hostname *default-hostname*) (port *default-port*)) "Open TCP connection to hostname." - (let ((stream (trivial-sockets:open-stream - hostname port :element-type '(unsigned-byte 8)))) - (make-instance 'connection - :server-stream stream - :hostname hostname - :port port))) + (let* ((stream (trivial-sockets:open-stream + hostname port :element-type '(unsigned-byte 8))) + (connection (make-instance 'connection + :server-stream stream + :hostname hostname + :port port))) + (begin-xml-stream connection) + connection)) (defmethod connectedp ((connection connection)) "Returns t if `connection' is connected to a server and is ready for

1 0

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

11 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv1234 Modified Files: cl-xmpp-sasl.lisp Log Message: Date: Fri Nov 11 23:31:38 2005 Author: eenge Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.2 cl-xmpp/cl-xmpp-sasl.lisp:1.3 --- cl-xmpp/cl-xmpp-sasl.lisp:1.2 Fri Nov 11 22:20:20 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Fri Nov 11 23:31:38 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.2 2005/11/11 21:20:20 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.3 2005/11/11 22:31:38 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -26,6 +26,7 @@ :authentication-id username :password password :service "xmpp" + :realm (hostname connection) :host (hostname connection))) (response (sasl:client-step sasl-client challenge-string)) (base64-response (base64:string-to-base64-string response)))

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/README cl-xmpp/TODO cl-xmpp/cl-xmpp-sasl.asd cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp-tls.asd cl-xmpp/cl-xmpp.lisp cl-xmpp/package.lisp cl-xmpp/utility.lisp cl-xmpp/variable.lisp
by eenge＠common-lisp.net 11 Nov '05

11 Nov '05

Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv28289 Modified Files: README TODO cl-xmpp-sasl.asd cl-xmpp-sasl.lisp cl-xmpp-tls.asd cl-xmpp.lisp package.lisp utility.lisp variable.lisp Log Message: near-complete sasl support Date: Fri Nov 11 22:20:20 2005 Author: eenge Index: cl-xmpp/README diff -u cl-xmpp/README:1.3 cl-xmpp/README:1.4 --- cl-xmpp/README:1.3 Mon Oct 31 18:03:30 2005 +++ cl-xmpp/README Fri Nov 11 22:20:20 2005 @@ -5,13 +5,13 @@ * (require :cl-xmpp) - * (defvar connection (xmpp:connect :hostname "jabber.org")) + * (defvar connection (xmpp:connect "username" :hostname "jabber.org")) ;; initiate XML stream with server * (xmpp:begin-xml-stream connection) ;; authenticate (or use xmpp:register to make an account) - * (xmpp:auth connection "username" "password" "resource") + * (xmpp:auth connection "password" "resource") ;; let the server know you want to receive/send presence information ;; (this makes you "come online" if others have a subscription with you Index: cl-xmpp/TODO diff -u cl-xmpp/TODO:1.6 cl-xmpp/TODO:1.7 --- cl-xmpp/TODO:1.6 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/TODO Fri Nov 11 22:20:20 2005 @@ -4,3 +4,5 @@ - also, i'm interning things which may screw up lisps with up/down case different. + +- i hate that xmlns's are as strings and never validated \ No newline at end of file Index: cl-xmpp/cl-xmpp-sasl.asd diff -u cl-xmpp/cl-xmpp-sasl.asd:1.1 cl-xmpp/cl-xmpp-sasl.asd:1.2 --- cl-xmpp/cl-xmpp-sasl.asd:1.1 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/cl-xmpp-sasl.asd Fri Nov 11 22:20:20 2005 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp-sasl.asd,v 1.1 2005/11/11 17:21:56 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.asd,v 1.2 2005/11/11 21:20:20 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.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 with SASL support" - :depends-on (#+sbcl :sb-bsd-sockets :trivial-sockets :cxml :ironclad :sasl) + :depends-on (#+sbcl :sb-bsd-sockets :trivial-sockets :cxml :ironclad :sasl :cl-base64) :components ((:file "package") (:file "variable" :depends-on ("package")) Index: cl-xmpp/cl-xmpp-sasl.lisp diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.1 cl-xmpp/cl-xmpp-sasl.lisp:1.2 --- cl-xmpp/cl-xmpp-sasl.lisp:1.1 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/cl-xmpp-sasl.lisp Fri Nov 11 22:20:20 2005 @@ -1,7 +1,60 @@ -;;;; $Id: cl-xmpp-sasl.lisp,v 1.1 2005/11/11 17:21:56 eenge Exp $ +;;;; $Id: cl-xmpp-sasl.lisp,v 1.2 2005/11/11 21:20:20 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $ ;;;; See the LICENSE file for licensing information. (in-package :xmpp) + +;;; XXX: Remember to BIND after these, I think. +(defmethod %sasl-plain% ((connection connection) username password resource) + (handle-challenge-response connection username password "PLAIN")) + +(add-auth-method :sasl-plain #'%sasl-plain%) + +(defmethod %sasl-digest-md5% ((connection connection) username password resource) + (handle-challenge-response connection username (digestify-string password) "DIGEST-MD5")) + +(add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%) + +(defmethod handle-challenge-response ((connection connection) username password mechanism) + (initiate-sasl-authentication connection mechanism) + (let ((initial-challenge (receive-stanza connection))) + (if (eq (name initial-challenge) :challenge) + (let* ((challenge-string (base64:base64-string-to-string + (data (get-element initial-challenge :\#text)))) + (sasl-client (make-instance (sasl:get-mechanism mechanism) + :authentication-id username + :password password + :service "xmpp" + :host (hostname connection))) + (response (sasl:client-step sasl-client challenge-string)) + (base64-response (base64:string-to-base64-string response))) + (format *debug-stream* "~&challenge-string: ~a~%" challenge-string) + (format *debug-stream* "response: ~a~%" response) + (if (eq response :failure) + (error "SASL failure: ~a." challenge-string) + (progn + (send-challenge-response connection base64-response) + (let ((second-challenge (receive-stanza connection))) + (if (eq (name second-challenge) :challenge) + (progn + (send-second-response connection) + ; This should return either :success or :failure. + (name (receive-stanza connection))) + (error "Expected second challenge, got: ~a." second-challenge)))))) + (error "Expected initial challenge, got: ~a." initial-challenge)))) + +(defmethod initiate-sasl-authentication ((connection connection) mechanism) + (with-xml-stream (stream connection) + (xml-output stream (fmt "<auth mechanism='~a' +xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" mechanism)))) + +(defmethod send-challenge-response ((connection connection) response) + (with-xml-stream (stream connection) + (xml-output stream + (fmt "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>~a</response>" response)))) + +(defmethod send-second-response ((connection connection)) + (with-xml-stream (stream connection) + (xml-output stream "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>"))) Index: cl-xmpp/cl-xmpp-tls.asd diff -u cl-xmpp/cl-xmpp-tls.asd:1.1 cl-xmpp/cl-xmpp-tls.asd:1.2 --- cl-xmpp/cl-xmpp-tls.asd:1.1 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/cl-xmpp-tls.asd Fri Nov 11 22:20:20 2005 @@ -1,5 +1,5 @@ ;;;; -*- mode: lisp -*- -;;;; $Id: cl-xmpp-tls.asd,v 1.1 2005/11/11 17:21:56 eenge Exp $ +;;;; $Id: cl-xmpp-tls.asd,v 1.2 2005/11/11 21:20:20 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -17,7 +17,8 @@ :version "0.0.1" :licence "MIT" :description "Common Lisp XMPP client implementation with TLS+SASL support" - :depends-on (#+sbcl :sb-bsd-sockets :trivial-sockets :cxml :ironclad :cl+ssl :sasl) + :depends-on (#+sbcl :sb-bsd-sockets :trivial-sockets :cxml + :ironclad :cl+ssl :sasl :cl-base64) :components ((:file "package") (:file "variable" :depends-on ("package")) Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.9 cl-xmpp/cl-xmpp.lisp:1.10 --- cl-xmpp/cl-xmpp.lisp:1.9 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/cl-xmpp.lisp Fri Nov 11 22:20:20 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.9 2005/11/11 17:21:56 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.10 2005/11/11 21:20:20 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -58,15 +58,14 @@ (format stream " (open)") (format stream " (closed)")))) -;;; XXX: "not-a-pathname"? Need it because CXML wants to call -;;; pathname on the stream and without one it returns NIL which -;;; CXML breaks on. -(defun connect (&key (hostname *default-hostname*) (port *default-port*)) +(defun connect (username &key (hostname *default-hostname*) (port *default-port*)) "Open TCP connection to hostname." (let ((stream (trivial-sockets:open-stream hostname port :element-type '(unsigned-byte 8)))) - (make-instance 'connection :server-stream stream - :hostname hostname :port port))) + (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 @@ -80,6 +79,36 @@ (close (server-stream connection)) connection) +(defmethod feature-p ((connection connection) feature-name) + "See if connection has a specific feature. + +Eg. (has-feature *my-connection* :starttls) + +Returns the xml-element representing the feature if it +is present, nil otherwise." + (dolist (feature (features connection)) + (when (eq (name feature) feature-name) + (return-from feature-p feature)))) + +(defmethod feature-required-p ((connection connection) feature-name) + "Checks if feature is required. Three possible outcomes + +t - feature is supported and required +nil - feature is support but not required +:not-supported - feature is not supported" + (let ((feature (feature-p connection feature-name))) + (if feature + (if (get-element feature :required) + t + nil) + :not-supported))) + +(defmethod mechanism-p ((connection connection) mechanism-name) + (dolist (mechanism (mechanisms connection)) + (let ((name (intern (data (get-element mechanism :\#text)) :keyword))) + (when (eq name mechanism-name) + (return-from mechanism-p mechanism))))) + ;; ;; Handle ;; @@ -215,17 +244,24 @@ 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)))) - (cond - ((equal tagname "stream:error") - (when stanza-callback - (funcall stanza-callback stanza connection :dom-repr dom-repr)) - (error "Received error.")) - (t - (when stanza-callback - (funcall stanza-callback stanza connection :dom-repr dom-repr))))))) + (loop (receive-stanza connection + :stanza-callback stanza-callback + :dom-repr dom-repr))) + +(defmethod receive-stanza ((connection connection) &key + (stanza-callback 'default-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))))))) (defun read-stanza (connection) (unless (server-xstream connection) @@ -246,7 +282,9 @@ to the debug stream. It's not strictly /with/ xml-stream so it should probably be renamed." `(let ((,stream (server-stream ,connection))) - ,@body)) + (progn + ,@body + ,connection))) (defun xml-output (stream string) "Write string to stream as a sequence of bytes and not characters." @@ -256,24 +294,31 @@ (when *debug-stream* (write-string string *debug-stream*)))) -(defmethod begin-xml-stream ((connection connection)) - "Begin XML stream. This should be the first thing to -happen on a newly connected connection." +;; +;; Operators for communicating over the XML stream +;; + +(defmethod begin-xml-stream ((connection connection) &optional jid-domain-part) + "Begin XML stream. This should be the first thing to happen on a +newly connected connection. + +Some XMPP server's addresses are not the same as the domain part of +the JID (eg. talk.google.com vs gmail.com) so we provide the option of +passing that in here. Could perhaps be taken care of by the library +but I'm trying not to optimize too early." (with-xml-stream (stream connection) (xml-output stream "<?xml version='1.0'?>") (xml-output stream (fmt "<stream:stream to='~a' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' -version='1.0'>" (hostname connection)))) - connection) +version='1.0'>" (or jid-domain-part (hostname 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>")) - connection) + (xml-output stream "</stream:stream>"))) (defmacro with-iq ((connection &key id to (type "get")) &body body) "Macro to make it easier to write IQ stanzas." @@ -305,10 +350,11 @@ ;; (defmethod discover ((connection connection) &key (type :info) to node) - (let ((xmlns (case type - (:info "http://jabber.org/protocol/disco#info") - (:items "http://jabber.org/protocol/disco#items") - (t (error "Unknown type: ~a (Please choose between :info and :items)" type))))) + (let ((xmlns + (case type + (:info "http://jabber.org/protocol/disco#info") + (:items "http://jabber.org/protocol/disco#items") + (t (error "Unknown type: ~a (Please choose between :info and :items)" type))))) (with-iq-query (connection :id "info1" :xmlns xmlns :to to :node node)))) ;; @@ -340,19 +386,29 @@ (with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth") (cxml:with-element "username" (cxml:text username)))) -(defmethod auth ((connection connection) username password resource &key digestp) +(defmethod auth ((connection connection) username password + resource &key (mechanism :plain)) (setf (username connection) username) + (funcall (get-auth-method mechanism) connection username password resource)) + +(defmethod %plain-auth% ((connection connection) username password resource) + (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)) + (cxml:with-element "resource" (cxml:text resource)))) + +(add-auth-method :plain #'%plain-auth%) + +(defmethod %digest-md5-auth% ((connection connection) username password resource) (with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth") (cxml:with-element "username" (cxml:text username)) - (if digestp - (if (stream-id connection) - (cxml:with-element "digest" (cxml:text - (make-digest-password - (stream-id connection) - password))) - (error "stream-id on ~a not set, cannot make digest password" connection)) - (cxml:with-element "password" (cxml:text password))) + (if (stream-id connection) + (cxml:with-element "digest" + (cxml:text (make-digest-password (stream-id connection) password))) + (error "stream-id on ~a not set, cannot make digest password" connection)) (cxml:with-element "resource" (cxml:text resource)))) + +(add-auth-method :digest-md5 #'%digest-md5-auth%) (defmethod presence ((connection connection) &key type to) (cxml:with-xml-output (make-octet+character-debug-stream-sink Index: cl-xmpp/package.lisp diff -u cl-xmpp/package.lisp:1.6 cl-xmpp/package.lisp:1.7 --- cl-xmpp/package.lisp:1.6 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/package.lisp Fri Nov 11 22:20:20 2005 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.6 2005/11/11 17:21:56 eenge Exp $ +;;;; $Id: package.lisp,v 1.7 2005/11/11 21:20:20 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -16,6 +16,7 @@ :connect :disconnect :stream- :hostname :port :connectedp :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 ;; xmpp commands :discover :registration-requirements :register Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.6 cl-xmpp/utility.lisp:1.7 --- cl-xmpp/utility.lisp:1.6 Thu Nov 10 21:41:28 2005 +++ cl-xmpp/utility.lisp Fri Nov 11 22:20:20 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.6 2005/11/10 20:41:28 eenge Exp $ +;;;; $Id: utility.lisp,v 1.7 2005/11/11 21:20:20 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -35,4 +35,15 @@ (handle connection result) (handle connection (dom-to-event connection result))))) +(defun list-auth-method-names () + (mapcar #'car *auth-methods*)) +(defun get-auth-method (name) + (let ((auth-method (second (assoc name *auth-methods*)))) + (if auth-method + (return-from get-auth-method auth-method) + (error "Unknown mechanism name: ~s. Please choose between: ~s." + name (list-auth-method-names))))) + +(defun add-auth-method (name operator) + (push (list name operator) *auth-methods*)) Index: cl-xmpp/variable.lisp diff -u cl-xmpp/variable.lisp:1.3 cl-xmpp/variable.lisp:1.4 --- cl-xmpp/variable.lisp:1.3 Fri Nov 11 18:21:56 2005 +++ cl-xmpp/variable.lisp Fri Nov 11 22:20:20 2005 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.3 2005/11/11 17:21:56 eenge Exp $ +;;;; $Id: variable.lisp,v 1.4 2005/11/11 21:20:20 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -35,3 +35,9 @@ (:undefined-condition :any 500) (:unexpected-request :wait 400))) +(defvar *auth-methods* nil + "Alist of method name to operator. + +Operators must accept the following operands: + + connection username password resource")

1 0

[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.asd cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp-tls.asd cl-xmpp/cl-xmpp-tls.lisp cl-xmpp/CREDITS cl-xmpp/TODO cl-xmpp/cl-xmpp.asd cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/package.lisp cl-xmpp/variable.lisp
by eenge＠common-lisp.net 11 Nov '05

11 Nov '05

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)))

1 0

[cl-xmpp-cvs] CVS update: public_html/index.html
by eenge＠common-lisp.net 11 Nov '05

11 Nov '05

Update of /project/cl-xmpp/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv30363 Modified Files: index.html Log Message: adding comment about needing trivial-sockets Date: Fri Nov 11 15:38:10 2005 Author: eenge Index: public_html/index.html diff -u public_html/index.html:1.17 public_html/index.html:1.18 --- public_html/index.html:1.17 Thu Nov 10 22:17:59 2005 +++ public_html/index.html Fri Nov 11 15:38:09 2005 @@ -30,7 +30,8 @@ <h2>Requirements</h2> <div class="level"> <ul> - <li>SBCL, LispWorks, OpenMCL and Allegro (patches welcome for others)</li> + <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> </ul>

1 0