Menu
▾
▴
[SCM] emacs-jabber branch, rtt, updated. ebce8529c30fb554b3d0df830319653445accbc8
|
From: Magnus H. <leg...@us...> - 2013-11-26 20:13:31
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "emacs-jabber".
The branch, rtt has been updated
via ebce8529c30fb554b3d0df830319653445accbc8 (commit)
via 71d66edb4cedba59e98fcc43d0f1879eedac0e70 (commit)
via cf89a44b68736638763d877aef5b067adbee2986 (commit)
via b0e517f27086b27ffb522549e36b5a536ac063ff (commit)
via 3fc929628606d988e5a41cac9d5941c87a23ae26 (commit)
from 0b40a35043e7f6fb256411c2b9287b820c6d7ec1 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ebce8529c30fb554b3d0df830319653445accbc8
Author: Magnus Henoch <mag...@gm...>
Date: Tue Nov 26 20:09:48 2013 +0000
Add jabber-rtt to Makefile.am
diff --git a/Makefile.am b/Makefile.am
index fc57b22..ce47ac7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -13,7 +13,7 @@ jabber-export.el jabber-feature-neg.el jabber-festival.el \
jabber-ft-client.el jabber-ft-common.el jabber-ft-server.el \
jabber-gmail.el jabber-history.el jabber-iq.el jabber-keepalive.el \
jabber-keymap.el jabber-logon.el jabber-menu.el jabber-modeline.el \
-jabber-muc-nick-completion.el jabber-muc.el \
+jabber-muc-nick-completion.el jabber-muc.el jabber-rtt.el \
jabber-osd.el jabber-presence.el jabber-private.el jabber-ratpoison.el \
jabber-register.el jabber-roster.el jabber-sasl.el jabber-sawfish.el \
jabber-screen.el jabber-search.el jabber-si-client.el \
commit 71d66edb4cedba59e98fcc43d0f1879eedac0e70
Author: Magnus Henoch <mag...@gm...>
Date: Tue Nov 26 20:07:56 2013 +0000
Advertise RTT feature
diff --git a/jabber-rtt.el b/jabber-rtt.el
index 65d5272..520ca11 100644
--- a/jabber-rtt.el
+++ b/jabber-rtt.el
@@ -25,6 +25,10 @@
;;;; Handling incoming events
+;;;###autoload
+(eval-after-load "jabber-disco"
+ '(jabber-disco-advertise-feature "urn:xmpp:rtt:0"))
+
(defvar jabber-rtt-ewoc-node nil)
(make-variable-buffer-local 'jabber-rtt-ewoc-node)
commit cf89a44b68736638763d877aef5b067adbee2986
Author: Magnus Henoch <mag...@gm...>
Date: Tue Nov 26 01:18:06 2013 +0000
Send Entity Capabilities in outgoing presence stanzas
Also changed the disco info feature "plugin" system - now a module that
wants to advertise a feature needs to call the function
`jabber-disco-advertise-feature'. This ensures that caps are
recalculated as needed.
diff --git a/jabber-ahc.el b/jabber-ahc.el
index e201b7d..605c0f8 100644
--- a/jabber-ahc.el
+++ b/jabber-ahc.el
@@ -75,7 +75,7 @@ access allowed. nil means open for everyone."
(feature ((var . "http://jabber.org/protocol/disco#info")))
(feature ((var . "jabber:x:data")))))))
-(add-to-list 'jabber-advertised-features "http://jabber.org/protocol/commands")
+(jabber-disco-advertise-feature "http://jabber.org/protocol/commands")
(add-to-list 'jabber-disco-items-nodes
(list "http://jabber.org/protocol/commands" #'jabber-ahc-disco-items nil))
(defun jabber-ahc-disco-items (jc xml-data)
diff --git a/jabber-chatstates.el b/jabber-chatstates.el
index 8b82171..3b8d0a5 100644
--- a/jabber-chatstates.el
+++ b/jabber-chatstates.el
@@ -168,7 +168,7 @@ It can be sent and cancelled several times.")
;; Add function last in chain, so a chat buffer is already created.
(add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-chatstates t)
-(add-to-list 'jabber-advertised-features "http://jabber.org/protocol/chatstates")
+(jabber-disco-advertise-feature "http://jabber.org/protocol/chatstates")
(provide 'jabber-chatstates)
;; arch-tag: d879de90-51e1-11dc-909d-000a95c2fcd0
diff --git a/jabber-disco.el b/jabber-disco.el
index 6eb3667..49cdcaa 100644
--- a/jabber-disco.el
+++ b/jabber-disco.el
@@ -25,10 +25,12 @@
;;; Respond to disco requests
-;; Advertise your features here. Add the namespace to this list.
(defvar jabber-advertised-features
(list "http://jabber.org/protocol/disco#info")
- "Features advertised on service discovery requests")
+ "Features advertised on service discovery requests
+
+Don't add your feature to this list directly. Instead, call
+`jabber-disco-advertise-feature'.")
(defvar jabber-disco-items-nodes
(list
@@ -109,7 +111,7 @@ See JEP-0030."
;; No such node
(jabber-signal-error "cancel" 'item-not-found))))
-(defun jabber-disco-return-client-info (jc xml-data)
+(defun jabber-disco-return-client-info (&optional jc xml-data)
`(
;; If running under a window system, this is
;; a GUI client. If not, it is a console client.
@@ -482,6 +484,8 @@ Return (IDENTITIES FEATURES), or nil if not in cache."
;; No, forget about it for now.
(remhash key jabber-caps-cache))))))
+;;; Entity Capabilities utility functions
+
(defun jabber-caps-ver-string (query hash)
;; XEP-0115, section 5.1
;; 1. Initialize an empty string S.
@@ -573,6 +577,58 @@ Return (IDENTITIES FEATURES), or nil if not in cache."
(b-xml:lang (jabber-xml-get-attribute b 'xml:lang)))
(string< a-xml:lang b-xml:lang)))))))))
+;;; Sending Entity Capabilities
+
+(defvar jabber-caps-default-hash-function "sha-1"
+ "Hash function to use when sending caps in presence stanzas.
+The value should be a key in `jabber-caps-hash-names'.")
+
+(defvar jabber-caps-current-hash nil
+ "The current disco hash we're sending out in presence stanzas.")
+
+(defconst jabber-caps-node "http://emacs-jabber.sourceforge.net")
+
+;;;###autoload
+(defun jabber-disco-advertise-feature (feature)
+ (push feature jabber-advertised-features)
+ (when jabber-caps-current-hash
+ (jabber-caps-recalculate-hash)
+ ;; If we're already connected, we need to send updated presence
+ ;; for the new feature.
+ (mapc #'jabber-send-current-presence jabber-connections)))
+
+(defun jabber-caps-recalculate-hash ()
+ "Update `jabber-caps-current-hash' for feature list change.
+Also update `jabber-disco-info-nodes', so we return results for
+the right node."
+ (let* ((old-hash jabber-caps-current-hash)
+ (old-node (and old-hash (concat jabber-caps-node "#" old-hash)))
+ (new-hash
+ (jabber-caps-ver-string `(query () ,@(jabber-disco-return-client-info))
+ jabber-caps-default-hash-function))
+ (new-node (concat jabber-caps-node "#" new-hash)))
+ (when old-node
+ (let ((old-entry (assoc old-node jabber-disco-info-nodes)))
+ (when old-entry
+ (setq jabber-disco-info-nodes (delq old-entry jabber-disco-info-nodes)))))
+ (push (list new-node #'jabber-disco-return-client-info nil)
+ jabber-disco-info-nodes)
+ (setq jabber-caps-current-hash new-hash)))
+
+;;;###autoload
+(defun jabber-caps-presence-element (_jc)
+ (unless jabber-caps-current-hash
+ (jabber-caps-recalculate-hash))
+
+ (list
+ `(c ((xmlns . "http://jabber.org/protocol/caps")
+ (hash . ,jabber-caps-default-hash-function)
+ (node . ,jabber-caps-node)
+ (ver . ,jabber-caps-current-hash)))))
+
+;;;###autoload
+(eval-after-load "jabber-presence"
+ '(add-to-list 'jabber-presence-element-functions #'jabber-caps-presence-element))
(provide 'jabber-disco)
diff --git a/jabber-feature-neg.el b/jabber-feature-neg.el
index 1fb8853..748a4cd 100644
--- a/jabber-feature-neg.el
+++ b/jabber-feature-neg.el
@@ -22,7 +22,7 @@
(require 'jabber-disco)
(require 'cl)
-(add-to-list 'jabber-advertised-features "http://jabber.org/protocol/feature-neg")
+(jabber-disco-advertise-feature "http://jabber.org/protocol/feature-neg")
(defun jabber-fn-parse (xml-data type)
"Parse a Feature Negotiation request, return alist representation.
diff --git a/jabber-ft-server.el b/jabber-ft-server.el
index cd889d5..b2afceb 100644
--- a/jabber-ft-server.el
+++ b/jabber-ft-server.el
@@ -31,7 +31,7 @@
(defvar jabber-ft-md5-hash nil
"MD5 hash of the file that is being downloaded")
-(add-to-list 'jabber-advertised-features "http://jabber.org/protocol/si/profile/file-transfer")
+(jabber-disco-advertise-feature "http://jabber.org/protocol/si/profile/file-transfer")
(add-to-list 'jabber-si-profiles
(list "http://jabber.org/protocol/si/profile/file-transfer"
diff --git a/jabber-ping.el b/jabber-ping.el
index e71267e..e9056ab 100644
--- a/jabber-ping.el
+++ b/jabber-ping.el
@@ -49,7 +49,7 @@
(format "%s is alive" to)))
(add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:ping" 'jabber-pong))
-(add-to-list 'jabber-advertised-features "urn:xmpp:ping")
+(jabber-disco-advertise-feature "urn:xmpp:ping")
(defun jabber-pong (jc xml-data)
"Return pong as defined in XEP-0199. Sender and Id are
diff --git a/jabber-si-server.el b/jabber-si-server.el
index 286ad29..70b99ad 100644
--- a/jabber-si-server.el
+++ b/jabber-si-server.el
@@ -25,7 +25,7 @@
(require 'jabber-si-common)
-(add-to-list 'jabber-advertised-features "http://jabber.org/protocol/si")
+(jabber-disco-advertise-feature "http://jabber.org/protocol/si")
;; Now, stream methods push data to profiles. It could be the other
;; way around; not sure which is better.
diff --git a/jabber-socks5.el b/jabber-socks5.el
index 54e6a90..fc77523 100644
--- a/jabber-socks5.el
+++ b/jabber-socks5.el
@@ -57,7 +57,7 @@ Put preferred ones first."
Keys of the alist are strings, the JIDs of the proxies.
Values are \"streamhost\" XML nodes.")
-(add-to-list 'jabber-advertised-features "http://jabber.org/protocol/bytestreams")
+(jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams")
(add-to-list 'jabber-si-stream-methods
(list "http://jabber.org/protocol/bytestreams"
diff --git a/jabber-time.el b/jabber-time.el
index 919e5b0..96ebe36 100644
--- a/jabber-time.el
+++ b/jabber-time.el
@@ -147,7 +147,7 @@
(format "%s uptime: %s seconds" from seconds)))))
(add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:time" 'jabber-return-legacy-time))
-(add-to-list 'jabber-advertised-features "jabber:iq:time")
+(jabber-disco-advertise-feature "jabber:iq:time")
(defun jabber-return-legacy-time (jc xml-data)
"Return client time as defined in XEP-0090. Sender and ID are
@@ -165,7 +165,7 @@ determined from the incoming packet passed in XML-DATA."
id)))
(add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:time" 'jabber-return-time))
-(add-to-list 'jabber-advertised-features "urn:xmpp:time")
+(jabber-disco-advertise-feature "urn:xmpp:time")
(defun jabber-return-time (jc xml-data)
"Return client time as defined in XEP-0202. Sender and ID are
@@ -180,7 +180,7 @@ determined from the incoming packet passed in XML-DATA."
id)))
(add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:last" 'jabber-return-last))
-(add-to-list 'jabber-advertised-features "jabber:iq:last")
+(jabber-disco-advertise-feature "jabber:iq:last")
(defun jabber-return-last (jc xml-data)
(let ((to (jabber-xml-get-attribute xml-data 'from))
diff --git a/jabber-version.el b/jabber-version.el
index 91d6ff3..455701a 100644
--- a/jabber-version.el
+++ b/jabber-version.el
@@ -54,7 +54,7 @@
(if jabber-version-show
(and
(add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:version" 'jabber-return-version))
- (add-to-list 'jabber-advertised-features "jabber:iq:version")))
+ (jabber-disco-advertise-feature "jabber:iq:version")))
(defun jabber-return-version (jc xml-data)
"Return client version as defined in JEP-0092. Sender and ID are
diff --git a/jabber-widget.el b/jabber-widget.el
index 9c31baf..8e8fd0b 100644
--- a/jabber-widget.el
+++ b/jabber-widget.el
@@ -35,7 +35,7 @@
(defvar jabber-submit-to nil
"JID of the entity to which form data is to be sent")
-(add-to-list 'jabber-advertised-features "jabber:x:data")
+(jabber-disco-advertise-feature "jabber:x:data")
(define-widget 'jid 'string
"JID widget."
commit b0e517f27086b27ffb522549e36b5a536ac063ff
Author: Magnus Henoch <mag...@gm...>
Date: Tue Nov 26 01:13:44 2013 +0000
Look for caps only on "available" presence
diff --git a/jabber-disco.el b/jabber-disco.el
index 2d9f132..6eb3667 100644
--- a/jabber-disco.el
+++ b/jabber-disco.el
@@ -386,8 +386,9 @@ Return (IDENTITIES FEATURES), or nil if not in cache."
(defun jabber-process-caps (jc xml-data)
"Look for entity capabilities in presence stanzas."
(let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (type (jabber-xml-get-attribute xml-data 'type))
(c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
- (when c
+ (when (and (null type) c)
(jabber-xml-let-attributes
(ext hash node ver) c
(cond
commit 3fc929628606d988e5a41cac9d5941c87a23ae26
Author: Magnus Henoch <mag...@gm...>
Date: Mon Nov 25 23:36:12 2013 +0000
Merge jabber-newdisco into jabber-disco
The functionality is about to start overlapping. Also, there wasn't
much sense in separating the two to begin with.
diff --git a/Makefile.am b/Makefile.am
index bf9bd01..fc57b22 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -13,7 +13,7 @@ jabber-export.el jabber-feature-neg.el jabber-festival.el \
jabber-ft-client.el jabber-ft-common.el jabber-ft-server.el \
jabber-gmail.el jabber-history.el jabber-iq.el jabber-keepalive.el \
jabber-keymap.el jabber-logon.el jabber-menu.el jabber-modeline.el \
-jabber-muc-nick-completion.el jabber-muc.el jabber-newdisco.el \
+jabber-muc-nick-completion.el jabber-muc.el \
jabber-osd.el jabber-presence.el jabber-private.el jabber-ratpoison.el \
jabber-register.el jabber-roster.el jabber-sasl.el jabber-sawfish.el \
jabber-screen.el jabber-search.el jabber-si-client.el \
diff --git a/jabber-disco.el b/jabber-disco.el
index 38cb213..2d9f132 100644
--- a/jabber-disco.el
+++ b/jabber-disco.el
@@ -19,16 +19,12 @@
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
-;;; All the client part should be seriously rewritten, or at least
-;;; reconsidered. I'm imagining a separation between backend and
-;;; frontend, so that various functions can perform disco queries for
-;;; their own purposes, and maybe some caching with that.
-
(require 'jabber-iq)
(require 'jabber-xml)
(require 'jabber-menu)
+;;; Respond to disco requests
+
;; Advertise your features here. Add the namespace to this list.
(defvar jabber-advertised-features
(list "http://jabber.org/protocol/disco#info")
@@ -75,53 +71,6 @@ Second item is access control function. That function is passed the
JID, and returns non-nil if access is granted. If the second item is
nil, access is always granted.")
-(defun jabber-process-disco-info (jc xml-data)
- "Handle results from info disco requests."
-
- (let ((beginning (point)))
- (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data)))
- (cond
- ((eq (jabber-xml-node-name x) 'identity)
- (let ((name (jabber-xml-get-attribute x 'name))
- (category (jabber-xml-get-attribute x 'category))
- (type (jabber-xml-get-attribute x 'type)))
- (insert (jabber-propertize (if name
- name
- "Unnamed")
- 'face 'jabber-title-medium)
- "\n\nCategory:\t" category "\n")
- (if type
- (insert "Type:\t\t" type "\n"))
- (insert "\n")))
- ((eq (jabber-xml-node-name x) 'feature)
- (let ((var (jabber-xml-get-attribute x 'var)))
- (insert "Feature:\t" var "\n")))))
- (put-text-property beginning (point)
- 'jabber-jid (jabber-xml-get-attribute xml-data 'from))
- (put-text-property beginning (point)
- 'jabber-account jc)))
-
-(defun jabber-process-disco-items (jc xml-data)
- "Handle results from items disco requests."
-
- (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))
- (if items
- (dolist (item items)
- (let ((jid (jabber-xml-get-attribute item 'jid))
- (name (jabber-xml-get-attribute item 'name))
- (node (jabber-xml-get-attribute item 'node)))
- (insert
- (jabber-propertize
- (concat
- (jabber-propertize
- (concat jid "\n" (if node (format "Node: %s\n" node)))
- 'face 'jabber-title-medium)
- name "\n\n")
- 'jabber-jid jid
- 'jabber-account jc
- 'jabber-node node))))
- (insert "No items found.\n"))))
-
(add-to-list 'jabber-iq-get-xmlns-alist
(cons "http://jabber.org/protocol/disco#info" 'jabber-return-disco-info))
(add-to-list 'jabber-iq-get-xmlns-alist
@@ -174,6 +123,8 @@ See JEP-0030."
#'(lambda (featurename)
`(feature ((var . ,featurename))))
jabber-advertised-features)))
+
+;;; Interactive disco requests
(add-to-list 'jabber-jid-info-menu
(cons "Send items disco query" 'jabber-get-disco-items))
@@ -205,6 +156,423 @@ See JEP-0030."
#'jabber-process-data #'jabber-process-disco-info
#'jabber-process-data "Info discovery failed"))
+(defun jabber-process-disco-info (jc xml-data)
+ "Handle results from info disco requests."
+
+ (let ((beginning (point)))
+ (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data)))
+ (cond
+ ((eq (jabber-xml-node-name x) 'identity)
+ (let ((name (jabber-xml-get-attribute x 'name))
+ (category (jabber-xml-get-attribute x 'category))
+ (type (jabber-xml-get-attribute x 'type)))
+ (insert (jabber-propertize (if name
+ name
+ "Unnamed")
+ 'face 'jabber-title-medium)
+ "\n\nCategory:\t" category "\n")
+ (if type
+ (insert "Type:\t\t" type "\n"))
+ (insert "\n")))
+ ((eq (jabber-xml-node-name x) 'feature)
+ (let ((var (jabber-xml-get-attribute x 'var)))
+ (insert "Feature:\t" var "\n")))))
+ (put-text-property beginning (point)
+ 'jabber-jid (jabber-xml-get-attribute xml-data 'from))
+ (put-text-property beginning (point)
+ 'jabber-account jc)))
+
+(defun jabber-process-disco-items (jc xml-data)
+ "Handle results from items disco requests."
+
+ (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))
+ (if items
+ (dolist (item items)
+ (let ((jid (jabber-xml-get-attribute item 'jid))
+ (name (jabber-xml-get-attribute item 'name))
+ (node (jabber-xml-get-attribute item 'node)))
+ (insert
+ (jabber-propertize
+ (concat
+ (jabber-propertize
+ (concat jid "\n" (if node (format "Node: %s\n" node)))
+ 'face 'jabber-title-medium)
+ name "\n\n")
+ 'jabber-jid jid
+ 'jabber-account jc
+ 'jabber-node node))))
+ (insert "No items found.\n"))))
+
+;;; Caching API for disco requests
+
+;; Keys are ("jid" . "node"), where "node" is nil if appropriate.
+;; Values are (identities features), where each identity is ["name"
+;; "category" "type"], and each feature is a string.
+(defvar jabber-disco-info-cache (make-hash-table :test 'equal))
+
+;; Keys are ("jid" . "node"). Values are (items), where each
+;; item is ["name" "jid" "node"] (some values may be nil).
+(defvar jabber-disco-items-cache (make-hash-table :test 'equal))
+
+(defun jabber-disco-get-info (jc jid node callback closure-data &optional force)
+ "Get disco info for JID and NODE, using connection JC.
+Call CALLBACK with JC and CLOSURE-DATA as first and second
+arguments and result as third argument when result is available.
+On success, result is (IDENTITIES FEATURES), where each identity is [\"name\"
+\"category\" \"type\"], and each feature is a string.
+On error, result is the error node, recognizable by (eq (car result) 'error).
+
+If CALLBACK is nil, just fetch data. If FORCE is non-nil,
+invalidate cache and get fresh data."
+ (when force
+ (remhash (cons jid node) jabber-disco-info-cache))
+ (let ((result (unless force (jabber-disco-get-info-immediately jid node))))
+ (if result
+ (and callback (run-with-timer 0 nil callback jc closure-data result))
+ (jabber-send-iq jc jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#info")
+ ,@(when node `((node . ,node)))))
+ #'jabber-disco-got-info (cons callback closure-data)
+ (lambda (jc xml-data callback-data)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
+ (cons callback closure-data)))))
+
+(defun jabber-disco-got-info (jc xml-data callback-data)
+ (let ((jid (jabber-xml-get-attribute xml-data 'from))
+ (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
+ 'node))
+ (result (jabber-disco-parse-info xml-data)))
+ (puthash (cons jid node) result jabber-disco-info-cache)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) result))))
+
+(defun jabber-disco-parse-info (xml-data)
+ "Extract data from an <iq/> stanza containing a disco#info result.
+See `jabber-disco-get-info' for a description of the return value."
+ (list
+ (mapcar
+ #'(lambda (id)
+ (vector (jabber-xml-get-attribute id 'name)
+ (jabber-xml-get-attribute id 'category)
+ (jabber-xml-get-attribute id 'type)))
+ (jabber-xml-get-children (jabber-iq-query xml-data) 'identity))
+ (mapcar
+ #'(lambda (feature)
+ (jabber-xml-get-attribute feature 'var))
+ (jabber-xml-get-children (jabber-iq-query xml-data) 'feature))))
+
+(defun jabber-disco-get-info-immediately (jid node)
+ "Get cached disco info for JID and NODE.
+Return nil if no info available.
+
+Fill the cache with `jabber-disco-get-info'."
+ (or
+ ;; Check "normal" cache...
+ (gethash (cons jid node) jabber-disco-info-cache)
+ ;; And then check Entity Capabilities.
+ (and (null node) (jabber-caps-get-cached jid))))
+
+(defun jabber-disco-get-items (jc jid node callback closure-data &optional force)
+ "Get disco items for JID and NODE, using connection JC.
+Call CALLBACK with JC and CLOSURE-DATA as first and second
+arguments and items result as third argument when result is
+available.
+On success, result is a list of items, where each
+item is [\"name\" \"jid\" \"node\"] (some values may be nil).
+On error, result is the error node, recognizable by (eq (car result) 'error).
+
+If CALLBACK is nil, just fetch data. If FORCE is non-nil,
+invalidate cache and get fresh data."
+ (when force
+ (remhash (cons jid node) jabber-disco-items-cache))
+ (let ((result (gethash (cons jid node) jabber-disco-items-cache)))
+ (if result
+ (and callback (run-with-timer 0 nil callback jc closure-data result))
+ (jabber-send-iq jc jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#items")
+ ,@(when node `((node . ,node)))))
+ #'jabber-disco-got-items (cons callback closure-data)
+ (lambda (jc xml-data callback-data)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
+ (cons callback closure-data)))))
+
+(defun jabber-disco-got-items (jc xml-data callback-data)
+ (let ((jid (jabber-xml-get-attribute xml-data 'from))
+ (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
+ 'node))
+ (result
+ (mapcar
+ #'(lambda (item)
+ (vector
+ (jabber-xml-get-attribute item 'name)
+ (jabber-xml-get-attribute item 'jid)
+ (jabber-xml-get-attribute item 'node)))
+ (jabber-xml-get-children (jabber-iq-query xml-data) 'item))))
+ (puthash (cons jid node) result jabber-disco-items-cache)
+ (when (car callback-data)
+ (funcall (car callback-data) jc (cdr callback-data) result))))
+
+(defun jabber-disco-get-items-immediately (jid node)
+ (gethash (cons jid node) jabber-disco-items-cache))
+
+;;; Publish
+
+(defun jabber-disco-publish (jc node item-name item-jid item-node)
+ "Publish the given item under disco node NODE."
+ (jabber-send-iq jc nil
+ "set"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#items")
+ ,@(when node `((node . ,node))))
+ (item ((action . "update")
+ (jid . ,item-jid)
+ ,@(when item-name
+ `((name . ,item-name)))
+ ,@(when item-node
+ `((node . ,item-node))))))
+ 'jabber-report-success "Disco publish"
+ 'jabber-report-success "Disco publish"))
+
+(defun jabber-disco-publish-remove (jc node item-jid item-node)
+ "Remove the given item from published disco items."
+ (jabber-send-iq jc nil
+ "set"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#items")
+ ,@(when node `((node . ,node))))
+ (item ((action . "remove")
+ (jid . ,item-jid)
+ ,@(when item-node
+ `((node . ,item-node))))))
+ 'jabber-report-success "Disco removal"
+ 'jabber-report-success "Disco removal"))
+
+;;; Entity Capabilities (XEP-0115)
+
+;;;###autoload
+(eval-after-load "jabber-core"
+ '(add-to-list 'jabber-presence-chain #'jabber-process-caps))
+
+(defvar jabber-caps-cache (make-hash-table :test 'equal))
+
+(defconst jabber-caps-hash-names
+ '(("sha-1" . sha1)
+ ("sha-224" . sha224)
+ ("sha-256" . sha256)
+ ("sha-384" . sha384)
+ ("sha-512" . sha512))
+ "Hash function name map.
+Maps names defined in http://www.iana.org/assignments/hash-function-text-names
+to symbols accepted by `secure-hash'.
+
+XEP-0115 currently recommends SHA-1, but let's be future-proof.")
+
+(defun jabber-caps-get-cached (jid)
+ "Get disco info from Entity Capabilities cache.
+JID should be a string containing a full JID.
+Return (IDENTITIES FEATURES), or nil if not in cache."
+ (let* ((symbol (jabber-jid-symbol jid))
+ (resource (or (jabber-jid-resource jid) ""))
+ (resource-plist (cdr (assoc resource (get symbol 'resources))))
+ (key (plist-get resource-plist 'caps)))
+ (when key
+ (let ((cache-entry (gethash key jabber-caps-cache)))
+ (when (and (consp cache-entry) (not (floatp (car cache-entry))))
+ cache-entry)))))
+
+;;;###autoload
+(defun jabber-process-caps (jc xml-data)
+ "Look for entity capabilities in presence stanzas."
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
+ (when c
+ (jabber-xml-let-attributes
+ (ext hash node ver) c
+ (cond
+ (hash
+ ;; If the <c/> element has a hash attribute, it follows the
+ ;; "modern" version of XEP-0115.
+ (jabber-process-caps-modern jc from hash node ver))
+ (t
+ ;; No hash attribute. Use legacy version of XEP-0115.
+ ;; TODO: do something clever here.
+ ))))))
+
+(defun jabber-process-caps-modern (jc jid hash node ver)
+ (when (assoc hash jabber-caps-hash-names)
+ ;; We support the hash function used.
+ (let* ((key (cons hash ver))
+ (cache-entry (gethash key jabber-caps-cache)))
+ ;; Remember the hash in the JID symbol.
+ (let* ((symbol (jabber-jid-symbol jid))
+ (resource (or (jabber-jid-resource jid) ""))
+ (resource-entry (assoc resource (get symbol 'resources)))
+ (new-resource-plist (plist-put (cdr resource-entry) 'caps key)))
+ (if resource-entry
+ (setf (cdr resource-entry) new-resource-plist)
+ (push (cons resource new-resource-plist) (get symbol 'resources))))
+
+ (flet ((request-disco-info
+ ()
+ (jabber-send-iq
+ jc jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#info")
+ (node . ,(concat node "#" ver))))
+ #'jabber-process-caps-info-result (list hash node ver)
+ #'jabber-process-caps-info-error (list hash node ver))))
+ (cond
+ ((and (consp cache-entry)
+ (floatp (car cache-entry)))
+ ;; We have a record of asking someone about this hash.
+ (if (< (- (float-time) (car cache-entry)) 10.0)
+ ;; We asked someone about this hash less than 10 seconds ago.
+ ;; Let's add the new JID to the entry, just in case that
+ ;; doesn't work out.
+ (pushnew jid (cdr cache-entry) :test #'string=)
+ ;; We asked someone about it more than 10 seconds ago.
+ ;; They're probably not going to answer. Let's ask
+ ;; this contact about it instead.
+ (setf (car cache-entry) (float-time))
+ (request-disco-info)))
+ ((null cache-entry)
+ ;; We know nothing about this hash. Let's note the
+ ;; fact that we tried to get information about it.
+ (puthash key (list (float-time)) jabber-caps-cache)
+ (request-disco-info))
+ (t
+ ;; We already know what this hash represents, so we
+ ;; can cache info for this contact.
+ (puthash (cons jid nil) cache-entry jabber-disco-info-cache)))))))
+
+(defun jabber-process-caps-info-result (jc xml-data closure-data)
+ (destructuring-bind (hash node ver) closure-data
+ (let* ((key (cons hash ver))
+ (query (jabber-iq-query xml-data))
+ (verification-string (jabber-caps-ver-string query hash)))
+ (if (string= ver verification-string)
+ ;; The hash is correct; save info.
+ (puthash key (jabber-disco-parse-info xml-data) jabber-caps-cache)
+ ;; The hash is incorrect.
+ (jabber-caps-try-next jc hash node ver)))))
+
+(defun jabber-process-caps-info-error (jc xml-data closure-data)
+ (destructuring-bind (hash node ver) closure-data
+ (jabber-caps-try-next jc hash node ver)))
+
+(defun jabber-caps-try-next (jc hash node ver)
+ (let* ((key (cons hash ver))
+ (cache-entry (gethash key jabber-caps-cache)))
+ (when (floatp (car-safe cache-entry))
+ (let ((next-jid (pop (cdr cache-entry))))
+ ;; Do we know someone else we could ask about this hash?
+ (if next-jid
+ (progn
+ (setf (car cache-entry) (float-time))
+ (jabber-send-iq
+ jc next-jid
+ "get"
+ `(query ((xmlns . "http://jabber.org/protocol/disco#info")
+ (node . ,(concat node "#" ver))))
+ #'jabber-process-caps-info-result key
+ #'jabber-process-caps-info-error key))
+ ;; No, forget about it for now.
+ (remhash key jabber-caps-cache))))))
+
+(defun jabber-caps-ver-string (query hash)
+ ;; XEP-0115, section 5.1
+ ;; 1. Initialize an empty string S.
+ (with-temp-buffer
+ (let* ((identities (jabber-xml-get-children query 'identity))
+ (features (mapcar (lambda (feature) (jabber-xml-get-attribute feature 'var))
+ (jabber-xml-get-children query 'feature)))
+ (maybe-forms (jabber-xml-get-children query 'x))
+ (forms (remove-if-not
+ (lambda (x)
+ ;; Keep elements that are forms and have a FORM_TYPE,
+ ;; according to XEP-0128.
+ (and (string= (jabber-xml-get-xmlns x) "jabber:x:data")
+ (jabber-xdata-formtype x)))
+ maybe-forms)))
+ ;; 2. Sort the service discovery identities [15] by category
+ ;; and then by type and then by xml:lang (if it exists),
+ ;; formatted as CATEGORY '/' [TYPE] '/' [LANG] '/'
+ ;; [NAME]. [16] Note that each slash is included even if the
+ ;; LANG or NAME is not included (in accordance with XEP-0030,
+ ;; the category and type MUST be included.
+ (setq identities (sort identities #'jabber-caps-identity-<))
+ ;; 3. For each identity, append the 'category/type/lang/name' to
+ ;; S, followed by the '<' character.
+ (dolist (identity identities)
+ (jabber-xml-let-attributes (category type xml:lang name) identity
+ ;; Use `concat' here instead of passing everything to
+ ;; `insert', since `concat' tolerates nil values.
+ (insert (concat category "/" type "/" xml:lang "/" name "<"))))
+ ;; 4. Sort the supported service discovery features. [17]
+ (setq features (sort features #'string<))
+ ;; 5. For each feature, append the feature to S, followed by the
+ ;; '<' character.
+ (dolist (feature features)
+ (insert feature "<"))
+ ;; 6. If the service discovery information response includes
+ ;; XEP-0128 data forms, sort the forms by the FORM_TYPE (i.e.,
+ ;; by the XML character data of the <value/> element).
+ (setq forms (sort forms (lambda (a b)
+ (string< (jabber-xdata-formtype a)
+ (jabber-xdata-formtype b)))))
+ ;; 7. For each extended service discovery information form:
+ (dolist (form forms)
+ ;; Append the XML character data of the FORM_TYPE field's
+ ;; <value/> element, followed by the '<' character.
+ (insert (jabber-xdata-formtype form) "<")
+ ;; Sort the fields by the value of the "var" attribute.
+ (let ((fields (sort (jabber-xml-get-children form 'field)
+ (lambda (a b)
+ (string< (jabber-xml-get-attribute a 'var)
+ (jabber-xml-get-attribute b 'var))))))
+ (dolist (field fields)
+ ;; For each field other than FORM_TYPE:
+ (unless (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
+ ;; Append the value of the "var" attribute, followed by the '<' character.
+ (insert (jabber-xml-get-attribute field 'var) "<")
+ ;; Sort values by the XML character data of the <value/> element.
+ (let ((values (sort (mapcar (lambda (value)
+ (car (jabber-xml-node-children value)))
+ (jabber-xml-get-children field 'value))
+ #'string<)))
+ ;; For each <value/> element, append the XML character
+ ;; data, followed by the '<' character.
+ (dolist (value values)
+ (insert value "<"))))))))
+
+ ;; 8. Ensure that S is encoded according to the UTF-8 encoding
+ ;; (RFC 3269 [18]).
+ (let ((s (encode-coding-string (buffer-string) 'utf-8 t))
+ (algorithm (cdr (assoc hash jabber-caps-hash-names))))
+ ;; 9. Compute the verification string by hashing S using the
+ ;; algorithm specified in the 'hash' attribute (e.g., SHA-1 as
+ ;; defined in RFC 3174 [19]). The hashed data MUST be generated
+ ;; with binary output and encoded using Base64 as specified in
+ ;; Section 4 of RFC 4648 [20] (note: the Base64 output MUST NOT
+ ;; include whitespace and MUST set padding bits to zero). [21]
+ (base64-encode-string (secure-hash algorithm s nil nil t) t))))
+
+(defun jabber-caps-identity-< (a b)
+ (let ((a-category (jabber-xml-get-attribute a 'category))
+ (b-category (jabber-xml-get-attribute b 'category)))
+ (or (string< a-category b-category)
+ (and (string= a-category b-category)
+ (let ((a-type (jabber-xml-get-attribute a 'type))
+ (b-type (jabber-xml-get-attribute b 'type)))
+ (or (string< a-type b-type)
+ (and (string= a-type b-type)
+ (let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang))
+ (b-xml:lang (jabber-xml-get-attribute b 'xml:lang)))
+ (string< a-xml:lang b-xml:lang)))))))))
+
+
(provide 'jabber-disco)
;;; arch-tag: 71f5c76f-2956-4ed2-b871-9f5fe198092d
diff --git a/jabber-muc.el b/jabber-muc.el
index 45a7bd8..ceb8bc4 100644
--- a/jabber-muc.el
+++ b/jabber-muc.el
@@ -22,7 +22,7 @@
(require 'jabber-chat)
(require 'jabber-widget)
-(require 'jabber-newdisco)
+(require 'jabber-disco)
(require 'jabber-muc-nick-coloring)
(require 'cl)
diff --git a/jabber-newdisco.el b/jabber-newdisco.el
deleted file mode 100644
index 7d3d286..0000000
--- a/jabber-newdisco.el
+++ /dev/null
@@ -1,399 +0,0 @@
-;;; jabber-newdisco.el --- caching disco API
-
-;; Copyright (C) 2005, 2008 Magnus Henoch
-
-;; Author: Magnus Henoch <ma...@fr...>
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; This file is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-(require 'jabber-xml)
-
-;;---
-;; Keys are ("jid" . "node"), where "node" is nil if appropriate.
-;; Values are (identities features), where each identity is ["name"
-;; "category" "type"], and each feature is a string.
-(defvar jabber-disco-info-cache (make-hash-table :test 'equal))
-
-;; Keys are ("jid" . "node"). Values are (items), where each
-;; item is ["name" "jid" "node"] (some values may be nil).
-(defvar jabber-disco-items-cache (make-hash-table :test 'equal))
-
-;;; Info
-
-(defun jabber-disco-get-info (jc jid node callback closure-data &optional force)
- "Get disco info for JID and NODE, using connection JC.
-Call CALLBACK with JC and CLOSURE-DATA as first and second
-arguments and result as third argument when result is available.
-On success, result is (IDENTITIES FEATURES), where each identity is [\"name\"
-\"category\" \"type\"], and each feature is a string.
-On error, result is the error node, recognizable by (eq (car result) 'error).
-
-If CALLBACK is nil, just fetch data. If FORCE is non-nil,
-invalidate cache and get fresh data."
- (when force
- (remhash (cons jid node) jabber-disco-info-cache))
- (let ((result (unless force (jabber-disco-get-info-immediately jid node))))
- (if result
- (and callback (run-with-timer 0 nil callback jc closure-data result))
- (jabber-send-iq jc jid
- "get"
- `(query ((xmlns . "http://jabber.org/protocol/disco#info")
- ,@(when node `((node . ,node)))))
- #'jabber-disco-got-info (cons callback closure-data)
- (lambda (jc xml-data callback-data)
- (when (car callback-data)
- (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
- (cons callback closure-data)))))
-
-(defun jabber-disco-got-info (jc xml-data callback-data)
- (let ((jid (jabber-xml-get-attribute xml-data 'from))
- (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
- 'node))
- (result (jabber-disco-parse-info xml-data)))
- (puthash (cons jid node) result jabber-disco-info-cache)
- (when (car callback-data)
- (funcall (car callback-data) jc (cdr callback-data) result))))
-
-(defun jabber-disco-parse-info (xml-data)
- "Extract data from an <iq/> stanza containing a disco#info result.
-See `jabber-disco-get-info' for a description of the return value."
- (list
- (mapcar
- #'(lambda (id)
- (vector (jabber-xml-get-attribute id 'name)
- (jabber-xml-get-attribute id 'category)
- (jabber-xml-get-attribute id 'type)))
- (jabber-xml-get-children (jabber-iq-query xml-data) 'identity))
- (mapcar
- #'(lambda (feature)
- (jabber-xml-get-attribute feature 'var))
- (jabber-xml-get-children (jabber-iq-query xml-data) 'feature))))
-
-(defun jabber-disco-get-info-immediately (jid node)
- "Get cached disco info for JID and NODE.
-Return nil if no info available.
-
-Fill the cache with `jabber-disco-get-info'."
- (or
- ;; Check "normal" cache...
- (gethash (cons jid node) jabber-disco-info-cache)
- ;; And then check Entity Capabilities.
- (and (null node) (jabber-caps-get-cached jid))))
-
-;;; Items
-
-(defun jabber-disco-get-items (jc jid node callback closure-data &optional force)
- "Get disco items for JID and NODE, using connection JC.
-Call CALLBACK with JC and CLOSURE-DATA as first and second
-arguments and items result as third argument when result is
-available.
-On success, result is a list of items, where each
-item is [\"name\" \"jid\" \"node\"] (some values may be nil).
-On error, result is the error node, recognizable by (eq (car result) 'error).
-
-If CALLBACK is nil, just fetch data. If FORCE is non-nil,
-invalidate cache and get fresh data."
- (when force
- (remhash (cons jid node) jabber-disco-items-cache))
- (let ((result (gethash (cons jid node) jabber-disco-items-cache)))
- (if result
- (and callback (run-with-timer 0 nil callback jc closure-data result))
- (jabber-send-iq jc jid
- "get"
- `(query ((xmlns . "http://jabber.org/protocol/disco#items")
- ,@(when node `((node . ,node)))))
- #'jabber-disco-got-items (cons callback closure-data)
- (lambda (jc xml-data callback-data)
- (when (car callback-data)
- (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
- (cons callback closure-data)))))
-
-(defun jabber-disco-got-items (jc xml-data callback-data)
- (let ((jid (jabber-xml-get-attribute xml-data 'from))
- (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
- 'node))
- (result
- (mapcar
- #'(lambda (item)
- (vector
- (jabber-xml-get-attribute item 'name)
- (jabber-xml-get-attribute item 'jid)
- (jabber-xml-get-attribute item 'node)))
- (jabber-xml-get-children (jabber-iq-query xml-data) 'item))))
- (puthash (cons jid node) result jabber-disco-items-cache)
- (when (car callback-data)
- (funcall (car callback-data) jc (cdr callback-data) result))))
-
-(defun jabber-disco-get-items-immediately (jid node)
- (gethash (cons jid node) jabber-disco-items-cache))
-
-;;; Publish
-
-(defun jabber-disco-publish (jc node item-name item-jid item-node)
- "Publish the given item under disco node NODE."
- (jabber-send-iq jc nil
- "set"
- `(query ((xmlns . "http://jabber.org/protocol/disco#items")
- ,@(when node `((node . ,node))))
- (item ((action . "update")
- (jid . ,item-jid)
- ,@(when item-name
- `((name . ,item-name)))
- ,@(when item-node
- `((node . ,item-node))))))
- 'jabber-report-success "Disco publish"
- 'jabber-report-success "Disco publish"))
-
-(defun jabber-disco-publish-remove (jc node item-jid item-node)
- "Remove the given item from published disco items."
- (jabber-send-iq jc nil
- "set"
- `(query ((xmlns . "http://jabber.org/protocol/disco#items")
- ,@(when node `((node . ,node))))
- (item ((action . "remove")
- (jid . ,item-jid)
- ,@(when item-node
- `((node . ,item-node))))))
- 'jabber-report-success "Disco removal"
- 'jabber-report-success "Disco removal"))
-
-;;; Entity Capabilities (XEP-0115)
-
-;;;###autoload
-(eval-after-load "jabber-core"
- '(add-to-list 'jabber-presence-chain #'jabber-process-caps))
-
-(defvar jabber-caps-cache (make-hash-table :test 'equal))
-
-(defconst jabber-caps-hash-names
- '(("sha-1" . sha1)
- ("sha-224" . sha224)
- ("sha-256" . sha256)
- ("sha-384" . sha384)
- ("sha-512" . sha512))
- "Hash function name map.
-Maps names defined in http://www.iana.org/assignments/hash-function-text-names
-to symbols accepted by `secure-hash'.
-
-XEP-0115 currently recommends SHA-1, but let's be future-proof.")
-
-(defun jabber-caps-get-cached (jid)
- "Get disco info from Entity Capabilities cache.
-JID should be a string containing a full JID.
-Return (IDENTITIES FEATURES), or nil if not in cache."
- (let* ((symbol (jabber-jid-symbol jid))
- (resource (or (jabber-jid-resource jid) ""))
- (resource-plist (cdr (assoc resource (get symbol 'resources))))
- (key (plist-get resource-plist 'caps)))
- (when key
- (let ((cache-entry (gethash key jabber-caps-cache)))
- (when (and (consp cache-entry) (not (floatp (car cache-entry))))
- cache-entry)))))
-
-;;;###autoload
-(defun jabber-process-caps (jc xml-data)
- "Look for entity capabilities in presence stanzas."
- (let* ((from (jabber-xml-get-attribute xml-data 'from))
- (c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
- (when c
- (jabber-xml-let-attributes
- (ext hash node ver) c
- (cond
- (hash
- ;; If the <c/> element has a hash attribute, it follows the
- ;; "modern" version of XEP-0115.
- (jabber-process-caps-modern jc from hash node ver))
- (t
- ;; No hash attribute. Use legacy version of XEP-0115.
- ;; TODO: do something clever here.
- ))))))
-
-(defun jabber-process-caps-modern (jc jid hash node ver)
- (when (assoc hash jabber-caps-hash-names)
- ;; We support the hash function used.
- (let* ((key (cons hash ver))
- (cache-entry (gethash key jabber-caps-cache)))
- ;; Remember the hash in the JID symbol.
- (let* ((symbol (jabber-jid-symbol jid))
- (resource (or (jabber-jid-resource jid) ""))
- (resource-entry (assoc resource (get symbol 'resources)))
- (new-resource-plist (plist-put (cdr resource-entry) 'caps key)))
- (if resource-entry
- (setf (cdr resource-entry) new-resource-plist)
- (push (cons resource new-resource-plist) (get symbol 'resources))))
-
- (flet ((request-disco-info
- ()
- (jabber-send-iq
- jc jid
- "get"
- `(query ((xmlns . "http://jabber.org/protocol/disco#info")
- (node . ,(concat node "#" ver))))
- #'jabber-process-caps-info-result (list hash node ver)
- #'jabber-process-caps-info-error (list hash node ver))))
- (cond
- ((and (consp cache-entry)
- (floatp (car cache-entry)))
- ;; We have a record of asking someone about this hash.
- (if (< (- (float-time) (car cache-entry)) 10.0)
- ;; We asked someone about this hash less than 10 seconds ago.
- ;; Let's add the new JID to the entry, just in case that
- ;; doesn't work out.
- (pushnew jid (cdr cache-entry) :test #'string=)
- ;; We asked someone about it more than 10 seconds ago.
- ;; They're probably not going to answer. Let's ask
- ;; this contact about it instead.
- (setf (car cache-entry) (float-time))
- (request-disco-info)))
- ((null cache-entry)
- ;; We know nothing about this hash. Let's note the
- ;; fact that we tried to get information about it.
- (puthash key (list (float-time)) jabber-caps-cache)
- (request-disco-info))
- (t
- ;; We already know what this hash represents, so we
- ;; can cache info for this contact.
- (puthash (cons jid nil) cache-entry jabber-disco-info-cache)))))))
-
-(defun jabber-process-caps-info-result (jc xml-data closure-data)
- (destructuring-bind (hash node ver) closure-data
- (let* ((key (cons hash ver))
- (query (jabber-iq-query xml-data))
- (verification-string (jabber-caps-ver-string query hash)))
- (if (string= ver verification-string)
- ;; The hash is correct; save info.
- (puthash key (jabber-disco-parse-info xml-data) jabber-caps-cache)
- ;; The hash is incorrect.
- (jabber-caps-try-next jc hash node ver)))))
-
-(defun jabber-process-caps-info-error (jc xml-data closure-data)
- (destructuring-bind (hash node ver) closure-data
- (jabber-caps-try-next jc hash node ver)))
-
-(defun jabber-caps-try-next (jc hash node ver)
- (let* ((key (cons hash ver))
- (cache-entry (gethash key jabber-caps-cache)))
- (when (floatp (car-safe cache-entry))
- (let ((next-jid (pop (cdr cache-entry))))
- ;; Do we know someone else we could ask about this hash?
- (if next-jid
- (progn
- (setf (car cache-entry) (float-time))
- (jabber-send-iq
- jc next-jid
- "get"
- `(query ((xmlns . "http://jabber.org/protocol/disco#info")
- (node . ,(concat node "#" ver))))
- #'jabber-process-caps-info-result key
- #'jabber-process-caps-info-error key))
- ;; No, forget about it for now.
- (remhash key jabber-caps-cache))))))
-
-(defun jabber-caps-ver-string (query hash)
- ;; XEP-0115, section 5.1
- ;; 1. Initialize an empty string S.
- (with-temp-buffer
- (let* ((identities (jabber-xml-get-children query 'identity))
- (features (mapcar (lambda (feature) (jabber-xml-get-attribute feature 'var))
- (jabber-xml-get-children query 'feature)))
- (maybe-forms (jabber-xml-get-children query 'x))
- (forms (remove-if-not
- (lambda (x)
- ;; Keep elements that are forms and have a FORM_TYPE,
- ;; according to XEP-0128.
- (and (string= (jabber-xml-get-xmlns x) "jabber:x:data")
- (jabber-xdata-formtype x)))
- maybe-forms)))
- ;; 2. Sort the service discovery identities [15] by category
- ;; and then by type and then by xml:lang (if it exists),
- ;; formatted as CATEGORY '/' [TYPE] '/' [LANG] '/'
- ;; [NAME]. [16] Note that each slash is included even if the
- ;; LANG or NAME is not included (in accordance with XEP-0030,
- ;; the category and type MUST be included.
- (setq identities (sort identities #'jabber-caps-identity-<))
- ;; 3. For each identity, append the 'category/type/lang/name' to
- ;; S, followed by the '<' character.
- (dolist (identity identities)
- (jabber-xml-let-attributes (category type xml:lang name) identity
- ;; Use `concat' here instead of passing everything to
- ;; `insert', since `concat' tolerates nil values.
- (insert (concat category "/" type "/" xml:lang "/" name "<"))))
- ;; 4. Sort the supported service discovery features. [17]
- (setq features (sort features #'string<))
- ;; 5. For each feature, append the feature to S, followed by the
- ;; '<' character.
- (dolist (feature features)
- (insert feature "<"))
- ;; 6. If the service discovery information response includes
- ;; XEP-0128 data forms, sort the forms by the FORM_TYPE (i.e.,
- ;; by the XML character data of the <value/> element).
- (setq forms (sort forms (lambda (a b)
- (string< (jabber-xdata-formtype a)
- (jabber-xdata-formtype b)))))
- ;; 7. For each extended service discovery information form:
- (dolist (form forms)
- ;; Append the XML character data of the FORM_TYPE field's
- ;; <value/> element, followed by the '<' character.
- (insert (jabber-xdata-formtype form) "<")
- ;; Sort the fields by the value of the "var" attribute.
- (let ((fields (sort (jabber-xml-get-children form 'field)
- (lambda (a b)
- (string< (jabber-xml-get-attribute a 'var)
- (jabber-xml-get-attribute b 'var))))))
- (dolist (field fields)
- ;; For each field other than FORM_TYPE:
- (unless (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
- ;; Append the value of the "var" attribute, followed by the '<' character.
- (insert (jabber-xml-get-attribute field 'var) "<")
- ;; Sort values by the XML character data of the <value/> element.
- (let ((values (sort (mapcar (lambda (value)
- (car (jabber-xml-node-children value)))
- (jabber-xml-get-children field 'value))
- #'string<)))
- ;; For each <value/> element, append the XML character
- ;; data, followed by the '<' character.
- (dolist (value values)
- (insert value "<"))))))))
-
- ;; 8. Ensure that S is encoded according to the UTF-8 encoding
- ;; (RFC 3269 [18]).
- (let ((s (encode-coding-string (buffer-string) 'utf-8 t))
- (algorithm (cdr (assoc hash jabber-caps-hash-names))))
- ;; 9. Compute the verification string by hashing S using the
- ;; algorithm specified in the 'hash' attribute (e.g., SHA-1 as
- ;; defined in RFC 3174 [19]). The hashed data MUST be generated
- ;; with binary output and encoded using Base64 as specified in
- ;; Section 4 of RFC 4648 [20] (note: the Base64 output MUST NOT
- ;; include whitespace and MUST set padding bits to zero). [21]
- (base64-encode-string (secure-hash algorithm s nil nil t) t))))
-
-(defun jabber-caps-identity-< (a b)
- (let ((a-category (jabber-xml-get-attribute a 'category))
- (b-category (jabber-xml-get-attribute b 'category)))
- (or (string< a-category b-category)
- (and (string= a-category b-category)
- (let ((a-type (jabber-xml-get-attribute a 'type))
- (b-type (jabber-xml-get-attribute b 'type)))
- (or (string< a-type b-type)
- (and (string= a-type b-type)
- (let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang))
- (b-xml:lang (jabber-xml-get-attribute b 'xml:lang)))
- (string< a-xml:lang b-xml:lang)))))))))
-
-
-(provide 'jabber-newdisco)
-
-;; arch-tag: b47c06aa-cae6-11d9-b1c0-000a95c2fcd0
diff --git a/jabber-socks5.el b/jabber-socks5.el
index ee64033..54e6a90 100644
--- a/jabber-socks5.el
+++ b/jabber-socks5.el
@@ -23,7 +23,6 @@
(require 'jabber-disco)
(require 'jabber-si-server)
(require 'jabber-si-client)
-(require 'jabber-newdisco)
(require 'fsm)
(eval-when-compile (require 'cl))
-----------------------------------------------------------------------
Summary of changes:
Makefile.am | 2 +-
jabber-ahc.el | 2 +-
jabber-chatstates.el | 2 +-
jabber-disco.el | 537 +++++++++++++++++++++++++++++++++++++++++++-----
jabber-feature-neg.el | 2 +-
jabber-ft-server.el | 2 +-
jabber-muc.el | 2 +-
jabber-newdisco.el | 399 ------------------------------------
jabber-ping.el | 2 +-
jabber-rtt.el | 4 +
jabber-si-server.el | 2 +-
jabber-socks5.el | 3 +-
jabber-time.el | 6 +-
jabber-version.el | 2 +-
jabber-widget.el | 2 +-
15 files changed, 499 insertions(+), 470 deletions(-)
delete mode 100644 jabber-newdisco.el
hooks/post-receive
--
emacs-jabber
|
