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