[cl-xmpp-cvs] CVS update: cl-xmpp/CREDITS cl-xmpp/TODO cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp-tls.lisp cl-xmpp/cl-xmpp.lisp cl-xmpp/result.lisp
Erik Enge
eenge at common-lisp.net
Thu Nov 17 19:41:43 UTC 2005
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv7442
Modified Files:
CREDITS TODO cl-xmpp-sasl.lisp cl-xmpp-tls.lisp cl-xmpp.lisp
result.lisp
Log Message:
working sasl and working tls support
still some issue talking with google talk but less important
Date: Thu Nov 17 20:41:41 2005
Author: eenge
Index: cl-xmpp/CREDITS
diff -u cl-xmpp/CREDITS:1.2 cl-xmpp/CREDITS:1.3
--- cl-xmpp/CREDITS:1.2 Fri Nov 11 18:21:56 2005
+++ cl-xmpp/CREDITS Thu Nov 17 20:41:40 2005
@@ -1,4 +1,5 @@
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
+Richard Krueter for Clisp support
+Adam Thorsen for helping me debug SASL bugs
\ No newline at end of file
Index: cl-xmpp/TODO
diff -u cl-xmpp/TODO:1.9 cl-xmpp/TODO:1.10
--- cl-xmpp/TODO:1.9 Mon Nov 14 21:07:36 2005
+++ cl-xmpp/TODO Thu Nov 17 20:41:40 2005
@@ -1,6 +1,8 @@
- respect stringprep/nodeprep - jid validator
- i hate that xmlns's are as strings and never validated
+ - could perhaps pass xmlns as last parameter to
+ xml-element-to-event
- create a connect-test which makes a "fake" connection but
still writes into a stream. prerequisite for writing a test
Index: cl-xmpp/cl-xmpp-sasl.lisp
diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.8 cl-xmpp/cl-xmpp-sasl.lisp:1.9
--- cl-xmpp/cl-xmpp-sasl.lisp:1.8 Mon Nov 14 20:21:06 2005
+++ cl-xmpp/cl-xmpp-sasl.lisp Thu Nov 17 20:41:40 2005
@@ -1,25 +1,16 @@
-;;;; $Id: cl-xmpp-sasl.lisp,v 1.8 2005/11/14 19:21:06 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.lisp,v 1.9 2005/11/17 19:41:40 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%)
-
+;;; XXX: Remember to BIND after this, I think.
(defmethod %sasl-digest-md5% ((connection connection) username password resource)
- (handle-challenge-response connection
- username
- (make-digest-password
- (stream-id connection)
- password)
- "DIGEST-MD5"))
+ (handle-challenge-response connection username password "DIGEST-MD5"))
-(add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%)
+(eval-when (:execute :load-toplevel :compile-toplevel)
+ (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
@@ -31,6 +22,7 @@
:password password
:service "xmpp"
:host (hostname connection))))
+ (format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client))
(initiate-sasl-authentication connection mechanism sasl-client)
(let ((initial-challenge (receive-stanza connection)))
(if (eq (name initial-challenge) :challenge)
@@ -39,7 +31,8 @@
(usb8-response (sasl:client-step
sasl-client
(ironclad:ascii-string-to-byte-array challenge-string))))
- (format *debug-stream* "~&challenge-string: ~a~%" challenge-string)
+ (format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client))
+ (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)))
@@ -59,7 +52,9 @@
(defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client)
(with-xml-stream (stream connection)
- (xml-output stream (fmt "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='~a'/>" mechanism))))
+ (xml-output
+ stream
+ (fmt "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='~a'/>" mechanism))))
(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.5 cl-xmpp/cl-xmpp-tls.lisp:1.6
--- cl-xmpp/cl-xmpp-tls.lisp:1.5 Wed Nov 16 20:06:12 2005
+++ cl-xmpp/cl-xmpp-tls.lisp Thu Nov 17 20:41:40 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-tls.lisp,v 1.5 2005/11/16 19:06:12 eenge Exp $
+;;;; $Id: cl-xmpp-tls.lisp,v 1.6 2005/11/17 19:41:40 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -11,8 +11,17 @@
(send-starttls connection)
(let ((reply (receive-stanza connection)))
(case (name reply)
- (:proceed (convert-to-tls-stream connection)
- (values connection :proceed reply))
+ (:proceed
+ (let ((begin-xml-stream (if (member :begin-xml-stream args)
+ (getf args :begin-xml-stream)
+ t))
+ (receive-stanzas (if (member :begin-xml-stream args)
+ (getf args :begin-xml-stream)
+ t)))
+ (convert-to-tls-stream connection
+ :begin-xml-stream begin-xml-stream
+ :receive-stanzas receive-stanzas)
+ (values connection :proceed reply)))
(:failure (values connection :failure reply))
(t (error "Unexpected reply from TLS negotiation: ~a." reply))))))
@@ -21,14 +30,18 @@
(with-xml-stream (stream connection)
(xml-output stream "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>")))
-(defmethod convert-to-tls-stream ((connection connection) &key (begin-xml-stream t))
+(defmethod convert-to-tls-stream ((connection connection) &key
+ (begin-xml-stream t)
+ (receive-stanzas t))
"Convert the existing stream to a TLS stream and issue
a stream:stream open tag to start the XML stream.
Turn off sending XML stream start with :begin-xml-stream nil."
(setf (server-stream connection)
(cl+ssl:make-ssl-client-stream (server-stream connection)))
- (setf (server-xstream connection)
- (cxml:make-xstream (server-stream connection)))
- (when begin-xml-stream
- (begin-xml-stream connection)))
+ (setf (server-xstream connection) nil)
+ (when begin-xml-stream
+ (begin-xml-stream connection))
+ (when receive-stanzas
+ (receive-stanza connection)
+ (receive-stanza connection)))
\ No newline at end of file
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.16 cl-xmpp/cl-xmpp.lisp:1.17
--- cl-xmpp/cl-xmpp.lisp:1.16 Mon Nov 14 21:07:36 2005
+++ cl-xmpp/cl-xmpp.lisp Thu Nov 17 20:41:40 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.16 2005/11/14 20:07:36 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.17 2005/11/17 19:41:40 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -62,6 +62,9 @@
(format stream " (open)")
(format stream " (closed)"))))
+;;; Note: If you change the default value of either receive-stanzas
+;;; or begin-xml-stream you must update that value in cl-xmpp-tls.lisp's
+;;; connect-tls to be the same.
(defun connect (&key (hostname *default-hostname*) (port *default-port*)
(receive-stanzas t) (begin-xml-stream t) jid-domain-part)
"Open TCP connection to hostname.
@@ -417,7 +420,8 @@
(cxml:with-element "password" (cxml:text password))
(cxml:with-element "resource" (cxml:text resource))))
-(add-auth-method :plain #'%plain-auth%)
+(eval-when (:execute :load-toplevel :compile-toplevel)
+ (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")
@@ -428,7 +432,8 @@
(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%)
+(eval-when (:execute :load-toplevel :compile-toplevel)
+ (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/result.lisp
diff -u cl-xmpp/result.lisp:1.10 cl-xmpp/result.lisp:1.11
--- cl-xmpp/result.lisp:1.10 Tue Nov 15 16:19:08 2005
+++ cl-xmpp/result.lisp Thu Nov 17 20:41:40 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.10 2005/11/15 15:19:08 eenge Exp $
+;;;; $Id: result.lisp,v 1.11 2005/11/17 19:41:40 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -66,7 +66,7 @@
(defmethod print-object ((object xml-element) stream)
"Print the object for the Lisp reader."
(print-unreadable-object (object stream :type t :identity t)
- (format stream "~a (~a:~a:~a)"
+ (format stream "~a (~aattr:~achild:~adata)"
(name object)
(length (attributes object))
(length (elements object))
@@ -288,8 +288,11 @@
(defmethod print-object ((object xmpp-protocol-error) stream)
"Print the object for the Lisp reader."
- (print-unreadable-object (object stream :type t :identity t)
- (format stream "code:~a name:~a" (code object) (name object))))
+ (print-unreadable-object (object stream :type nil :identity t)
+ (format stream "~a code:~a name:~a"
+ (type-of object)
+ (code object)
+ (name object))))
(defclass xmpp-protocol-error-modify (xmpp-protocol-error) ())
(defclass xmpp-protocol-error-cancel (xmpp-protocol-error) ())
@@ -304,29 +307,18 @@
(defun map-error-type-to-class (type)
(case type
- (modify (find-class 'xmpp-protocol-error-modify))
- (cancel (find-class 'xmpp-protocol-error-cancel))
- (wait (find-class 'xmpp-protocol-error-wait))
- (auth (find-class 'xmpp-protocol-error-auth))
- (t (find-class 'xmpp-protocol-error))))
+ (:modify (find-class 'xmpp-protocol-error-modify))
+ (:cancel (find-class 'xmpp-protocol-error-cancel))
+ (:wait (find-class 'xmpp-protocol-error-wait))
+ (:auth (find-class 'xmpp-protocol-error-auth))
+ (t (format *debug-stream* "~&Unable to find error class for ~w.~&" type)
+ (find-class 'xmpp-protocol-error))))
+;;; XXX: Handle legacy errors
(defmethod make-error ((object xml-element))
- (let* ((first-element (car (elements object)))
- (name)
- (type)
- (code)
- (class))
- (if (eq (name first-element) :\#text) ; old-style error
- (progn
- (setq code (parse-integer (value (get-attribute object :code))))
- (let ((data (get-error-data-code code)))
- (setq name (first data))
- (setq type (second data))
- (setq class (map-error-type-to-class type))))
- (progn
- (setq name (name first-element))
- (let ((data (get-error-data-name name)))
- (setq type (second data))
- (setq code (third data))
- (setq class (map-error-type-to-class type)))))
+ (let* ((code (parse-integer (value (get-attribute object :code))))
+ (data (get-error-data-code code))
+ (name (first data))
+ (type (second data))
+ (class (map-error-type-to-class type)))
(make-instance class :code code :name name :xml-element object)))
More information about the Cl-xmpp-cvs
mailing list