[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.asd cl-xmpp/cl-xmpp.lisp cl-xmpp/result.lisp cl-xmpp/utility.lisp
Erik Enge
eenge at common-lisp.net
Mon Oct 31 21:07:16 UTC 2005
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv15203
Modified Files:
cl-xmpp.asd cl-xmpp.lisp result.lisp utility.lisp
Log Message:
now depending on ironclad for sha1 generation of digest password
Date: Mon Oct 31 22:07:15 2005
Author: eenge
Index: cl-xmpp/cl-xmpp.asd
diff -u cl-xmpp/cl-xmpp.asd:1.3 cl-xmpp/cl-xmpp.asd:1.4
--- cl-xmpp/cl-xmpp.asd:1.3 Fri Oct 28 23:04:12 2005
+++ cl-xmpp/cl-xmpp.asd Mon Oct 31 22:07:14 2005
@@ -1,5 +1,5 @@
;;;; -*- mode: lisp -*-
-;;;; $Id: cl-xmpp.asd,v 1.3 2005/10/28 21:04:12 eenge Exp $
+;;;; $Id: cl-xmpp.asd,v 1.4 2005/10/31 21:07:14 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)
+ :depends-on (#+sbcl :sb-bsd-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.6 cl-xmpp/cl-xmpp.lisp:1.7
--- cl-xmpp/cl-xmpp.lisp:1.6 Mon Oct 31 18:02:04 2005
+++ cl-xmpp/cl-xmpp.lisp Mon Oct 31 22:07:15 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -17,6 +17,12 @@
(server-xstream
:accessor server-xstream
:initform nil)
+ (stream-id
+ :accessor stream-id
+ :initarg :stream-id
+ :initform nil
+ :documentation "Stream ID attribute of the <stream>
+element as gotten when we call BEGIN-XML-STREAM.")
(hostname
:accessor hostname
:initarg :hostname
@@ -92,17 +98,137 @@
#+(or allegro lispworks) (close (socket connection))
connection)
+;;
+;; Handle
+;;
+
+(defmethod handle ((connection connection) (list list))
+ (dolist (object list)
+ (handle connection object)))
+
+(defmethod handle ((connection connection) object)
+ (format t "~&Received: ~a~%" 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)))
+
+(defmethod parse-result ((connection connection) (document dom-impl::document))
+ (let (objects)
+ (dom:map-node-list #'(lambda (node)
+ (push (parse-result connection node) objects))
+ (dom:child-nodes document))
+ objects))
+
+(defmethod parse-result ((connection connection) (attribute dom-impl::attribute))
+ (let* ((name (dom:node-name attribute))
+ (value (dom:value attribute))
+ (xml-attribute
+ (make-instance 'xml-attribute
+ :name name :value value :node attribute)))
+ xml-attribute))
+
+(defmethod parse-result ((connection connection) (node dom-impl::character-data))
+ (let* ((name (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))
+ (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)))
+ (dom:do-node-list (child (dom:child-nodes node))
+ (push (parse-result connection child) (elements xml-element)))
+ xml-element))
+
+
+(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"))
+ (make-error (get-element object :error))
+ (case id
+ (:error (make-error (get-element object :error)))
+ (:roster_1 (make-roster object))
+ (:reg2 :registration-successful)
+ (:unreg_1 :registration-cancellation-successful)
+ (:change1 :password-changed-succesfully)
+ (:auth2 :authentication-successful)
+ (t (cond
+ ((member id '(info1 info2 info3))
+ (make-disco-info (get-element object :query)))
+ ((member id '(items1 items2 items3 items4))
+ (make-disco-items (get-element object :query)))))))))
+
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :error)))
+ (make-error object))
+
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :stream\:error)))
+ (make-error object))
+
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :stream\:stream)))
+ (setf (stream-id connection) (value (get-attribute object :id)))
+ 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))
+
+(defmethod dom-to-event ((connection connection) (object xml-element))
+ (xml-element-to-event
+ connection object (intern (string-upcase (name object)) :keyword)))
+
+;;; XXX: Is the ask attribute of the <presence/> element part of the RFC/JEP?
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :presence)))
+ (let ((show (get-element object :show)))
+ (when show
+ (setq show (data (get-element show :\#text))))
+ (make-instance 'presence
+ :xml-element object
+ :from (value (get-attribute object :from))
+ :to (value (get-attribute object :to))
+ :show show
+ :type- (value (get-attribute object :type)))))
+
+;;; XXX: Add support for the <thread/> element. Also note that
+;;; there may be an XHTML version of the body available in the
+;;; original node but as of right now I don't care about it. If
+;;; you do please feel free to submit a patch.
+(defmethod xml-element-to-event ((connection connection)
+ (object xml-element) (name (eql :message)))
+ (make-instance 'message
+ :xml-element object
+ :from (value (get-attribute object :from))
+ :to (value (get-attribute object :to))
+ :body (data (get-element (get-element object :body) :\#text))))
+
+;;
+;; Receive stanzas
+;;
+
(defmethod receive-stanza-loop ((connection connection) &key
(stanza-callback 'default-stanza-callback)
- (init-callback 'default-init-callback)
dom-repr)
(loop
(let* ((stanza (read-stanza connection))
(tagname (dom:tag-name (dom:document-element stanza))))
(cond
- ((equal tagname "stream:stream")
- (when init-callback
- (funcall init-callback stanza connection :dom-repr dom-repr)))
((equal tagname "stream:error")
(when stanza-callback
(funcall stanza-callback stanza connection :dom-repr dom-repr))
@@ -221,11 +347,17 @@
(with-iq-query (connection :id "auth1" :xmlns "jabber:iq:auth")
(cxml:with-element "username" (cxml:text username))))
-;;; XXX: Add support for digest authentication.
-(defmethod auth ((connection connection) username password resource)
+(defmethod auth ((connection connection) username password resource &key digestp)
(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))
+ (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)))
(cxml:with-element "resource" (cxml:text resource))))
(defmethod presence ((connection connection) &key type to)
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.6 cl-xmpp/result.lisp:1.7
--- cl-xmpp/result.lisp:1.6 Mon Oct 31 18:02:04 2005
+++ cl-xmpp/result.lisp Mon Oct 31 22:07:15 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $
+;;;; $Id: result.lisp,v 1.7 2005/10/31 21:07:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -106,44 +106,6 @@
(format stream "~a=~a" (name object) (value object))))
;;
-;; Produce DOM-ish structure from the XML DOM returned by cxml.
-;;
-
-(defmethod parse-result ((objects list))
- (mapcar #'parse-result objects))
-
-(defmethod parse-result ((document dom-impl::document))
- (let (objects)
- (dom:map-node-list #'(lambda (node)
- (push (parse-result node) objects))
- (dom:child-nodes document))
- objects))
-
-(defmethod parse-result ((attribute dom-impl::attribute))
- (let* ((name (dom:node-name attribute))
- (value (dom:value attribute))
- (xml-attribute
- (make-instance 'xml-attribute
- :name name :value value :node attribute)))
- xml-attribute))
-
-(defmethod parse-result ((node dom-impl::character-data))
- (let* ((name (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 ((node dom-impl::node))
- (let* ((name (intern (string-upcase (dom:node-name node)) :keyword))
- (xml-element (make-instance 'xml-element :name name :node node)))
- (dom:do-node-list (attribute (dom:attributes node))
- (push (parse-result attribute) (attributes xml-element)))
- (dom:do-node-list (child (dom:child-nodes node))
- (push (parse-result child) (elements xml-element)))
- xml-element))
-
-;;
;; Event interface
;;
@@ -172,17 +134,6 @@
(print-unreadable-object (object stream :type t :identity t)
(format stream "to:~a from:~a" (to object) (from object))))
-;;; XXX: Add support for the <thread/> element. Also note that
-;;; there may be an XHTML version of the body available in the
-;;; original node but as of right now I don't care about it. If
-;;; you do please feel free to submit a patch.
-(defmethod xml-element-to-event ((object xml-element) (name (eql :message)))
- (make-instance 'message
- :xml-element object
- :from (value (get-attribute object :from))
- :to (value (get-attribute object :to))
- :body (data (get-element (get-element object :body) :\#text))))
-
(defclass presence (event)
((to
:accessor to
@@ -206,18 +157,6 @@
(print-unreadable-object (object stream :type t :identity t)
(format stream "from:~a show:~a" (from object) (show object))))
-;;; XXX: Is the ask attribute of the <presence/> element part of the RFC/JEP?
-(defmethod xml-element-to-event ((object xml-element) (name (eql :presence)))
- (let ((show (get-element object :show)))
- (when show
- (setq show (data (get-element show :\#text))))
- (make-instance 'presence
- :xml-element object
- :from (value (get-attribute object :from))
- :to (value (get-attribute object :to))
- :show show
- :type- (value (get-attribute object :type)))))
-
(defclass contact ()
((jid
:accessor jid
@@ -349,6 +288,11 @@
:accessor name
:initarg :name)))
+(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))))
+
(defclass xmpp-protocol-error-modify (xmpp-protocol-error) ())
(defclass xmpp-protocol-error-cancel (xmpp-protocol-error) ())
(defclass xmpp-protocol-error-wait (xmpp-protocol-error) ())
@@ -372,48 +316,3 @@
(code (third data))
(class (map-error-type-to-class type)))
(make-instance class :code code :name name :xml-element object)))
-
-(defmethod xml-element-to-event ((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"))
- (make-error (get-element object :error))
- (case id
- (:error (make-error (get-element object :error)))
- (:roster_1 (make-roster object))
- (:reg2 :registration-successful)
- (:unreg_1 :registration-cancellation-successful)
- (:change1 :password-changed-succesfully)
- (:auth2 :authentication-successful)
- (t (cond
- ((member id '(info1 info2 info3))
- (make-disco-info (get-element object :query)))
- ((member id '(items1 items2 items3 items4))
- (make-disco-items (get-element object :query)))))))))
-
-(defmethod xml-element-to-event ((object xml-element) (name (eql :error)))
- (make-error object))
-
-(defmethod xml-element-to-event ((object xml-element) (name (eql :stream\:error)))
- (make-error object))
-
-(defmethod xml-element-to-event ((object xml-element) name)
- (declare (ignore name))
- object)
-
-(defmethod dom-to-event ((object list))
- (mapcar #'dom-to-event object))
-
-(defmethod dom-to-event ((object xml-element))
- (xml-element-to-event
- object (intern (string-upcase (name object)) :keyword)))
-
-;;
-;; Handle
-;;
-
-(defmethod handle ((connection connection) (object list))
- (dolist (object list)
- (handle connection object)))
-
-(defmethod handle ((connection connection) object)
- (format t "~&Received: ~a~%" object))
Index: cl-xmpp/utility.lisp
diff -u cl-xmpp/utility.lisp:1.4 cl-xmpp/utility.lisp:1.5
--- cl-xmpp/utility.lisp:1.4 Mon Oct 31 18:02:04 2005
+++ cl-xmpp/utility.lisp Mon Oct 31 22:07:15 2005
@@ -1,10 +1,13 @@
-;;;; $Id: utility.lisp,v 1.4 2005/10/31 17:02:04 eenge Exp $
+;;;; $Id: utility.lisp,v 1.5 2005/10/31 21:07:15 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $
;;;; See the LICENSE file for licensing information.
(in-package :xmpp)
+(defmacro fmt (string &rest args)
+ `(format nil ,string , at args))
+
(defun flatten (list)
(cond
((typep list 'atom) list)
@@ -12,25 +15,40 @@
(flatten (cdr list))))
((typep (car list) 'list) (flatten (append (car list) (cdr list))))))
-(defun string-to-array (string)
- (let ((array (make-array (length string))))
+(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 default-stanza-callback (stanza connection &key dom-repr)
- (let ((result (parse-result stanza)))
- (if dom-repr
- (handle connection result)
- (handle connection (dom-to-event result)))))
+(defun hex-array-to-ascii-string (array)
+ (let ((string (make-string 0)))
+ (dotimes (position (length array))
+ (let ((element (aref array position))
+ (*print-base* 16))
+ (setq string (fmt "~a~a" string element)))) ; probably inefficient
+ string))
+
+;;; borrowed from ironclad, so Copyright (C) 2004 Nathan Froyd
+(defun ascii-string-to-byte-array (string)
+ (let ((vec (make-array (length string) :element-type '(unsigned-byte 8))))
+ (dotimes (i (length string) vec)
+ (let ((byte (char-code (char string i))))
+ (assert (< byte 256))
+ (setf (aref vec i) byte)))))
+
+(defun digestify-string (string)
+ (hex-array-to-ascii-string
+ (ironclad:digest-sequence
+ :sha1 (ascii-string-to-byte-array string))))
+
+(defun make-digest-password (stream-id password)
+ (string-downcase (digestify-string (fmt "~a~a" stream-id password))))
-;; um, refactor?
-(defun default-init-callback (stanza connection &key dom-repr)
- (let ((result (parse-result stanza)))
+(defun default-stanza-callback (stanza connection &key dom-repr)
+ (let ((result (parse-result connection stanza)))
(if dom-repr
(handle connection result)
- (handle connection (dom-to-event result)))))
+ (handle connection (dom-to-event connection result)))))
-(defmacro fmt (string &rest args)
- `(format nil ,string , at args))
More information about the Cl-xmpp-cvs
mailing list