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