[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
Erik Enge
eenge at common-lisp.net
Fri Nov 11 21:20:26 UTC 2005
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)))
- , at body))
+ (progn
+ , at 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")
More information about the Cl-xmpp-cvs
mailing list