Move Entity Capabilities before first use of jabber-disco-advertise-feature
This commit is contained in:
contrapunctus
parent
a31d7920d7
commit
75a78f7788
580
jabber.el
580
jabber.el
|
|
@ -6339,6 +6339,296 @@ Signal an error if there is no JID at point."
|
|||
(get jid 'groups))
|
||||
:test 'string=)))))
|
||||
|
||||
;;;###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
|
||||
(if (fboundp 'secure-hash)
|
||||
'(("sha-1" . sha1)
|
||||
("sha-224" . sha224)
|
||||
("sha-256" . sha256)
|
||||
("sha-384" . sha384)
|
||||
("sha-512" . sha512))
|
||||
;; `secure-hash' was introduced in Emacs 24. For Emacs 23, fall
|
||||
;; back to the `sha1' function, handled specially in
|
||||
;; `jabber-caps--secure-hash'.
|
||||
'(("sha-1" . sha1)))
|
||||
"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))
|
||||
(type (jabber-xml-get-attribute xml-data 'type))
|
||||
(c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
|
||||
(when (and (null type) 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 (list hash node ver)
|
||||
#'jabber-process-caps-info-error (list hash node ver)))
|
||||
;; 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))
|
||||
(disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f '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 disco-features (sort disco-features #'string<))
|
||||
;; 5. For each feature, append the feature to S, followed by the
|
||||
;; '<' character.
|
||||
(dolist (f disco-features)
|
||||
(insert f "<"))
|
||||
;; 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 (jabber-caps--secure-hash algorithm s) t))))
|
||||
|
||||
(defun jabber-caps--secure-hash (algorithm string)
|
||||
(cond
|
||||
;; `secure-hash' was introduced in Emacs 24
|
||||
((fboundp 'secure-hash)
|
||||
(secure-hash algorithm string nil nil t))
|
||||
((eq algorithm 'sha1)
|
||||
;; For SHA-1, we can use the `sha1' function.
|
||||
(sha1 string nil nil t))
|
||||
(t
|
||||
(error "Cannot use hash algorithm %s!" algorithm))))
|
||||
|
||||
(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)))))))))
|
||||
|
||||
(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)
|
||||
(unless (member feature jabber-advertised-features)
|
||||
(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))
|
||||
|
||||
(defvar jabber-advertised-features
|
||||
(list "http://jabber.org/protocol/disco#info")
|
||||
"Features advertised on service discovery requests
|
||||
|
|
@ -6829,296 +7119,6 @@ accounts."
|
|||
(dolist (c jabber-connections)
|
||||
(ignore-errors (jabber-send-string c " "))))
|
||||
|
||||
;;;###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
|
||||
(if (fboundp 'secure-hash)
|
||||
'(("sha-1" . sha1)
|
||||
("sha-224" . sha224)
|
||||
("sha-256" . sha256)
|
||||
("sha-384" . sha384)
|
||||
("sha-512" . sha512))
|
||||
;; `secure-hash' was introduced in Emacs 24. For Emacs 23, fall
|
||||
;; back to the `sha1' function, handled specially in
|
||||
;; `jabber-caps--secure-hash'.
|
||||
'(("sha-1" . sha1)))
|
||||
"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))
|
||||
(type (jabber-xml-get-attribute xml-data 'type))
|
||||
(c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
|
||||
(when (and (null type) 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 (list hash node ver)
|
||||
#'jabber-process-caps-info-error (list hash node ver)))
|
||||
;; 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))
|
||||
(disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f '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 disco-features (sort disco-features #'string<))
|
||||
;; 5. For each feature, append the feature to S, followed by the
|
||||
;; '<' character.
|
||||
(dolist (f disco-features)
|
||||
(insert f "<"))
|
||||
;; 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 (jabber-caps--secure-hash algorithm s) t))))
|
||||
|
||||
(defun jabber-caps--secure-hash (algorithm string)
|
||||
(cond
|
||||
;; `secure-hash' was introduced in Emacs 24
|
||||
((fboundp 'secure-hash)
|
||||
(secure-hash algorithm string nil nil t))
|
||||
((eq algorithm 'sha1)
|
||||
;; For SHA-1, we can use the `sha1' function.
|
||||
(sha1 string nil nil t))
|
||||
(t
|
||||
(error "Cannot use hash algorithm %s!" algorithm))))
|
||||
|
||||
(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)))))))))
|
||||
|
||||
(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)
|
||||
(unless (member feature jabber-advertised-features)
|
||||
(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))
|
||||
|
||||
(require 'cl)
|
||||
|
||||
(jabber-disco-advertise-feature "http://jabber.org/protocol/feature-neg")
|
||||
|
|
|
|||
704
jabber.org
704
jabber.org
|
|
@ -7942,6 +7942,358 @@ Signal an error if there is no JID at point."
|
|||
(get jid 'groups))
|
||||
:test 'string=)))))
|
||||
|
||||
#+END_SRC
|
||||
*** Entity Capabilities ([[https://xmpp.org/extensions/xep-0115.html][XEP-0115]])
|
||||
:PROPERTIES:
|
||||
:file: jabber-disco.el
|
||||
:END:
|
||||
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###autoload
|
||||
(eval-after-load "jabber-core"
|
||||
'(add-to-list 'jabber-presence-chain #'jabber-process-caps))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-cache :variable:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defvar jabber-caps-cache (make-hash-table :test 'equal))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-hash-names :constant:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defconst jabber-caps-hash-names
|
||||
(if (fboundp 'secure-hash)
|
||||
'(("sha-1" . sha1)
|
||||
("sha-224" . sha224)
|
||||
("sha-256" . sha256)
|
||||
("sha-384" . sha384)
|
||||
("sha-512" . sha512))
|
||||
;; `secure-hash' was introduced in Emacs 24. For Emacs 23, fall
|
||||
;; back to the `sha1' function, handled specially in
|
||||
;; `jabber-caps--secure-hash'.
|
||||
'(("sha-1" . sha1)))
|
||||
"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.")
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-get-cached :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###autoload
|
||||
(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 (and (null type) 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.
|
||||
))))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps-modern :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps-info-result :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps-info-error :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-try-next :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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 (list hash node ver)
|
||||
#'jabber-process-caps-info-error (list hash node ver)))
|
||||
;; No, forget about it for now.
|
||||
(remhash key jabber-caps-cache))))))
|
||||
|
||||
#+END_SRC
|
||||
|
||||
**** entity capabilities utility functions
|
||||
***** jabber-caps-ver-string :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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))
|
||||
(disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f '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 disco-features (sort disco-features #'string<))
|
||||
;; 5. For each feature, append the feature to S, followed by the
|
||||
;; '<' character.
|
||||
(dolist (f disco-features)
|
||||
(insert f "<"))
|
||||
;; 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 (jabber-caps--secure-hash algorithm s) t))))
|
||||
|
||||
#+END_SRC
|
||||
***** jabber-caps--secure-hash :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defun jabber-caps--secure-hash (algorithm string)
|
||||
(cond
|
||||
;; `secure-hash' was introduced in Emacs 24
|
||||
((fboundp 'secure-hash)
|
||||
(secure-hash algorithm string nil nil t))
|
||||
((eq algorithm 'sha1)
|
||||
;; For SHA-1, we can use the `sha1' function.
|
||||
(sha1 string nil nil t))
|
||||
(t
|
||||
(error "Cannot use hash algorithm %s!" algorithm))))
|
||||
|
||||
#+END_SRC
|
||||
***** jabber-caps-identity-< :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))))))
|
||||
|
||||
#+END_SRC
|
||||
|
||||
**** sending entity capabilities
|
||||
***** jabber-caps-default-hash-function :variable:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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'.")
|
||||
|
||||
#+END_SRC
|
||||
***** jabber-caps-current-hash :variable:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defvar jabber-caps-current-hash nil
|
||||
"The current disco hash we're sending out in presence stanzas.")
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-node :constant:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defconst jabber-caps-node "http://emacs-jabber.sourceforge.net")
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-disco-advertise-feature :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###autoload
|
||||
(defun jabber-disco-advertise-feature (feature)
|
||||
(unless (member feature jabber-advertised-features)
|
||||
(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))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-recalculate-hash :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-presence-element :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###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))
|
||||
|
||||
#+END_SRC
|
||||
*** Service Discovery ([[https://xmpp.org/extensions/xep-0030.html][XEP-0030]])
|
||||
:PROPERTIES:
|
||||
|
|
@ -8597,358 +8949,6 @@ accounts."
|
|||
|
||||
#+END_SRC
|
||||
|
||||
*** Entity Capabilities ([[https://xmpp.org/extensions/xep-0115.html][XEP-0115]])
|
||||
:PROPERTIES:
|
||||
:file: jabber-disco.el
|
||||
:END:
|
||||
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###autoload
|
||||
(eval-after-load "jabber-core"
|
||||
'(add-to-list 'jabber-presence-chain #'jabber-process-caps))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-cache :variable:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defvar jabber-caps-cache (make-hash-table :test 'equal))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-hash-names :constant:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defconst jabber-caps-hash-names
|
||||
(if (fboundp 'secure-hash)
|
||||
'(("sha-1" . sha1)
|
||||
("sha-224" . sha224)
|
||||
("sha-256" . sha256)
|
||||
("sha-384" . sha384)
|
||||
("sha-512" . sha512))
|
||||
;; `secure-hash' was introduced in Emacs 24. For Emacs 23, fall
|
||||
;; back to the `sha1' function, handled specially in
|
||||
;; `jabber-caps--secure-hash'.
|
||||
'(("sha-1" . sha1)))
|
||||
"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.")
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-get-cached :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###autoload
|
||||
(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 (and (null type) 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.
|
||||
))))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps-modern :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps-info-result :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-process-caps-info-error :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-try-next :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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 (list hash node ver)
|
||||
#'jabber-process-caps-info-error (list hash node ver)))
|
||||
;; No, forget about it for now.
|
||||
(remhash key jabber-caps-cache))))))
|
||||
|
||||
#+END_SRC
|
||||
|
||||
**** entity capabilities utility functions
|
||||
***** jabber-caps-ver-string :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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))
|
||||
(disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f '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 disco-features (sort disco-features #'string<))
|
||||
;; 5. For each feature, append the feature to S, followed by the
|
||||
;; '<' character.
|
||||
(dolist (f disco-features)
|
||||
(insert f "<"))
|
||||
;; 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 (jabber-caps--secure-hash algorithm s) t))))
|
||||
|
||||
#+END_SRC
|
||||
***** jabber-caps--secure-hash :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defun jabber-caps--secure-hash (algorithm string)
|
||||
(cond
|
||||
;; `secure-hash' was introduced in Emacs 24
|
||||
((fboundp 'secure-hash)
|
||||
(secure-hash algorithm string nil nil t))
|
||||
((eq algorithm 'sha1)
|
||||
;; For SHA-1, we can use the `sha1' function.
|
||||
(sha1 string nil nil t))
|
||||
(t
|
||||
(error "Cannot use hash algorithm %s!" algorithm))))
|
||||
|
||||
#+END_SRC
|
||||
***** jabber-caps-identity-< :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))))))))
|
||||
|
||||
#+END_SRC
|
||||
|
||||
**** sending entity capabilities
|
||||
***** jabber-caps-default-hash-function :variable:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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'.")
|
||||
|
||||
#+END_SRC
|
||||
***** jabber-caps-current-hash :variable:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defvar jabber-caps-current-hash nil
|
||||
"The current disco hash we're sending out in presence stanzas.")
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-node :constant:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defconst jabber-caps-node "http://emacs-jabber.sourceforge.net")
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-disco-advertise-feature :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###autoload
|
||||
(defun jabber-disco-advertise-feature (feature)
|
||||
(unless (member feature jabber-advertised-features)
|
||||
(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))))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-recalculate-hash :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(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)))
|
||||
|
||||
#+END_SRC
|
||||
**** jabber-caps-presence-element :function:
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
;;;###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))
|
||||
|
||||
#+END_SRC
|
||||
*** Feature Negotiation ([[https://xmpp.org/extensions/xep-0020.html][XEP-0020]]) :xep_deprecated:
|
||||
:PROPERTIES:
|
||||
:file: jabber-feature-neg.el
|
||||
|
|
|
|||
Loading…
Reference in New Issue