[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
Erik Enge
eenge at common-lisp.net
Fri Nov 11 17:22:13 UTC 2005
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 <stream>
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 "<stream:stream to='~a'
xmlns='jabber:client'
xmlns:stream='http://etherx.jabber.org/streams'
-version='1.0'>" (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 "</stream:stream>")))
+ (xml-output stream "</stream: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)))
More information about the Cl-xmpp-cvs
mailing list