- - A recent SBCL (need 16bit wide characters), LispWorks or Allegro (patches welcome for others)
+ - SBCL, LispWorks, OpenMCL and Allegro (patches welcome for others)
- cxml
- Ironclad
From eenge at common-lisp.net Fri Nov 11 14:38:10 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 11 Nov 2005 15:38:10 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051111143810.07A0C88556@common-lisp.net>
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 @@
Requirements
- - SBCL, LispWorks, OpenMCL and Allegro (patches welcome for others)
+ - Any implementation which can run the dependencies
+ - trivial-sockets
- cxml
- Ironclad
From eenge at common-lisp.net Fri Nov 11 17:22:13 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 11 Nov 2005 18:22:13 +0100 (CET)
Subject: [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
Message-ID: <20051111172213.663C388565@common-lisp.net>
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
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)))
, at 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 "" (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 "")))
+ (xml-output 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)
, at 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)))
From eenge at common-lisp.net Fri Nov 11 21:20:26 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 11 Nov 2005 22:20:26 +0100 (CET)
Subject: [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
Message-ID: <20051111212026.F0E1D88556@common-lisp.net>
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 "" mechanism))))
+
+(defmethod send-challenge-response ((connection connection) response)
+ (with-xml-stream (stream connection)
+ (xml-output stream
+ (fmt "~a" response))))
+
+(defmethod send-second-response ((connection connection))
+ (with-xml-stream (stream connection)
+ (xml-output stream "")))
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-output stream (fmt "" (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 ""))
- connection)
+ (xml-output 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")
From eenge at common-lisp.net Fri Nov 11 22:31:39 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 11 Nov 2005 23:31:39 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp
Message-ID: <20051111223139.637A588556@common-lisp.net>
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)))
From eenge at common-lisp.net Sat Nov 12 02:29:52 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 12 Nov 2005 03:29:52 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/README cl-xmpp/cl-xmpp-sasl.lisp
cl-xmpp/cl-xmpp.lisp
Message-ID: <20051112022952.78C4388565@common-lisp.net>
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
From eenge at common-lisp.net Sat Nov 12 02:37:30 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 12 Nov 2005 03:37:30 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp
cl-xmpp/cl-xmpp.lisp
Message-ID: <20051112023730.A361288565@common-lisp.net>
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))
From eenge at common-lisp.net Sat Nov 12 04:20:24 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 12 Nov 2005 05:20:24 +0100 (CET)
Subject: [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
Message-ID: <20051112042024.EE44688567@common-lisp.net>
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)
[....]
+;; 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 "" mechanism))))
+xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>~a"
+ 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 "")))
-(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-output stream (fmt "" (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
From eenge at common-lisp.net Sat Nov 12 04:22:04 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 12 Nov 2005 05:22:04 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/README
Message-ID: <20051112042204.3B54588567@common-lisp.net>
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")
From eenge at common-lisp.net Sat Nov 12 04:30:57 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 12 Nov 2005 05:30:57 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-tls.lisp
Message-ID: <20051112043057.EBB9388567@common-lisp.net>
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))
From eenge at common-lisp.net Sat Nov 12 20:53:18 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 12 Nov 2005 21:53:18 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/TODO
Message-ID: <20051112205318.391538855F@common-lisp.net>
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).
From eenge at common-lisp.net Sun Nov 13 02:08:13 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:08:13 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: Directory change: cl-xmpp/test
Message-ID: <20051113020813.DF64888545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp/test
In directory common-lisp.net:/tmp/cvs-serv25800/test
Log Message:
Directory /project/cl-xmpp/cvsroot/cl-xmpp/test added to the repository
Date: Sun Nov 13 03:08:13 2005
Author: eenge
New directory cl-xmpp/test added
From eenge at common-lisp.net Sun Nov 13 02:36:12 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:36:12 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/Makefile cl-xmpp/cl-xmpp-sasl.asd
cl-xmpp/cl-xmpp-tls.asd cl-xmpp/cl-xmpp.asd cl-xmpp/package.lisp
Message-ID: <20051113023612.78A6388545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv27919
Modified Files:
Makefile cl-xmpp-sasl.asd cl-xmpp-tls.asd cl-xmpp.asd
package.lisp
Log Message:
beginnings of test suite
cleaned up .asd's a little
Date: Sun Nov 13 03:36:10 2005
Author: eenge
Index: cl-xmpp/Makefile
diff -u cl-xmpp/Makefile:1.2 cl-xmpp/Makefile:1.3
--- cl-xmpp/Makefile:1.2 Sat Oct 29 19:25:04 2005
+++ cl-xmpp/Makefile Sun Nov 13 03:36:09 2005
@@ -1,2 +1,4 @@
clean:
- rm *~ *.fasl *.nfasl
+ find ./ -name *.fasl -exec rm \{\} \;
+ find ./ -name *.nfasl -exec rm \{\} \;
+ find ./ -name *~ -exec rm \{\} \;
Index: cl-xmpp/cl-xmpp-sasl.asd
diff -u cl-xmpp/cl-xmpp-sasl.asd:1.2 cl-xmpp/cl-xmpp-sasl.asd:1.3
--- cl-xmpp/cl-xmpp-sasl.asd:1.2 Fri Nov 11 22:20:20 2005
+++ cl-xmpp/cl-xmpp-sasl.asd Sun Nov 13 03:36:10 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp-sasl.asd,v 1.2 2005/11/11 21:20:20 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.asd,v 1.3 2005/11/13 02:36:10 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -14,21 +14,8 @@
(defsystem cl-xmpp-sasl
:name "cl-xmpp-sasl"
:author "Erik Enge"
- :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 :cl-base64)
- :components ((:file "package")
- (:file "variable"
- :depends-on ("package"))
- (:file "utility"
- :depends-on ("variable"))
- (:file "cxml"
- :depends-on ("utility"))
- (:file "result"
- :depends-on ("cxml"))
- (:file "cl-xmpp"
- :depends-on ("result"))
- (:file "cl-xmpp-sasl"
- :depends-on ("cl-xmpp"))))
+ :depends-on (:cl-xmpp :cl-base64 :sasl)
+ :components ((:file "cl-xmpp-sasl")))
Index: cl-xmpp/cl-xmpp-tls.asd
diff -u cl-xmpp/cl-xmpp-tls.asd:1.2 cl-xmpp/cl-xmpp-tls.asd:1.3
--- cl-xmpp/cl-xmpp-tls.asd:1.2 Fri Nov 11 22:20:20 2005
+++ cl-xmpp/cl-xmpp-tls.asd Sun Nov 13 03:36:10 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp-tls.asd,v 1.2 2005/11/11 21:20:20 eenge Exp $
+;;;; $Id: cl-xmpp-tls.asd,v 1.3 2005/11/13 02:36:10 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -14,24 +14,8 @@
(defsystem cl-xmpp-tls
:name "cl-xmpp-tls"
:author "Erik Enge"
- :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 :cl-base64)
- :components ((:file "package")
- (:file "variable"
- :depends-on ("package"))
- (:file "utility"
- :depends-on ("variable"))
- (:file "cxml"
- :depends-on ("utility"))
- (:file "result"
- :depends-on ("cxml"))
- (:file "cl-xmpp"
- :depends-on ("result"))
- (:file "cl-xmpp-sasl"
- :depends-on ("cl-xmpp"))
- (:file "cl-xmpp-tls"
- :depends-on ("cl-xmpp-sasl"))))
+ :depends-on (:cl-xmpp-sasl :cl+ssl)
+ :components ((:file "cl-xmpp-sasl")))
Index: cl-xmpp/cl-xmpp.asd
diff -u cl-xmpp/cl-xmpp.asd:1.5 cl-xmpp/cl-xmpp.asd:1.6
--- cl-xmpp/cl-xmpp.asd:1.5 Fri Nov 11 18:21:56 2005
+++ cl-xmpp/cl-xmpp.asd Sun Nov 13 03:36:10 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp.asd,v 1.5 2005/11/11 17:21:56 eenge Exp $
+;;;; $Id: cl-xmpp.asd,v 1.6 2005/11/13 02:36:10 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -14,7 +14,6 @@
(defsystem cl-xmpp
:name "cl-xmpp"
:author "Erik Enge"
- :version "0.0.1"
:licence "MIT"
:description "Common Lisp XMPP client implementation"
:depends-on (#+sbcl :sb-bsd-sockets :trivial-sockets :cxml :ironclad)
Index: cl-xmpp/package.lisp
diff -u cl-xmpp/package.lisp:1.8 cl-xmpp/package.lisp:1.9
--- cl-xmpp/package.lisp:1.8 Sat Nov 12 05:20:21 2005
+++ cl-xmpp/package.lisp Sun Nov 13 03:36:10 2005
@@ -1,4 +1,4 @@
-;;;; $Id: package.lisp,v 1.8 2005/11/12 04:20:21 eenge Exp $
+;;;; $Id: package.lisp,v 1.9 2005/11/13 02:36:10 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -33,7 +33,7 @@
:get-privacy-lists :get-privacy-list
;; dom-ish interface
:xml-element :name :elements :attributes :node :data
- :xml-attribute :value
+ :xml-attribute :value :get-element :get-attribute
;; event interface
:event
:presence
From eenge at common-lisp.net Sun Nov 13 02:36:13 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:36:13 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/test/cl-xmpp-test.asd
cl-xmpp/test/package.lisp cl-xmpp/test/result-test.lisp
cl-xmpp/test/utility-test.lisp
Message-ID: <20051113023613.21BC88855F@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp/test
In directory common-lisp.net:/tmp/cvs-serv27919/test
Added Files:
cl-xmpp-test.asd package.lisp result-test.lisp
utility-test.lisp
Log Message:
beginnings of test suite
cleaned up .asd's a little
Date: Sun Nov 13 03:36:11 2005
Author: eenge
From eenge at common-lisp.net Sun Nov 13 02:45:42 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:45:42 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/Makefile
Message-ID: <20051113024542.8F62A88545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv28518
Modified Files:
Makefile
Log Message:
more tests
Date: Sun Nov 13 03:45:41 2005
Author: eenge
Index: cl-xmpp/Makefile
diff -u cl-xmpp/Makefile:1.3 cl-xmpp/Makefile:1.4
--- cl-xmpp/Makefile:1.3 Sun Nov 13 03:36:09 2005
+++ cl-xmpp/Makefile Sun Nov 13 03:45:41 2005
@@ -1,4 +1,8 @@
clean:
- find ./ -name *.fasl -exec rm \{\} \;
- find ./ -name *.nfasl -exec rm \{\} \;
- find ./ -name *~ -exec rm \{\} \;
+ find ./ -name "*.fasl" \
+ -o -name "*.faslmt" \
+ -o -name "*~" \
+ -o -name "*.err" \
+ -o -name "*.x86f" \
+ -o -name "*.nfasl" \
+ | xargs rm
From eenge at common-lisp.net Sun Nov 13 02:45:42 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:45:42 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/test/result-test.lisp
Message-ID: <20051113024542.280848855F@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp/test
In directory common-lisp.net:/tmp/cvs-serv28518/test
Modified Files:
result-test.lisp
Log Message:
more tests
Date: Sun Nov 13 03:45:42 2005
Author: eenge
Index: cl-xmpp/test/result-test.lisp
diff -u cl-xmpp/test/result-test.lisp:1.1 cl-xmpp/test/result-test.lisp:1.2
--- cl-xmpp/test/result-test.lisp:1.1 Sun Nov 13 03:36:11 2005
+++ cl-xmpp/test/result-test.lisp Sun Nov 13 03:45:41 2005
@@ -1,10 +1,17 @@
-;;;; $Id: result-test.lisp,v 1.1 2005/11/13 02:36:11 eenge Exp $
+;;;; $Id: result-test.lisp,v 1.2 2005/11/13 02:45:41 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/result-test.lisp,v $
;;;; See the LICENSE file for licensing information.
(in-package :xmpp-test)
-(defvar *empty-element* #.(make-instance 'xmpp:xml-element :name :test))
+(defvar *empty-element* (make-instance 'xmpp:xml-element :name :test))
+(defvar *sub-element* (make-instance 'xmpp:xml-element :name :subtest))
+(defvar *element+subelement*
+ (make-instance 'xmpp:xml-element
+ :name :test
+ :elements (list *sub-element*)))
-(deftest get-element.1 (xmpp:get-element *empty-element* :x) nil)
\ No newline at end of file
+(deftest get-element.1 (xmpp:get-element *empty-element* :x) nil)
+(deftest get-element.2 (xmpp:get-element *element+subelement* :x) nil)
+(deftest get-element.3 (xmpp:get-element *element+subelement* :subtest) #.*sub-element*)
From eenge at common-lisp.net Sun Nov 13 02:55:15 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:55:15 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051113025515.B6A0588545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv29070
Modified Files:
index.html
Log Message:
updating docs in preparation for new release
Date: Sun Nov 13 03:55:15 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.18 public_html/index.html:1.19
--- public_html/index.html:1.18 Fri Nov 11 15:38:09 2005
+++ public_html/index.html Sun Nov 13 03:55:15 2005
@@ -7,7 +7,7 @@
@@ -34,12 +34,16 @@
trivial-sockets
cxml
Ironclad
+
cl-base64 (if you are using cl-xmpp-{sasl|tls}.asd)
+
cl-sasl (if you are using cl-xmpp-{sasl|tls}.asd)
+
cl+ssl (if you are using cl-xmpp-tls.asd
News
+ - Version 0.6.0 released (SASL and TLS support, better debugability + small test suite)
- Version 0.5.0 released (Now depending on Ironclad for digest authentication)
- Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)
- Version 0.3.0 released (Added Allegro and LispWorks support)
@@ -92,16 +96,18 @@
* (require :cl-xmpp)
- * (defvar connection (xmpp:connect :hostname "jabber.org"))
-
-;; initiate XML stream with server
- * (xmpp:begin-xml-stream connection)
+ * (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 "username" "password" "resource")
+ * (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
@@ -109,8 +115,11 @@
;; then sit back and watch the messages roll in:
* (xmpp:receive-stanza-loop connection)
-#<MESSAGE from=username at hostname to=me at 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)
@@ -120,16 +129,16 @@
;; 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:
* (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message))
(xmpp:message connection (xmpp:from message)
- (format nil "reply to: ~a~%" (xmpp:message object))))
-
-
+ (format nil "reply to: ~a" (xmpp:message object))))
+
From eenge at common-lisp.net Sun Nov 13 02:55:48 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:55:48 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/README cl-xmpp/result.lisp
Message-ID: <20051113025548.2821488545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv29110
Modified Files:
README result.lisp
Log Message:
more tests and updated README slightly
Date: Sun Nov 13 03:55:46 2005
Author: eenge
Index: cl-xmpp/README
diff -u cl-xmpp/README:1.7 cl-xmpp/README:1.8
--- cl-xmpp/README:1.7 Sat Nov 12 05:22:03 2005
+++ cl-xmpp/README Sun Nov 13 03:55:46 2005
@@ -46,5 +46,5 @@
* (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message))
(xmpp:message connection (xmpp:from message)
- (format nil "reply to: ~a~%" (xmpp:message object))))
+ (format nil "reply to: ~a" (xmpp:message object))))
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.7 cl-xmpp/result.lisp:1.8
--- cl-xmpp/result.lisp:1.7 Mon Oct 31 22:07:15 2005
+++ cl-xmpp/result.lisp Sun Nov 13 03:55:46 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $
+;;;; $Id: result.lisp,v 1.8 2005/11/13 02:55:46 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -32,10 +32,8 @@
;;; In the end, I don't know if this will be sufficient. It is
;;; for me at present time as all I really wanted to do was play
;;; around with XMPP in CL. If you have an idea which you wish
-;;; were implemented in this library or perhaps you know a better
-;;; way of doing this please don't hesitate to speak up as I
-;;; most likely won't have much to do with this library from
-;;; now on.
+;;; were implemented in this library or perhaps you know of a better
+;;; way of doing this please don't hesitate to speak.
(defclass xml-element ()
((name
From eenge at common-lisp.net Sun Nov 13 02:55:48 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sun, 13 Nov 2005 03:55:48 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/test/cl-xmpp-test.lisp
cl-xmpp/test/cl-xmpp-test.asd cl-xmpp/test/result-test.lisp
Message-ID: <20051113025548.420178855F@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp/test
In directory common-lisp.net:/tmp/cvs-serv29110/test
Modified Files:
cl-xmpp-test.asd result-test.lisp
Added Files:
cl-xmpp-test.lisp
Log Message:
more tests and updated README slightly
Date: Sun Nov 13 03:55:47 2005
Author: eenge
Index: cl-xmpp/test/cl-xmpp-test.asd
diff -u cl-xmpp/test/cl-xmpp-test.asd:1.1 cl-xmpp/test/cl-xmpp-test.asd:1.2
--- cl-xmpp/test/cl-xmpp-test.asd:1.1 Sun Nov 13 03:36:11 2005
+++ cl-xmpp/test/cl-xmpp-test.asd Sun Nov 13 03:55:47 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp-test.asd,v 1.1 2005/11/13 02:36:11 eenge Exp $
+;;;; $Id: cl-xmpp-test.asd,v 1.2 2005/11/13 02:55:47 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/cl-xmpp-test.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -21,5 +21,7 @@
(:file "utility-test"
:depends-on ("package"))
(:file "result-test"
+ :depends-on ("package"))))
+ (:file "cl-xmpp-test"
:depends-on ("package"))))
Index: cl-xmpp/test/result-test.lisp
diff -u cl-xmpp/test/result-test.lisp:1.2 cl-xmpp/test/result-test.lisp:1.3
--- cl-xmpp/test/result-test.lisp:1.2 Sun Nov 13 03:45:41 2005
+++ cl-xmpp/test/result-test.lisp Sun Nov 13 03:55:47 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result-test.lisp,v 1.2 2005/11/13 02:45:41 eenge Exp $
+;;;; $Id: result-test.lisp,v 1.3 2005/11/13 02:55:47 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/result-test.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -14,4 +14,4 @@
(deftest get-element.1 (xmpp:get-element *empty-element* :x) nil)
(deftest get-element.2 (xmpp:get-element *element+subelement* :x) nil)
-(deftest get-element.3 (xmpp:get-element *element+subelement* :subtest) #.*sub-element*)
+(deftest get-element.3 (xmpp:name (xmpp:get-element *element+subelement* :subtest)) :subtest)
From eenge at common-lisp.net Mon Nov 14 14:26:48 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 14 Nov 2005 15:26:48 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-tls.asd
Message-ID: <20051114142648.54F6788574@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv22523
Modified Files:
cl-xmpp-tls.asd
Log Message:
loading correct file
Date: Mon Nov 14 15:26:47 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-tls.asd
diff -u cl-xmpp/cl-xmpp-tls.asd:1.3 cl-xmpp/cl-xmpp-tls.asd:1.4
--- cl-xmpp/cl-xmpp-tls.asd:1.3 Sun Nov 13 03:36:10 2005
+++ cl-xmpp/cl-xmpp-tls.asd Mon Nov 14 15:26:47 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp-tls.asd,v 1.3 2005/11/13 02:36:10 eenge Exp $
+;;;; $Id: cl-xmpp-tls.asd,v 1.4 2005/11/14 14:26:47 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -17,5 +17,5 @@
:licence "MIT"
:description "Common Lisp XMPP client implementation with TLS+SASL support"
:depends-on (:cl-xmpp-sasl :cl+ssl)
- :components ((:file "cl-xmpp-sasl")))
+ :components ((:file "cl-xmpp-tls")))
From eenge at common-lisp.net Mon Nov 14 15:14:10 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 14 Nov 2005 16:14:10 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-tls.lisp
cl-xmpp/cl-xmpp.lisp cl-xmpp/utility.lisp
Message-ID: <20051114151410.B691788545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv25792
Modified Files:
cl-xmpp-tls.lisp cl-xmpp.lisp utility.lisp
Log Message:
killing string-to-array and using ironclad:ascii-string-to-byte-array instead
Date: Mon Nov 14 16:14:08 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-tls.lisp
diff -u cl-xmpp/cl-xmpp-tls.lisp:1.3 cl-xmpp/cl-xmpp-tls.lisp:1.4
--- cl-xmpp/cl-xmpp-tls.lisp:1.3 Sat Nov 12 05:30:57 2005
+++ cl-xmpp/cl-xmpp-tls.lisp Mon Nov 14 16:14:06 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-tls.lisp,v 1.3 2005/11/12 04:30:57 eenge Exp $
+;;;; $Id: cl-xmpp-tls.lisp,v 1.4 2005/11/14 15:14:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -9,17 +9,24 @@
"Connect to the host and start a TLS stream."
(let ((connection (apply #'connect args)))
(send-starttls connection)
- (convert-to-tls-stream connection)
- connection))
+ (let ((reply (receive-stanza connection)))
+ (case (name reply)
+ (:proceed (convert-to-tls-stream connection)
+ (values connection :proceed reply))
+ (:failure (values connection :failure reply))
+ (t (error "Unexpected reply from TLS negotiation: ~a." reply))))))
(defmethod send-starttls ((connection connection))
"Sends a request to start a TLS stream with the server."
(with-xml-stream (stream connection)
(xml-output stream "")))
-(defmethod convert-to-tls-stream ((connection connection))
+(defmethod convert-to-tls-stream ((connection connection) &key (begin-xml-stream t))
"Convert the existing stream to a TLS stream and issue
-a stream:stream open tag to start the XML stream."
+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)))
- (begin-xml-stream connection))
+ (when begin-xml-stream
+ (begin-xml-stream connection)))
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.13 cl-xmpp/cl-xmpp.lisp:1.14
--- cl-xmpp/cl-xmpp.lisp:1.13 Sat Nov 12 05:20:21 2005
+++ cl-xmpp/cl-xmpp.lisp Mon Nov 14 16:14:06 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.13 2005/11/12 04:20:21 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.14 2005/11/14 15:14:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -316,7 +316,7 @@
(defun xml-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))))
+ (let ((sequence (ironclad:ascii-string-to-byte-array string)))
(write-sequence sequence stream)
(finish-output stream)
(when *debug-stream*
Index: cl-xmpp/utility.lisp
diff -u cl-xmpp/utility.lisp:1.7 cl-xmpp/utility.lisp:1.8
--- cl-xmpp/utility.lisp:1.7 Fri Nov 11 22:20:20 2005
+++ cl-xmpp/utility.lisp Mon Nov 14 16:14:07 2005
@@ -1,4 +1,4 @@
-;;;; $Id: utility.lisp,v 1.7 2005/11/11 21:20:20 eenge Exp $
+;;;; $Id: utility.lisp,v 1.8 2005/11/14 15:14:07 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -14,12 +14,6 @@
((typep (car list) 'atom) (cons (car list)
(flatten (cdr list))))
((typep (car list) 'list) (flatten (append (car list) (cdr list))))))
-
-(defun string-to-array (string &rest args)
- (let ((array (apply #'make-array (length string) args)))
- (dotimes (position (length string))
- (setf (aref array position) (char-code (aref string position))))
- array))
(defun digestify-string (string)
(ironclad:byte-array-to-hex-string
From eenge at common-lisp.net Mon Nov 14 15:14:15 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 14 Nov 2005 16:14:15 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/test/utility-test.lisp
Message-ID: <20051114151415.BE4FB88545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp/test
In directory common-lisp.net:/tmp/cvs-serv25792/test
Modified Files:
utility-test.lisp
Log Message:
killing string-to-array and using ironclad:ascii-string-to-byte-array instead
Date: Mon Nov 14 16:14:10 2005
Author: eenge
Index: cl-xmpp/test/utility-test.lisp
diff -u cl-xmpp/test/utility-test.lisp:1.1 cl-xmpp/test/utility-test.lisp:1.2
--- cl-xmpp/test/utility-test.lisp:1.1 Sun Nov 13 03:36:11 2005
+++ cl-xmpp/test/utility-test.lisp Mon Nov 14 16:14:10 2005
@@ -1,4 +1,4 @@
-;;;; $Id: utility-test.lisp,v 1.1 2005/11/13 02:36:11 eenge Exp $
+;;;; $Id: utility-test.lisp,v 1.2 2005/11/14 15:14:10 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/utility-test.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -7,8 +7,6 @@
(deftest flatten.1 (xmpp::flatten '(1 2 3)) (1 2 3))
(deftest flatten.2 (xmpp::flatten '(1 (2 3) 4)) (1 2 3 4))
-
-(deftest string-to-array.1 (xmpp::string-to-array "test") #(116 101 115 116))
(deftest digestify-string.1 (xmpp::digestify-string "test") "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3")
From eenge at common-lisp.net Mon Nov 14 16:08:42 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 14 Nov 2005 17:08:42 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp
Message-ID: <20051114160842.16F71880D6@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv30186
Modified Files:
cl-xmpp-sasl.lisp
Log Message:
TLS is now working
Date: Mon Nov 14 17:08:42 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-sasl.lisp
diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.6 cl-xmpp/cl-xmpp-sasl.lisp:1.7
--- cl-xmpp/cl-xmpp-sasl.lisp:1.6 Sat Nov 12 05:20:21 2005
+++ cl-xmpp/cl-xmpp-sasl.lisp Mon Nov 14 17:08:42 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-sasl.lisp,v 1.6 2005/11/12 04:20:21 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.lisp,v 1.7 2005/11/14 16:08:42 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -12,7 +12,12 @@
(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"))
+ (handle-challenge-response connection
+ username
+ (make-digest-password
+ (stream-id connection)
+ password)
+ "DIGEST-MD5"))
(add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%)
@@ -38,7 +43,8 @@
(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))
+ (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)))
@@ -46,7 +52,7 @@
(progn
(send-second-response connection)
(let ((final-reply (receive-stanza connection)))
- ; This should return either :success or :failure.
+ ; name should be either :success or :failure.
(values (name final-reply) final-reply)))
(values :failure second-challenge))))))
(values :failure initial-challenge)))))
@@ -67,4 +73,3 @@
(defmethod send-second-response ((connection connection))
(with-xml-stream (stream connection)
(xml-output stream "")))
-
From eenge at common-lisp.net Mon Nov 14 19:21:07 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 14 Nov 2005 20:21:07 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.asd
cl-xmpp/cl-xmpp-sasl.lisp cl-xmpp/cl-xmpp.lisp
Message-ID: <20051114192107.EB85B88545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv12512
Modified Files:
cl-xmpp-sasl.asd cl-xmpp-sasl.lisp cl-xmpp.lisp
Log Message:
cleaning up a little in the XML we output (removing newlines, etc.)
Date: Mon Nov 14 20:21:06 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-sasl.asd
diff -u cl-xmpp/cl-xmpp-sasl.asd:1.3 cl-xmpp/cl-xmpp-sasl.asd:1.4
--- cl-xmpp/cl-xmpp-sasl.asd:1.3 Sun Nov 13 03:36:10 2005
+++ cl-xmpp/cl-xmpp-sasl.asd Mon Nov 14 20:21:06 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp-sasl.asd,v 1.3 2005/11/13 02:36:10 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.asd,v 1.4 2005/11/14 19:21:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -16,6 +16,6 @@
:author "Erik Enge"
:licence "MIT"
:description "Common Lisp XMPP client implementation with SASL support"
- :depends-on (:cl-xmpp :cl-base64 :sasl)
+ :depends-on (:cl-xmpp :cl-base64 :cl-sasl)
:components ((:file "cl-xmpp-sasl")))
Index: cl-xmpp/cl-xmpp-sasl.lisp
diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.7 cl-xmpp/cl-xmpp-sasl.lisp:1.8
--- cl-xmpp/cl-xmpp-sasl.lisp:1.7 Mon Nov 14 17:08:42 2005
+++ cl-xmpp/cl-xmpp-sasl.lisp Mon Nov 14 20:21:06 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-sasl.lisp,v 1.7 2005/11/14 16:08:42 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.lisp,v 1.8 2005/11/14 19:21:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -59,11 +59,7 @@
(defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client)
(with-xml-stream (stream connection)
- (xml-output stream (fmt "~a"
- mechanism
- (base64:usb8-array-to-base64-string
- (sasl:client-step sasl-client nil))))))
+ (xml-output stream (fmt "" mechanism))))
(defmethod send-challenge-response ((connection connection) response)
(with-xml-stream (stream connection)
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.14 cl-xmpp/cl-xmpp.lisp:1.15
--- cl-xmpp/cl-xmpp.lisp:1.14 Mon Nov 14 16:14:06 2005
+++ cl-xmpp/cl-xmpp.lisp Mon Nov 14 20:21:06 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.14 2005/11/14 15:14:06 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.15 2005/11/14 19:21:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -331,11 +331,8 @@
"Begin XML stream. This should be the first thing to happen on a
newly connected connection."
(with-xml-stream (stream connection)
- (xml-output stream "")
- (xml-output stream (fmt "" (or (jid-domain-part connection) (hostname connection))))))
+ (xml-output stream "")
+ (xml-output stream (fmt "" (or (jid-domain-part connection) (hostname connection))))))
(defmethod end-xml-stream ((connection connection))
"Closes the XML stream. At this point you'd have to
From eenge at common-lisp.net Mon Nov 14 19:42:30 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 14 Nov 2005 20:42:30 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cxml.lisp cl-xmpp/utility.lisp
Message-ID: <20051114194230.7159E88545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv13651
Modified Files:
cxml.lisp utility.lisp
Log Message:
fixing character issues for lisps without 16 bit wide characters
Date: Mon Nov 14 20:42:29 2005
Author: eenge
Index: cl-xmpp/cxml.lisp
diff -u cl-xmpp/cxml.lisp:1.5 cl-xmpp/cxml.lisp:1.6
--- cl-xmpp/cxml.lisp:1.5 Sat Nov 12 05:20:21 2005
+++ cl-xmpp/cxml.lisp Mon Nov 14 20:42:29 2005
@@ -19,7 +19,7 @@
(defmethod sax:start-element ((handler stanza-handler) uri lname qname attrs)
(declare (ignore uri lname))
(when (eql (depth handler) 0)
- (if (string-equal "stream:stream" qname)
+ (if (eq :stream\:stream (ensure-keyword qname))
;; Create an element for DOM-TO-EVENT so we don't have to have
;; any specialized code just to handle stream:stream.
(let* ((document (dom:create-document))
Index: cl-xmpp/utility.lisp
diff -u cl-xmpp/utility.lisp:1.8 cl-xmpp/utility.lisp:1.9
--- cl-xmpp/utility.lisp:1.8 Mon Nov 14 16:14:07 2005
+++ cl-xmpp/utility.lisp Mon Nov 14 20:42:29 2005
@@ -1,4 +1,4 @@
-;;;; $Id: utility.lisp,v 1.8 2005/11/14 15:14:07 eenge Exp $
+;;;; $Id: utility.lisp,v 1.9 2005/11/14 19:42:29 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -41,3 +41,9 @@
(defun add-auth-method (name operator)
(push (list name operator) *auth-methods*))
+
+(defun ensure-keyword (thing)
+ (cond
+ ((typep thing 'string) (intern thing :keyword))
+ ((typep thing 'array) (ensure-keyword (map 'string #'code-char thing)))
+ (t (error "Don't know how to make keyword out of: ~a (type: ~a)" thing (type-of thing)))))
\ No newline at end of file
From eenge at common-lisp.net Mon Nov 14 20:07:37 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 14 Nov 2005 21:07:37 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/TODO cl-xmpp/cl-xmpp.lisp
cl-xmpp/result.lisp cl-xmpp/utility.lisp
Message-ID: <20051114200737.0CCF6880D6@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv15793
Modified Files:
TODO cl-xmpp.lisp result.lisp utility.lisp
Log Message:
all names on attributes and elements are now keywords (works better
in lisps without wide characters due to cxml representing things as
vectors)
Date: Mon Nov 14 21:07:36 2005
Author: eenge
Index: cl-xmpp/TODO
diff -u cl-xmpp/TODO:1.8 cl-xmpp/TODO:1.9
--- cl-xmpp/TODO:1.8 Sat Nov 12 21:53:17 2005
+++ cl-xmpp/TODO Mon Nov 14 21:07:36 2005
@@ -1,8 +1,5 @@
- respect stringprep/nodeprep - jid validator
-- 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
- create a connect-test which makes a "fake" connection but
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.15 cl-xmpp/cl-xmpp.lisp:1.16
--- cl-xmpp/cl-xmpp.lisp:1.15 Mon Nov 14 20:21:06 2005
+++ cl-xmpp/cl-xmpp.lisp Mon Nov 14 21:07:36 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.15 2005/11/14 19:21:06 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.16 2005/11/14 20:07:36 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -163,7 +163,7 @@
objects))
(defmethod parse-result ((connection connection) (attribute dom-impl::attribute))
- (let* ((name (dom:node-name attribute))
+ (let* ((name (ensure-keyword (dom:node-name attribute)))
(value (dom:value attribute))
(xml-attribute
(make-instance 'xml-attribute
@@ -171,14 +171,14 @@
xml-attribute))
(defmethod parse-result ((connection connection) (node dom-impl::character-data))
- (let* ((name (dom:node-name node))
+ (let* ((name (ensure-keyword (dom:node-name node)))
(data (dom:data node))
(xml-element (make-instance 'xml-element
:name name :data data :node node)))
xml-element))
(defmethod parse-result ((connection connection) (node dom-impl::node))
- (let* ((name (intern (string-upcase (dom:node-name node)) :keyword))
+ (let* ((name (ensure-keyword (dom:node-name node)))
(xml-element (make-instance 'xml-element :name name :node node)))
(dom:do-node-list (attribute (dom:attributes node))
(push (parse-result connection attribute) (attributes xml-element)))
@@ -188,8 +188,8 @@
(defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :iq)))
- (let ((id (intern (string-upcase (value (get-attribute object :id))) :keyword)))
- (if (not (string-equal (value (get-attribute object :type)) "result"))
+ (let ((id (ensure-keyword (value (get-attribute object :id)))))
+ (if (not (eq (ensure-keyword (value (get-attribute object :type))) :result))
(make-error (get-element object :error))
(case id
(:error (make-error (get-element object :error)))
@@ -233,8 +233,7 @@
(map 'list #'(lambda (x) (dom-to-event connection x)) objects))
(defmethod dom-to-event ((connection connection) (object xml-element))
- (xml-element-to-event
- connection object (intern (string-upcase (name object)) :keyword)))
+ (xml-element-to-event connection object (name object)))
;;; XXX: Is the ask attribute of the element part of the RFC/JEP?
(defmethod xml-element-to-event ((connection connection)
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.8 cl-xmpp/result.lisp:1.9
--- cl-xmpp/result.lisp:1.8 Sun Nov 13 03:55:46 2005
+++ cl-xmpp/result.lisp Mon Nov 14 21:07:36 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.8 2005/11/13 02:55:46 eenge Exp $
+;;;; $Id: result.lisp,v 1.9 2005/11/14 20:07:36 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -72,12 +72,12 @@
(length (elements object))
(length (data object)))))
-(defmethod get-attribute ((element xml-element) name &key (test 'string-equal))
+(defmethod get-attribute ((element xml-element) name &key (test 'eq))
(dolist (attribute (attributes element))
(when (funcall test name (name attribute))
(return-from get-attribute attribute))))
-(defmethod get-element ((element xml-element) name &key (test 'string-equal))
+(defmethod get-element ((element xml-element) name &key (test 'eq))
(dolist (subelement (elements element))
(when (funcall test name (name subelement))
(return-from get-element subelement))))
Index: cl-xmpp/utility.lisp
diff -u cl-xmpp/utility.lisp:1.9 cl-xmpp/utility.lisp:1.10
--- cl-xmpp/utility.lisp:1.9 Mon Nov 14 20:42:29 2005
+++ cl-xmpp/utility.lisp Mon Nov 14 21:07:36 2005
@@ -1,4 +1,4 @@
-;;;; $Id: utility.lisp,v 1.9 2005/11/14 19:42:29 eenge Exp $
+;;;; $Id: utility.lisp,v 1.10 2005/11/14 20:07:36 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -43,7 +43,13 @@
(push (list name operator) *auth-methods*))
(defun ensure-keyword (thing)
+ "Makes a keyword except when it gets nil it just returns nil."
(cond
- ((typep thing 'string) (intern thing :keyword))
+ ((typep thing 'string)
+ (let ((correct-case-thing (if (eq *print-case* :upcase)
+ (string-upcase thing)
+ (string-downcase thing))))
+ (intern correct-case-thing :keyword)))
((typep thing 'array) (ensure-keyword (map 'string #'code-char thing)))
+ ((eq thing nil) nil)
(t (error "Don't know how to make keyword out of: ~a (type: ~a)" thing (type-of thing)))))
From eenge at common-lisp.net Tue Nov 15 15:19:08 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Tue, 15 Nov 2005 16:19:08 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/result.lisp
Message-ID: <20051115151908.E452B880DB@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv4803
Modified Files:
result.lisp
Log Message:
now producing the same error instance for old-style and new-style error messages
Date: Tue Nov 15 16:19:08 2005
Author: eenge
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.9 cl-xmpp/result.lisp:1.10
--- cl-xmpp/result.lisp:1.9 Mon Nov 14 21:07:36 2005
+++ cl-xmpp/result.lisp Tue Nov 15 16:19:08 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.9 2005/11/14 20:07:36 eenge Exp $
+;;;; $Id: result.lisp,v 1.10 2005/11/15 15:19:08 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -296,9 +296,12 @@
(defclass xmpp-protocol-error-wait (xmpp-protocol-error) ())
(defclass xmpp-protocol-error-auth (xmpp-protocol-error) ())
-(defun get-error-data (name)
+(defun get-error-data-name (name)
(assoc name *errors*))
+(defun get-error-data-code (code)
+ (rassoc code *errors* :key #'second))
+
(defun map-error-type-to-class (type)
(case type
(modify (find-class 'xmpp-protocol-error-modify))
@@ -308,9 +311,22 @@
(t (find-class 'xmpp-protocol-error))))
(defmethod make-error ((object xml-element))
- (let* ((name (intern (string-upcase (name (car (elements object)))) :keyword))
- (data (get-error-data name))
- (type (second data))
- (code (third data))
- (class (map-error-type-to-class type)))
+ (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)))))
(make-instance class :code code :name name :xml-element object)))
From eenge at common-lisp.net Tue Nov 15 15:19:47 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Tue, 15 Nov 2005 16:19:47 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/Makefile
Message-ID: <20051115151947.6CCA8880DB@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv4821
Modified Files:
Makefile
Log Message:
adding clisp compiled files to make clean
Date: Tue Nov 15 16:19:46 2005
Author: eenge
Index: cl-xmpp/Makefile
diff -u cl-xmpp/Makefile:1.4 cl-xmpp/Makefile:1.5
--- cl-xmpp/Makefile:1.4 Sun Nov 13 03:45:41 2005
+++ cl-xmpp/Makefile Tue Nov 15 16:19:46 2005
@@ -5,4 +5,6 @@
-o -name "*.err" \
-o -name "*.x86f" \
-o -name "*.nfasl" \
+ -o -name "*.lib" \
+ -o -name "*.fas" \
| xargs rm
From eenge at common-lisp.net Wed Nov 16 19:06:13 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Wed, 16 Nov 2005 20:06:13 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-tls.lisp
Message-ID: <20051116190613.22BB6880D7@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv29777
Modified Files:
cl-xmpp-tls.lisp
Log Message:
fix for convert-to-tls-stream for lichteblau though currently it (the function)
is not working because something is blocking, somewhere
Date: Wed Nov 16 20:06:12 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-tls.lisp
diff -u cl-xmpp/cl-xmpp-tls.lisp:1.4 cl-xmpp/cl-xmpp-tls.lisp:1.5
--- cl-xmpp/cl-xmpp-tls.lisp:1.4 Mon Nov 14 16:14:06 2005
+++ cl-xmpp/cl-xmpp-tls.lisp Wed Nov 16 20:06:12 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-tls.lisp,v 1.4 2005/11/14 15:14:06 eenge Exp $
+;;;; $Id: cl-xmpp-tls.lisp,v 1.5 2005/11/16 19:06:12 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -28,5 +28,7 @@
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)))
From eenge at common-lisp.net Thu Nov 17 19:41:43 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Thu, 17 Nov 2005 20:41:43 +0100 (CET)
Subject: [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
Message-ID: <20051117194143.6F668880D5@common-lisp.net>
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 "" mechanism))))
+ (xml-output
+ stream
+ (fmt "" 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 "")))
-(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)))
From eenge at common-lisp.net Thu Nov 17 20:56:40 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Thu, 17 Nov 2005 21:56:40 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp
cl-xmpp/cl-xmpp-tls.lisp cl-xmpp/cl-xmpp.lisp cl-xmpp/package.lisp
Message-ID: <20051117205640.5200C880D5@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv13228
Modified Files:
cl-xmpp-sasl.lisp cl-xmpp-tls.lisp cl-xmpp.lisp package.lisp
Log Message:
sasl-digest-md5, sasl-plain, digest-md5 and plain all tested and known
to be working with google talk, jabberd and ejabberd
Date: Thu Nov 17 21:56:38 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-sasl.lisp
diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.9 cl-xmpp/cl-xmpp-sasl.lisp:1.10
--- cl-xmpp/cl-xmpp-sasl.lisp:1.9 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/cl-xmpp-sasl.lisp Thu Nov 17 21:56:38 2005
@@ -1,16 +1,27 @@
-;;;; $Id: cl-xmpp-sasl.lisp,v 1.9 2005/11/17 19:41:40 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.lisp,v 1.10 2005/11/17 20:56:38 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 this, I think.
+(defmethod %sasl-plain% ((connection connection) username password resource)
+ (let* ((mechanism "PLAIN")
+ (sasl-client (make-instance (sasl:get-mechanism mechanism)
+ :authentication-id username
+ :password password
+ :service "xmpp"
+ :host (hostname connection))))
+ (format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client))
+ (initiate-sasl-authentication connection mechanism sasl-client)
+ (receive-stanza connection)))
+
+(add-auth-method :sasl-plain '%sasl-plain%)
+
(defmethod %sasl-digest-md5% ((connection connection) username password resource)
(handle-challenge-response connection username password "DIGEST-MD5"))
-(eval-when (:execute :load-toplevel :compile-toplevel)
- (add-auth-method :sasl-digest-md5 #'%sasl-digest-md5%))
+(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
@@ -44,9 +55,7 @@
(if (eq (name second-challenge) :challenge)
(progn
(send-second-response connection)
- (let ((final-reply (receive-stanza connection)))
- ; name should be either :success or :failure.
- (values (name final-reply) final-reply)))
+ (receive-stanza connection))
(values :failure second-challenge))))))
(values :failure initial-challenge)))))
@@ -54,7 +63,11 @@
(with-xml-stream (stream connection)
(xml-output
stream
- (fmt "" mechanism))))
+ (if (string-equal mechanism "plain")
+ (fmt "~a"
+ mechanism
+ (base64:usb8-array-to-base64-string (sasl:client-step sasl-client nil)))
+ (fmt "" 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.6 cl-xmpp/cl-xmpp-tls.lisp:1.7
--- cl-xmpp/cl-xmpp-tls.lisp:1.6 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/cl-xmpp-tls.lisp Thu Nov 17 21:56:38 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-tls.lisp,v 1.6 2005/11/17 19:41:40 eenge Exp $
+;;;; $Id: cl-xmpp-tls.lisp,v 1.7 2005/11/17 20:56:38 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -7,23 +7,31 @@
(defun connect-tls (&rest args)
"Connect to the host and start a TLS stream."
- (let ((connection (apply #'connect args)))
- (send-starttls connection)
- (let ((reply (receive-stanza connection)))
- (case (name 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))))))
+ (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)))
+ (connect-tls2 (apply #'connect args)
+ :begin-xml-stream begin-xml-stream
+ :receive-stanzas receive-stanzas)))
+
+(defmethod connect-tls2 ((connection connection) &key
+ (receive-stanzas t)
+ (begin-xml-stream t))
+ "This one does all the work so if you need to use the
+regular CONNECT followed by something followed by converting
+your stream to TLS you could use this function."
+ (send-starttls connection)
+ (let ((reply (receive-stanza connection)))
+ (case (name reply)
+ (:proceed (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)))))
(defmethod send-starttls ((connection connection))
"Sends a request to start a TLS stream with the server."
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.17 cl-xmpp/cl-xmpp.lisp:1.18
--- cl-xmpp/cl-xmpp.lisp:1.17 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/cl-xmpp.lisp Thu Nov 17 21:56:38 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.17 2005/11/17 19:41:40 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.18 2005/11/17 20:56:38 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -201,6 +201,7 @@
(:unreg_1 :registration-cancellation-successful)
(:change1 :password-changed-succesfully)
(:auth2 :authentication-successful)
+ (:bind_2 :bind-successful)
(t (cond
((member id '(info1 info2 info3))
(make-disco-info (get-element object :query)))
@@ -228,6 +229,13 @@
(push element (features connection))))
object)
+;;; XXX: Not sure this is correct. Could perhaps get a success element
+;;; for other things than just authentication. I can't remember right
+;;; now but I should check.
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :success)))
+ :authentication-successful)
+
(defmethod xml-element-to-event ((connection connection) (object xml-element) name)
(declare (ignore name))
object)
@@ -418,10 +426,10 @@
(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))))
+ (cxml:with-element "resource" (cxml:text resource)))
+ (receive-stanza connection))
-(eval-when (:execute :load-toplevel :compile-toplevel)
- (add-auth-method :plain #'%plain-auth%))
+(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")
@@ -430,10 +438,10 @@
(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))))
+ (cxml:with-element "resource" (cxml:text resource)))
+ (receive-stanza connection))
-(eval-when (:execute :load-toplevel :compile-toplevel)
- (add-auth-method :digest-md5 #'%digest-md5-auth%))
+(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.9 cl-xmpp/package.lisp:1.10
--- cl-xmpp/package.lisp:1.9 Sun Nov 13 03:36:10 2005
+++ cl-xmpp/package.lisp Thu Nov 17 21:56:38 2005
@@ -1,4 +1,4 @@
-;;;; $Id: package.lisp,v 1.9 2005/11/13 02:36:10 eenge Exp $
+;;;; $Id: package.lisp,v 1.10 2005/11/17 20:56:38 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -18,7 +18,7 @@
: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
+ :connect-tls :connect-tls2
;; xmpp commands
:discover
:registration-requirements :register
From eenge at common-lisp.net Thu Nov 17 21:51:17 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Thu, 17 Nov 2005 22:51:17 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-sasl.lisp
cl-xmpp/cl-xmpp.lisp cl-xmpp/package.lisp cl-xmpp/result.lisp
Message-ID: <20051117215117.0A9C6880D5@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv17629
Modified Files:
cl-xmpp-sasl.lisp cl-xmpp.lisp package.lisp result.lisp
Log Message:
some reorganisation of the auth code, google talk still not there 100%
Date: Thu Nov 17 22:51:16 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-sasl.lisp
diff -u cl-xmpp/cl-xmpp-sasl.lisp:1.10 cl-xmpp/cl-xmpp-sasl.lisp:1.11
--- cl-xmpp/cl-xmpp-sasl.lisp:1.10 Thu Nov 17 21:56:38 2005
+++ cl-xmpp/cl-xmpp-sasl.lisp Thu Nov 17 22:51:15 2005
@@ -1,10 +1,19 @@
-;;;; $Id: cl-xmpp-sasl.lisp,v 1.10 2005/11/17 20:56:38 eenge Exp $
+;;;; $Id: cl-xmpp-sasl.lisp,v 1.11 2005/11/17 21:51:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-sasl.lisp,v $
;;;; See the LICENSE file for licensing information.
(in-package :xmpp)
+(defmethod if-successful-restart-stream ((connection connection) reply)
+ (if (eq reply :authentication-successful)
+ (progn
+ (begin-xml-stream connection :xml-identifier nil)
+ (receive-stanza connection) ; stream
+ (receive-stanza connection) ; features
+ reply)
+ reply))
+
(defmethod %sasl-plain% ((connection connection) username password resource)
(let* ((mechanism "PLAIN")
(sasl-client (make-instance (sasl:get-mechanism mechanism)
@@ -14,16 +23,19 @@
:host (hostname connection))))
(format *debug-stream* "~&SASL state: ~a~&" (sasl::state sasl-client))
(initiate-sasl-authentication connection mechanism sasl-client)
- (receive-stanza connection)))
+ (if-successful-restart-stream connection (receive-stanza connection))))
(add-auth-method :sasl-plain '%sasl-plain%)
(defmethod %sasl-digest-md5% ((connection connection) username password resource)
- (handle-challenge-response connection username password "DIGEST-MD5"))
+ (if-successful-restart-stream
+ connection
+ (handle-challenge-response connection username password resource "DIGEST-MD5")))
(add-auth-method :sasl-digest-md5 '%sasl-digest-md5%)
-(defmethod handle-challenge-response ((connection connection) username password mechanism)
+(defmethod handle-challenge-response ((connection connection) username password
+ resource 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
@@ -52,12 +64,13 @@
(force-output *debug-stream*)
(send-challenge-response connection base64-response)
(let ((second-challenge (receive-stanza connection)))
+ (format *debug-stream* "second-challenge: ~a~&" second-challenge)
(if (eq (name second-challenge) :challenge)
(progn
(send-second-response connection)
- (receive-stanza connection))
- (values :failure second-challenge))))))
- (values :failure initial-challenge)))))
+ (receive-stanza connection))
+ second-challenge)))))
+ initial-challenge))))
(defmethod initiate-sasl-authentication ((connection connection) mechanism sasl-client)
(with-xml-stream (stream connection)
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.18 cl-xmpp/cl-xmpp.lisp:1.19
--- cl-xmpp/cl-xmpp.lisp:1.18 Thu Nov 17 21:56:38 2005
+++ cl-xmpp/cl-xmpp.lisp Thu Nov 17 22:51:15 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.18 2005/11/17 20:56:38 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.19 2005/11/17 21:51:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -93,8 +93,8 @@
(when begin-xml-stream
(begin-xml-stream connection))
(when receive-stanzas
- (receive-stanza connection)
- (receive-stanza connection))
+ (receive-stanza connection) ; stream
+ (receive-stanza connection)) ; features
connection))
(defmethod connectedp ((connection connection))
@@ -337,11 +337,12 @@
;; Operators for communicating over the XML stream
;;
-(defmethod begin-xml-stream ((connection connection))
+(defmethod begin-xml-stream ((connection connection) &key (xml-identifier t))
"Begin XML stream. This should be the first thing to happen on a
newly connected connection."
(with-xml-stream (stream connection)
- (xml-output stream "")
+ (when xml-identifier
+ (xml-output stream ""))
(xml-output stream (fmt "" (or (jid-domain-part connection) (hostname connection))))))
(defmethod end-xml-stream ((connection connection))
@@ -418,9 +419,19 @@
(cxml:with-element "username" (cxml:text username))))
(defmethod auth ((connection connection) username password
- resource &optional (mechanism :plain))
+ resource &optional (mechanism :plain) (bind-et-al t))
+ "If bind-et-al is T this operator will bind, create a session and
+call presence on your behalf if the authentication was successful."
(setf (username connection) username)
- (funcall (get-auth-method mechanism) connection username password resource))
+ (let ((result (funcall (get-auth-method mechanism) connection username password resource)))
+ (if (and (eq result :authentication-successful)
+ bind-et-al)
+ (progn
+ (bind connection username resource)
+ (receive-stanza connection)
+ (session connection)
+ (receive-stanza connection))
+ result)))
(defmethod %plain-auth% ((connection connection) username password resource)
(with-iq-query (connection :id "auth2" :type "set" :xmlns "jabber:iq:auth")
@@ -467,6 +478,11 @@
(cxml:attribute "xmlns" "urn:ietf:params:xml:ns:xmpp-bind")
(cxml:with-element "resource"
(cxml:text resource)))))
+
+(defmethod session ((connection connection))
+ (with-iq (connection :id "session_1" :type "set")
+ (cxml:with-element "session"
+ (cxml:attribute "xmlns" "urn:ietf:params:xml:ns:xmpp-session"))))
;;
;; Subscription
Index: cl-xmpp/package.lisp
diff -u cl-xmpp/package.lisp:1.10 cl-xmpp/package.lisp:1.11
--- cl-xmpp/package.lisp:1.10 Thu Nov 17 21:56:38 2005
+++ cl-xmpp/package.lisp Thu Nov 17 22:51:16 2005
@@ -1,4 +1,4 @@
-;;;; $Id: package.lisp,v 1.10 2005/11/17 20:56:38 eenge Exp $
+;;;; $Id: package.lisp,v 1.11 2005/11/17 21:51:16 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -23,7 +23,7 @@
:discover
:registration-requirements :register
:auth-requirements :auth
- :presence :message :bind
+ :presence :message :bind :session
;; subscriptions
:request-subscription :approve-subscription
:deny/cancel-subscription :unsubscribe
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.11 cl-xmpp/result.lisp:1.12
--- cl-xmpp/result.lisp:1.11 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/result.lisp Thu Nov 17 22:51:16 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.11 2005/11/17 19:41:40 eenge Exp $
+;;;; $Id: result.lisp,v 1.12 2005/11/17 21:51:16 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -316,9 +316,25 @@
;;; XXX: Handle legacy errors
(defmethod make-error ((object xml-element))
- (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)))
+ (let ((code-value (value (get-attribute object :code)))
+ (code)
+ (name)
+ (type)
+ (class))
+ ; Slightly verbose but there are still cases I have not
+ ; addressed (and have no examples of, any more) so I'm going
+ ; to leave it like this for now.
+ (if code-value
+ (let* ((code-number (parse-integer code-value))
+ (data (get-error-data-code code-number)))
+ (setq code code-number)
+ (setq name (first data))
+ (setq type (second data))
+ (setq class (map-error-type-to-class type)))
+ (let* ((name (name (first (elements object))))
+ (data (get-error-data-name name)))
+ (format *debug-stream* "~&Name: ~a~&" name)
+ (setq code (first data))
+ (setq type (second data))
+ (setq class (map-error-type-to-class type))))
(make-instance class :code code :name name :xml-element object)))
From eenge at common-lisp.net Fri Nov 18 21:43:54 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 22:43:54 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/LICENSE cl-xmpp/TODO
cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/package.lisp
cl-xmpp/variable.lisp
Message-ID: <20051118214354.7AEE988554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv27903
Modified Files:
LICENSE TODO cl-xmpp.lisp cxml.lisp package.lisp variable.lisp
Log Message:
Date: Fri Nov 18 22:43:52 2005
Author: eenge
Index: cl-xmpp/LICENSE
diff -u cl-xmpp/LICENSE:1.1.1.1 cl-xmpp/LICENSE:1.2
--- cl-xmpp/LICENSE:1.1.1.1 Fri Oct 28 15:16:02 2005
+++ cl-xmpp/LICENSE Fri Nov 18 22:43:51 2005
@@ -1,23 +1,23 @@
Copyright (c) 2005 Erik Enge
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions
-are met:
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
-1. Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
-2. Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
-
-THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER EXPRESSED NOR
-IMPLIED WARRANTIES - THIS INCLUDES, BUT IS NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.IN
-NO WAY ARE THE AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; LOSS OF USE,
-DATA, OR PROFITS ; OR BUSINESS INTERRUPTION)
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
For further details contact the author of this software.
Index: cl-xmpp/TODO
diff -u cl-xmpp/TODO:1.10 cl-xmpp/TODO:1.11
--- cl-xmpp/TODO:1.10 Thu Nov 17 20:41:40 2005
+++ cl-xmpp/TODO Fri Nov 18 22:43:52 2005
@@ -7,3 +7,6 @@
- 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).
+
+- havent found a good use for IDs yet so right now they are
+ just what happen to be in the specs
\ No newline at end of file
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.19 cl-xmpp/cl-xmpp.lisp:1.20
--- cl-xmpp/cl-xmpp.lisp:1.19 Thu Nov 17 22:51:15 2005
+++ cl-xmpp/cl-xmpp.lisp Fri Nov 18 22:43:52 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.19 2005/11/17 21:51:15 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.20 2005/11/18 21:43:52 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -202,6 +202,7 @@
(:change1 :password-changed-succesfully)
(:auth2 :authentication-successful)
(:bind_2 :bind-successful)
+ (:session_1 :session-initiated)
(t (cond
((member id '(info1 info2 info3))
(make-disco-info (get-element object :query)))
@@ -328,7 +329,7 @@
"Write string to stream as a sequence of bytes and not characters."
(let ((sequence (ironclad:ascii-string-to-byte-array string)))
(write-sequence sequence stream)
- (finish-output stream)
+ (force-output stream)
(when *debug-stream*
(write-string string *debug-stream*)
(force-output *debug-stream*))))
@@ -356,26 +357,25 @@
"Macro to make it easier to write IQ stanzas."
(let ((stream (gensym)))
`(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)
- , at body))
- (force-output ,stream)
- ,connection)))
+ (prog1
+ (cxml:with-xml-output (make-octet+character-debug-stream-sink ,stream)
+ (cxml:with-element "iq"
+ (when ,id
+ (cxml:attribute "id" ,id))
+ (when ,to
+ (cxml:attribute "to" ,to))
+ (cxml:attribute "type" ,type)
+ , at body))
+ (force-output ,stream)))))
(defmacro with-iq-query ((connection &key xmlns id to node (type "get")) &body body)
"Macro to make it easier to write QUERYs."
- `(progn
- (with-iq (connection :id ,id :type ,type :to ,to)
- (cxml:with-element "query"
+ `(with-iq (connection :id ,id :type ,type :to ,to)
+ (cxml:with-element "query"
(cxml:attribute "xmlns" ,xmlns)
- (when ,node
- (cxml:attribute "node" ,node))
- , at body))
- ,connection))
+ (when ,node
+ (cxml:attribute "node" ,node))
+ , at body)))
;;
;; Discovery
@@ -418,8 +418,10 @@
(with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth")
(cxml:with-element "username" (cxml:text username))))
-(defmethod auth ((connection connection) username password
- resource &optional (mechanism :plain) (bind-et-al t))
+(defmethod auth ((connection connection) username password resource &key
+ (mechanism :plain)
+ (bind-et-al t)
+ (send-presence t))
"If bind-et-al is T this operator will bind, create a session and
call presence on your behalf if the authentication was successful."
(setf (username connection) username)
@@ -427,10 +429,14 @@
(if (and (eq result :authentication-successful)
bind-et-al)
(progn
- (bind connection username resource)
- (receive-stanza connection)
- (session connection)
- (receive-stanza connection))
+ (when (feature-p connection :bind)
+ (bind connection resource)
+ (receive-stanza connection))
+ (when (feature-p connection :session)
+ (session connection)
+ (receive-stanza connection))
+ (when send-presence
+ (presence connection)))
result)))
(defmethod %plain-auth% ((connection connection) username password resource)
@@ -472,7 +478,7 @@
(cxml:with-element "body" (cxml:text body))))
connection)
-(defmethod bind ((connection connection) jid resource)
+(defmethod bind ((connection connection) resource)
(with-iq (connection :id "bind_2" :type "set")
(cxml:with-element "bind"
(cxml:attribute "xmlns" "urn:ietf:params:xml:ns:xmpp-bind")
Index: cl-xmpp/cxml.lisp
diff -u cl-xmpp/cxml.lisp:1.6 cl-xmpp/cxml.lisp:1.7
--- cl-xmpp/cxml.lisp:1.6 Mon Nov 14 20:42:29 2005
+++ cl-xmpp/cxml.lisp Fri Nov 18 22:43:52 2005
@@ -75,21 +75,21 @@
;; 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)))
+(defclass octet+character-debug-stream-sink (cxml::octet-stream-sink) ())
(defun make-octet+character-debug-stream-sink (octet-stream &rest initargs)
- (apply #'make-instance 'octet+character-debug-stream-sink
- :target-stream octet-stream
- 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*)
- (force-output *debug-stream*)))
+ (write-byte octet (slot-value sink 'cxml::target-stream))
+ (when *debug-stream*
+ (write-char (code-char octet) *debug-stream*)
+ (force-output *debug-stream*)))
+
+;(defmethod write-octet-sequence (sequence (sink octet+character-debug-stream-sink))
+; (write-sequence sequence (slot-value sink 'cxml::target-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.11 cl-xmpp/package.lisp:1.12
--- cl-xmpp/package.lisp:1.11 Thu Nov 17 22:51:16 2005
+++ cl-xmpp/package.lisp Fri Nov 18 22:43:52 2005
@@ -1,4 +1,4 @@
-;;;; $Id: package.lisp,v 1.11 2005/11/17 21:51:16 eenge Exp $
+;;;; $Id: package.lisp,v 1.12 2005/11/18 21:43:52 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/package.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -17,6 +17,7 @@
: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
+ :server-stream
;; only available if you've loaded cl-xmpp-tls
:connect-tls :connect-tls2
;; xmpp commands
@@ -52,4 +53,4 @@
;; user-hooks for handling events
:handle
;; variables
- :*default-port :*default-hostname* :*errors*)))
+ :*default-port :*default-hostname* :*errors* :*debug-stream*)))
Index: cl-xmpp/variable.lisp
diff -u cl-xmpp/variable.lisp:1.4 cl-xmpp/variable.lisp:1.5
--- cl-xmpp/variable.lisp:1.4 Fri Nov 11 22:20:20 2005
+++ cl-xmpp/variable.lisp Fri Nov 18 22:43:52 2005
@@ -1,4 +1,4 @@
-;;;; $Id: variable.lisp,v 1.4 2005/11/11 21:20:20 eenge Exp $
+;;;; $Id: variable.lisp,v 1.5 2005/11/18 21:43:52 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/variable.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -12,7 +12,7 @@
(defvar *default-hostname* "localhost")
(defvar *errors*
- '((:bad-request :modiy 400)
+ '((:bad-request :modify 400)
(:conflict :cancel 409)
(:feature-not-implemented :cancel 501)
(:forbidden :auth 403)
From eenge at common-lisp.net Fri Nov 18 22:00:45 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:00:45 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051118220045.24DC388554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv29648
Modified Files:
index.html
Log Message:
preparing for 0.6.0
Date: Fri Nov 18 23:00:44 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.19 public_html/index.html:1.20
--- public_html/index.html:1.19 Sun Nov 13 03:55:15 2005
+++ public_html/index.html Fri Nov 18 23:00:44 2005
@@ -17,15 +17,18 @@
servers use to communicate with eachother (including
Google Talk). In addition
cl-xmpp implements JEPs 0078, 0086, 0030 and 0070 which are
-all part of JEP-0073: Basic IM Protocol Suite. The author considers the library feature complete but will happily accept patches for any other reasonably stable JEPs.
+all part of JEP-0073:
+Basic IM Protocol Suite. The author considers the library
+feature complete but will happily accept patches for any other
+reasonably stable JEPs.
Currently, you can chat, manage your contacts, roster
and presence information using this library. You can now also
use the service discovery protocol using the xmpp:discover operator.
The code is released under an MIT-style
- license.
+ href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cl-xmpp/LICENSE?rev=HEAD&cvsroot=cl-xmpp&content-type=text/vnd.viewcvs-markup">MIT-style license.
+
Requirements
News
- - Version 0.6.0 released (SASL and TLS support, better debugability + small test suite)
+
- Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)
- Version 0.5.0 released (Now depending on Ironclad for digest authentication)
- Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)
- Version 0.3.0 released (Added Allegro and LispWorks support)
@@ -96,19 +98,11 @@
* (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.
+ * (defvar *connection* (xmpp:connect :hostname "jabber.org"))
-;; 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)
- * (xmpp:presence connection)
+;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5
+;; if you loaded cl-xmpp-sasl.
;; send someone a message
* (xmpp:message connection "username at hostname" "what's going on?")
@@ -138,7 +132,8 @@
* (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message))
(xmpp:message connection (xmpp:from message)
(format nil "reply to: ~a" (xmpp:message object))))
-
+
+
From eenge at common-lisp.net Fri Nov 18 22:01:10 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:01:10 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/README
Message-ID: <20051118220110.78F0088554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv29817
Modified Files:
README
Log Message:
Date: Fri Nov 18 23:01:09 2005
Author: eenge
Index: cl-xmpp/README
diff -u cl-xmpp/README:1.8 cl-xmpp/README:1.9
--- cl-xmpp/README:1.8 Sun Nov 13 03:55:46 2005
+++ cl-xmpp/README Fri Nov 18 23:01:08 2005
@@ -5,19 +5,11 @@
* (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.
+ * (defvar *connection* (xmpp:connect :hostname "jabber.org"))
-;; 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)
- * (xmpp:presence connection)
+;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5
+;; if you loaded cl-xmpp-sasl.
;; send someone a message
* (xmpp:message connection "username at hostname" "what's going on?")
From eenge at common-lisp.net Fri Nov 18 22:03:24 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:03:24 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051118220324.1A1B4885A6@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv30172
Modified Files:
index.html
Log Message:
*** empty log message ***
Date: Fri Nov 18 23:03:24 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.20 public_html/index.html:1.21
--- public_html/index.html:1.20 Fri Nov 18 23:00:44 2005
+++ public_html/index.html Fri Nov 18 23:03:23 2005
@@ -37,8 +37,8 @@
trivial-sockets
cxml
Ironclad
- cl-base64 (if you are using cl-xmpp-sasl)
- cl-sasl (if you loaded cl-xmpp-sasl)
+ cl-base64 (for cl-xmpp-sasl)
+ cl-sasl (for cl-xmpp-sasl)
From eenge at common-lisp.net Fri Nov 18 22:10:03 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:10:03 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051118221003.E404D88554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv30271
Modified Files:
index.html
Log Message:
fixed a missing paren
Date: Fri Nov 18 23:10:03 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.21 public_html/index.html:1.22
--- public_html/index.html:1.21 Fri Nov 18 23:03:23 2005
+++ public_html/index.html Fri Nov 18 23:10:02 2005
@@ -89,7 +89,7 @@
From eenge at common-lisp.net Fri Nov 18 22:29:31 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:29:31 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.lisp cl-xmpp/utility.lisp
Message-ID: <20051118222931.4E7F988554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv31460
Modified Files:
cl-xmpp.lisp utility.lisp
Log Message:
tls now works (thanks david lichteblau!)
Date: Fri Nov 18 23:29:28 2005
Author: eenge
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.20 cl-xmpp/cl-xmpp.lisp:1.21
--- cl-xmpp/cl-xmpp.lisp:1.20 Fri Nov 18 22:43:52 2005
+++ cl-xmpp/cl-xmpp.lisp Fri Nov 18 23:29:27 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.20 2005/11/18 21:43:52 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.21 2005/11/18 22:29:27 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -355,17 +355,22 @@
(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 (gensym "stream"))
+ (xml (gensym "xml")))
`(let ((,stream (server-stream ,connection)))
(prog1
- (cxml:with-xml-output (make-octet+character-debug-stream-sink ,stream)
- (cxml:with-element "iq"
- (when ,id
- (cxml:attribute "id" ,id))
- (when ,to
- (cxml:attribute "to" ,to))
- (cxml:attribute "type" ,type)
- , at body))
+; (cxml:with-xml-output (make-octet+character-debug-stream-sink ,stream)
+ (let ((,xml (cxml:with-xml-output (cxml:make-octet-vector-sink)
+ (cxml:with-element "iq"
+ (when ,id
+ (cxml:attribute "id" ,id))
+ (when ,to
+ (cxml:attribute "to" ,to))
+ (cxml:attribute "type" ,type)
+ , at body))))
+ (write-sequence (vector-to-array ,xml) ,stream)
+ (when *debug-stream*
+ (write-sequence (map 'string #'code-char ,xml) *debug-stream*)))
(force-output ,stream)))))
(defmacro with-iq-query ((connection &key xmlns id to node (type "get")) &body body)
Index: cl-xmpp/utility.lisp
diff -u cl-xmpp/utility.lisp:1.10 cl-xmpp/utility.lisp:1.11
--- cl-xmpp/utility.lisp:1.10 Mon Nov 14 21:07:36 2005
+++ cl-xmpp/utility.lisp Fri Nov 18 23:29:27 2005
@@ -1,4 +1,4 @@
-;;;; $Id: utility.lisp,v 1.10 2005/11/14 20:07:36 eenge Exp $
+;;;; $Id: utility.lisp,v 1.11 2005/11/18 22:29:27 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -52,4 +52,10 @@
(intern correct-case-thing :keyword)))
((typep thing 'array) (ensure-keyword (map 'string #'code-char thing)))
((eq thing nil) nil)
- (t (error "Don't know how to make keyword out of: ~a (type: ~a)" thing (type-of thing)))))
\ No newline at end of file
+ (t (error "Don't know how to make keyword out of: ~a (type: ~a)" thing (type-of thing)))))
+
+(defun vector-to-array (vector)
+ (let ((array (make-array (length vector) :element-type '(unsigned-byte 8))))
+ (dotimes (position (length vector))
+ (setf (aref array position) (aref vector position)))
+ array))
\ No newline at end of file
From eenge at common-lisp.net Fri Nov 18 22:32:36 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:32:36 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051118223236.902E788554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv32519
Modified Files:
index.html
Log Message:
0.7.0
Date: Fri Nov 18 23:32:35 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.22 public_html/index.html:1.23
--- public_html/index.html:1.22 Fri Nov 18 23:10:02 2005
+++ public_html/index.html Fri Nov 18 23:32:35 2005
@@ -7,7 +7,7 @@
@@ -30,6 +30,19 @@
href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cl-xmpp/LICENSE?rev=HEAD&cvsroot=cl-xmpp&content-type=text/vnd.viewcvs-markup">MIT-style license.
+
News
+
+
+ - Version 0.7.0 released (TLS support)
+ - Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)
+ - Version 0.5.0 released (Now depending on Ironclad for digest authentication)
+ - Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)
+ - Version 0.3.0 released (Added Allegro and LispWorks support)
+ - Version 0.2.0 released (JEP 0073 support)
+ - Version 0.1.0 released (Initial release)
+
+
+
Requirements
-
News
+
Tested against
- - Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)
- - Version 0.5.0 released (Now depending on Ironclad for digest authentication)
- - Version 0.4.0 released (Better support for JEP0030 (service discovery) and more exported symbols)
- - Version 0.3.0 released (Added Allegro and LispWorks support)
- - Version 0.2.0 released (JEP 0073 support)
- - Version 0.1.0 released (Initial release)
+ - Google Talk
+ - Jabberd 1.4 (ie not 2)
+ - ejabberd
From eenge at common-lisp.net Fri Nov 18 22:35:27 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:35:27 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051118223527.209A788554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv32549
Modified Files:
index.html
Log Message:
0.7.0
Date: Fri Nov 18 23:35:26 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.23 public_html/index.html:1.24
--- public_html/index.html:1.23 Fri Nov 18 23:32:35 2005
+++ public_html/index.html Fri Nov 18 23:35:26 2005
@@ -50,8 +50,9 @@
trivial-sockets
cxml
Ironclad
-
cl-base64 (for cl-xmpp-sasl)
-
cl-sasl (for cl-xmpp-sasl)
+
cl-base64 (for cl-xmpp-{sasl,tls})
+
cl-sasl (for cl-xmpp-{sasl,tls})
+
cl+ssl (for cl-xmpp-tls)
@@ -109,10 +110,17 @@
* (require :cl-xmpp)
* (defvar *connection* (xmpp:connect :hostname "jabber.org"))
+;; or xmpp:connect-tls if you loaded cl-xmpp-tls
+
+;; note that for XMPP servers which do not have the same hostname
+;; as the domain-part of the user's JID you will have to pass that
+;; in. eg for Google Talk:
+;; (defvar *connection* (xmpp:connect-tls :hostname "talk.google.com"
+ :jid-domain-part "gmail.com"))
* (xmpp:auth connection "password" "resource")
;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5
-;; if you loaded cl-xmpp-sasl.
+;; if you loaded cl-xmpp-sasl or cl-xmpp-tls.
;; send someone a message
* (xmpp:message connection "username at hostname" "what's going on?")
From eenge at common-lisp.net Fri Nov 18 22:35:50 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:35:50 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/README
Message-ID: <20051118223550.7D56588554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv32567
Modified Files:
README
Log Message:
0.7.0
Date: Fri Nov 18 23:35:50 2005
Author: eenge
Index: cl-xmpp/README
diff -u cl-xmpp/README:1.9 cl-xmpp/README:1.10
--- cl-xmpp/README:1.9 Fri Nov 18 23:01:08 2005
+++ cl-xmpp/README Fri Nov 18 23:35:50 2005
@@ -6,10 +6,17 @@
* (require :cl-xmpp)
* (defvar *connection* (xmpp:connect :hostname "jabber.org"))
+;; or xmpp:connect-tls if you loaded cl-xmpp-tls
+
+;; note that for XMPP servers which do not have the same hostname
+;; as the domain-part of the user's JID you will have to pass that
+;; in. eg for Google Talk:
+;; (defvar *connection* (xmpp:connect-tls :hostname "talk.google.com"
+ :jid-domain-part "gmail.com"))
* (xmpp:auth connection "password" "resource")
;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5
-;; if you loaded cl-xmpp-sasl.
+;; if you loaded cl-xmpp-sasl or cl-xmpp-tls.
;; send someone a message
* (xmpp:message connection "username at hostname" "what's going on?")
From eenge at common-lisp.net Fri Nov 18 22:39:55 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:39:55 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051118223955.EACCD88554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv32616
Modified Files:
index.html
Log Message:
.com -> .org
Date: Fri Nov 18 23:39:55 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.24 public_html/index.html:1.25
--- public_html/index.html:1.24 Fri Nov 18 23:35:26 2005
+++ public_html/index.html Fri Nov 18 23:39:55 2005
@@ -60,7 +60,7 @@
From eenge at common-lisp.net Fri Nov 18 22:52:49 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:52:49 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cxml.lisp
Message-ID: <20051118225249.82D0C88554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv1252
Modified Files:
cxml.lisp
Log Message:
removing unneeded functions
Date: Fri Nov 18 23:52:48 2005
Author: eenge
Index: cl-xmpp/cxml.lisp
diff -u cl-xmpp/cxml.lisp:1.7 cl-xmpp/cxml.lisp:1.8
--- cl-xmpp/cxml.lisp:1.7 Fri Nov 18 22:43:52 2005
+++ cl-xmpp/cxml.lisp Fri Nov 18 23:52:48 2005
@@ -72,25 +72,6 @@
(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) ())
-
-(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 (slot-value sink 'cxml::target-stream))
- (when *debug-stream*
- (write-char (code-char octet) *debug-stream*)
- (force-output *debug-stream*)))
-
-;(defmethod write-octet-sequence (sequence (sink octet+character-debug-stream-sink))
-; (write-sequence sequence (slot-value sink 'cxml::target-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*
From eenge at common-lisp.net Fri Nov 18 22:53:03 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Fri, 18 Nov 2005 23:53:03 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.lisp
Message-ID: <20051118225303.1A31188554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv1275
Modified Files:
cl-xmpp.lisp
Log Message:
removing commented-out function call no longer needed
Date: Fri Nov 18 23:53:02 2005
Author: eenge
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.21 cl-xmpp/cl-xmpp.lisp:1.22
--- cl-xmpp/cl-xmpp.lisp:1.21 Fri Nov 18 23:29:27 2005
+++ cl-xmpp/cl-xmpp.lisp Fri Nov 18 23:53:02 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.21 2005/11/18 22:29:27 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.22 2005/11/18 22:53:02 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -359,7 +359,6 @@
(xml (gensym "xml")))
`(let ((,stream (server-stream ,connection)))
(prog1
-; (cxml:with-xml-output (make-octet+character-debug-stream-sink ,stream)
(let ((,xml (cxml:with-xml-output (cxml:make-octet-vector-sink)
(cxml:with-element "iq"
(when ,id
From eenge at common-lisp.net Fri Nov 18 23:14:37 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Sat, 19 Nov 2005 00:14:37 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cxml.lisp
Message-ID: <20051118231437.6EEA888554@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv2908
Modified Files:
cxml.lisp
Log Message:
fixing cvs tags
Date: Sat Nov 19 00:14:36 2005
Author: eenge
Index: cl-xmpp/cxml.lisp
diff -u cl-xmpp/cxml.lisp:1.8 cl-xmpp/cxml.lisp:1.9
--- cl-xmpp/cxml.lisp:1.8 Fri Nov 18 23:52:48 2005
+++ cl-xmpp/cxml.lisp Sat Nov 19 00:14:35 2005
@@ -1,7 +1,7 @@
-;;;; cxml-stanza.lisp -- parser helper for RFC 3920 XML streams
+;;;; $Id: cxml.lisp,v 1.9 2005/11/18 23:14:35 eenge Exp $
+;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cxml.lisp,v $
-;;; These are modifications to CXML which helps us deal with the
-;;; incremental-style parsing required for the XML stanzas.
+;;;; See the LICENSE file for licensing information.
(in-package :xmpp)
From eenge at common-lisp.net Mon Nov 21 18:58:05 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 21 Nov 2005 19:58:05 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/test/cl-xmpp-test.asd
Message-ID: <20051121185805.4A73288545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp/test
In directory common-lisp.net:/tmp/cvs-serv12420/test
Modified Files:
cl-xmpp-test.asd
Log Message:
making my own with-xml-output and fixing a few small bugs
Date: Mon Nov 21 19:58:04 2005
Author: eenge
Index: cl-xmpp/test/cl-xmpp-test.asd
diff -u cl-xmpp/test/cl-xmpp-test.asd:1.2 cl-xmpp/test/cl-xmpp-test.asd:1.3
--- cl-xmpp/test/cl-xmpp-test.asd:1.2 Sun Nov 13 03:55:47 2005
+++ cl-xmpp/test/cl-xmpp-test.asd Mon Nov 21 19:58:04 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp-test.asd,v 1.2 2005/11/13 02:55:47 eenge Exp $
+;;;; $Id: cl-xmpp-test.asd,v 1.3 2005/11/21 18:58:04 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/test/cl-xmpp-test.asd,v $
;;;; See the LICENSE file for licensing information.
@@ -21,7 +21,7 @@
(:file "utility-test"
:depends-on ("package"))
(:file "result-test"
- :depends-on ("package"))))
+ :depends-on ("package"))
(:file "cl-xmpp-test"
- :depends-on ("package"))))
+ :depends-on ("package"))))
From eenge at common-lisp.net Mon Nov 21 18:58:05 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 21 Nov 2005 19:58:05 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.lisp
Message-ID: <20051121185805.A666688556@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv12420
Modified Files:
cl-xmpp.lisp
Log Message:
making my own with-xml-output and fixing a few small bugs
Date: Mon Nov 21 19:58:03 2005
Author: eenge
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.22 cl-xmpp/cl-xmpp.lisp:1.23
--- cl-xmpp/cl-xmpp.lisp:1.22 Fri Nov 18 23:53:02 2005
+++ cl-xmpp/cl-xmpp.lisp Mon Nov 21 19:58:03 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.22 2005/11/18 22:53:02 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.23 2005/11/21 18:58:03 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -353,24 +353,28 @@
(with-xml-stream (stream connection)
(xml-output stream "")))
-(defmacro with-iq ((connection &key id to (type "get")) &body body)
- "Macro to make it easier to write IQ stanzas."
- (let ((stream (gensym "stream"))
- (xml (gensym "xml")))
+(defmacro with-xml-output ((connection) &body body)
+ (let ((xml (gensym "xml"))
+ (stream (gensym "stream")))
`(let ((,stream (server-stream ,connection)))
(prog1
(let ((,xml (cxml:with-xml-output (cxml:make-octet-vector-sink)
- (cxml:with-element "iq"
- (when ,id
- (cxml:attribute "id" ,id))
- (when ,to
- (cxml:attribute "to" ,to))
- (cxml:attribute "type" ,type)
- , at body))))
+ , at body)))
(write-sequence (vector-to-array ,xml) ,stream)
- (when *debug-stream*
- (write-sequence (map 'string #'code-char ,xml) *debug-stream*)))
- (force-output ,stream)))))
+ (when *debug-stream*
+ (write-sequence (map 'string #'code-char ,xml) *debug-stream*)))
+ (force-output ,stream)))))
+
+(defmacro with-iq ((connection &key id to (type "get")) &body body)
+ "Macro to make it easier to write IQ stanzas."
+ `(with-xml-output (,connection)
+ (cxml:with-element "iq"
+ (when ,id
+ (cxml:attribute "id" ,id))
+ (when ,to
+ (cxml:attribute "to" ,to))
+ (cxml:attribute "type" ,type)
+ , at body)))
(defmacro with-iq-query ((connection &key xmlns id to node (type "get")) &body body)
"Macro to make it easier to write QUERYs."
@@ -465,22 +469,18 @@
(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
- (server-stream connection))
+ (with-xml-output (connection)
(cxml:with-element "presence"
(when type
(cxml:attribute "type" type))
(when to
- (cxml:attribute "to" to))))
- connection)
+ (cxml:attribute "to" to)))))
(defmethod message ((connection connection) to body)
- (cxml:with-xml-output (make-octet+character-debug-stream-sink
- (server-stream connection))
+ (with-xml-output (connection)
(cxml:with-element "message"
(cxml:attribute "to" to)
- (cxml:with-element "body" (cxml:text body))))
- connection)
+ (cxml:with-element "body" (cxml:text body)))))
(defmethod bind ((connection connection) resource)
(with-iq (connection :id "bind_2" :type "set")
From eenge at common-lisp.net Mon Nov 21 19:00:35 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 21 Nov 2005 20:00:35 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051121190035.2FE4F88545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv12992
Modified Files:
index.html
Log Message:
0.7.1
Date: Mon Nov 21 20:00:34 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.25 public_html/index.html:1.26
--- public_html/index.html:1.25 Fri Nov 18 23:39:55 2005
+++ public_html/index.html Mon Nov 21 20:00:34 2005
@@ -7,7 +7,7 @@
@@ -33,6 +33,7 @@
News
+ - Version 0.7.1 released (Bugfixes)
- Version 0.7.0 released (TLS support)
- Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)
- Version 0.5.0 released (Now depending on Ironclad for digest authentication)
From eenge at common-lisp.net Mon Nov 21 19:01:17 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 21 Nov 2005 20:01:17 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: public_html/index.html
Message-ID: <20051121190117.8EF6988545@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/public_html
In directory common-lisp.net:/tmp/cvs-serv13483
Modified Files:
index.html
Log Message:
0.7.1
Date: Mon Nov 21 20:01:16 2005
Author: eenge
Index: public_html/index.html
diff -u public_html/index.html:1.26 public_html/index.html:1.27
--- public_html/index.html:1.26 Mon Nov 21 20:00:34 2005
+++ public_html/index.html Mon Nov 21 20:01:16 2005
@@ -33,7 +33,7 @@
News
- - Version 0.7.1 released (Bugfixes)
+ - 2005-11-21: Version 0.7.1 released (Bugfixes)
- Version 0.7.0 released (TLS support)
- Version 0.6.0 released (SASL support, tiny test suite and many small fixes and tweaks)
- Version 0.5.0 released (Now depending on Ironclad for digest authentication)
From eenge at common-lisp.net Mon Nov 28 15:15:05 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 28 Nov 2005 16:15:05 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/README
Message-ID: <20051128151505.48FCE880D7@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv3006
Modified Files:
README
Log Message:
patch from david lichteblau
Date: Mon Nov 28 16:15:03 2005
Author: eenge
Index: cl-xmpp/README
diff -u cl-xmpp/README:1.10 cl-xmpp/README:1.11
--- cl-xmpp/README:1.10 Fri Nov 18 23:35:50 2005
+++ cl-xmpp/README Mon Nov 28 16:15:03 2005
@@ -14,7 +14,7 @@
;; (defvar *connection* (xmpp:connect-tls :hostname "talk.google.com"
:jid-domain-part "gmail.com"))
- * (xmpp:auth connection "password" "resource")
+ * (xmpp:auth connection "username" "password" "resource")
;; or pass :mechanism :sasl-plain, :digest-md5 or sasl-digest-md5
;; if you loaded cl-xmpp-sasl or cl-xmpp-tls.
From eenge at common-lisp.net Mon Nov 28 15:15:48 2005
From: eenge at common-lisp.net (Erik Enge)
Date: Mon, 28 Nov 2005 16:15:48 +0100 (CET)
Subject: [cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp-tls.lisp
Message-ID: <20051128151548.7D3F1880D7@common-lisp.net>
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv3568
Modified Files:
cl-xmpp-tls.lisp
Log Message:
patch from david lichteblau
Date: Mon Nov 28 16:15:46 2005
Author: eenge
Index: cl-xmpp/cl-xmpp-tls.lisp
diff -u cl-xmpp/cl-xmpp-tls.lisp:1.7 cl-xmpp/cl-xmpp-tls.lisp:1.8
--- cl-xmpp/cl-xmpp-tls.lisp:1.7 Thu Nov 17 21:56:38 2005
+++ cl-xmpp/cl-xmpp-tls.lisp Mon Nov 28 16:15:46 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp-tls.lisp,v 1.7 2005/11/17 20:56:38 eenge Exp $
+;;;; $Id: cl-xmpp-tls.lisp,v 1.8 2005/11/28 15:15:46 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp-tls.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -46,7 +46,8 @@
Turn off sending XML stream start with :begin-xml-stream nil."
(setf (server-stream connection)
- (cl+ssl:make-ssl-client-stream (server-stream connection)))
+ (cl+ssl:make-ssl-client-stream (server-stream connection)
+ :external-format :iso-8859-1))
(setf (server-xstream connection) nil)
(when begin-xml-stream
(begin-xml-stream connection))