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 ,@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 ,@args))