djavu-asus/elpa/jabber-20230715.456/jabber-disco.el

   1 ;; jabber-disco.el - service discovery functions  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5
   6 ;; This file is a part of jabber.el.
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21
  22 (require 'jabber-iq)
  23 (require 'jabber-xml)
  24 (require 'jabber-menu)
  25
  26 ;;; Respond to disco requests
  27
  28 ;;;###autoload
  29 (eval-after-load "jabber-core"
  30   '(add-to-list 'jabber-presence-chain #'jabber-process-caps))
  31
  32 (defvar jabber-caps-cache (make-hash-table :test 'equal))
  33
  34 (defconst jabber-caps-hash-names
  35   (if (fboundp 'secure-hash)
  36       '(("sha-1" . sha1)
  37         ("sha-224" . sha224)
  38         ("sha-256" . sha256)
  39         ("sha-384" . sha384)
  40         ("sha-512" . sha512))
  41     ;; `secure-hash' was introduced in Emacs 24.  For Emacs 23, fall
  42     ;; back to the `sha1' function, handled specially in
  43     ;; `jabber-caps--secure-hash'.
  44     '(("sha-1" . sha1)))
  45   "Hash function name map.
  46 Maps names defined in http://www.iana.org/assignments/hash-function-text-names
  47 to symbols accepted by `secure-hash'.
  48
  49 XEP-0115 currently recommends SHA-1, but let's be future-proof.")
  50
  51 (defun jabber-caps-get-cached (jid)
  52   "Get disco info from Entity Capabilities cache.
  53 JID should be a string containing a full JID.
  54 Return (IDENTITIES FEATURES), or nil if not in cache."
  55   (let* ((symbol (jabber-jid-symbol jid))
  56          (resource (or (jabber-jid-resource jid) ""))
  57          (resource-plist (cdr (assoc resource (get symbol 'resources))))
  58          (key (plist-get resource-plist 'caps)))
  59     (when key
  60       (let ((cache-entry (gethash key jabber-caps-cache)))
  61         (when (and (consp cache-entry) (not (floatp (car cache-entry))))
  62           cache-entry)))))
  63
  64 ;;;###autoload
  65 (defun jabber-process-caps (jc xml-data)
  66   "Look for entity capabilities in presence stanzas.
  67
  68 JC is the Jabber connection.
  69 XML-DATA is the parsed tree data from the stream (stanzas)
  70 obtained from `xml-parse-region'."
  71   (let* ((from (jabber-xml-get-attribute xml-data 'from))
  72          (type (jabber-xml-get-attribute xml-data 'type))
  73          (c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c")))))
  74     (when (and (null type) c)
  75       (jabber-xml-let-attributes
  76           (ext hash node ver) c
  77         (cond
  78          (hash
  79           ;; If the <c/> element has a hash attribute, it follows the
  80           ;; "modern" version of XEP-0115.
  81           (jabber-process-caps-modern jc from hash node ver))
  82          (t
  83           ;; No hash attribute.  Use legacy version of XEP-0115.
  84           ;; TODO: do something clever here.
  85           ))))))
  86
  87 (defun jabber-process-caps-modern (jc jid hash node ver)
  88   (when (assoc hash jabber-caps-hash-names)
  89     ;; We support the hash function used.
  90     (let* ((key (cons hash ver))
  91            (cache-entry (gethash key jabber-caps-cache)))
  92       ;; Remember the hash in the JID symbol.
  93       (let* ((symbol (jabber-jid-symbol jid))
  94              (resource (or (jabber-jid-resource jid) ""))
  95              (resource-entry (assoc resource (get symbol 'resources)))
  96              (new-resource-plist (plist-put (cdr resource-entry) 'caps key)))
  97         (if resource-entry
  98             (setf (cdr resource-entry) new-resource-plist)
  99           (push (cons resource new-resource-plist) (get symbol 'resources))))
 100
 101       (cl-flet ((request-disco-info
 102               ()
 103               (jabber-send-iq
 104                jc jid
 105                "get"
 106                `(query ((xmlns . "http://jabber.org/protocol/disco#info")
 107                         (node . ,(concat node "#" ver))))
 108                #'jabber-process-caps-info-result (list hash node ver)
 109                #'jabber-process-caps-info-error (list hash node ver))))
 110         (cond
 111          ((and (consp cache-entry)
 112                (floatp (car cache-entry)))
 113           ;; We have a record of asking someone about this hash.
 114           (if (< (- (float-time) (car cache-entry)) 10.0)
 115               ;; We asked someone about this hash less than 10 seconds ago.
 116               ;; Let's add the new JID to the entry, just in case that
 117               ;; doesn't work out.
 118               (cl-pushnew jid (cdr cache-entry) :test #'string=)
 119             ;; We asked someone about it more than 10 seconds ago.
 120             ;; They're probably not going to answer.  Let's ask
 121             ;; this contact about it instead.
 122             (setf (car cache-entry) (float-time))
 123             (request-disco-info)))
 124          ((null cache-entry)
 125           ;; We know nothing about this hash.  Let's note the
 126           ;; fact that we tried to get information about it.
 127           (puthash key (list (float-time)) jabber-caps-cache)
 128           (request-disco-info))
 129          (t
 130           ;; We already know what this hash represents, so we
 131           ;; can cache info for this contact.
 132           (puthash (cons jid nil) cache-entry jabber-disco-info-cache)))))))
 133
 134 (defun jabber-process-caps-info-result (jc xml-data closure-data)
 135   (cl-destructuring-bind (hash node ver) closure-data
 136     (let* ((key (cons hash ver))
 137            (query (jabber-iq-query xml-data))
 138            (verification-string (jabber-caps-ver-string query hash)))
 139       (if (string= ver verification-string)
 140           ;; The hash is correct; save info.
 141           (puthash key (jabber-disco-parse-info xml-data) jabber-caps-cache)
 142         ;; The hash is incorrect.
 143         (jabber-caps-try-next jc hash node ver)))))
 144
 145 (defun jabber-process-caps-info-error (jc xml-data closure-data)
 146   (cl-destructuring-bind (hash node ver) closure-data
 147     (jabber-caps-try-next jc hash node ver)))
 148
 149 (defun jabber-caps-try-next (jc hash node ver)
 150   (let* ((key (cons hash ver))
 151          (cache-entry (gethash key jabber-caps-cache)))
 152     (when (floatp (car-safe cache-entry))
 153       (let ((next-jid (pop (cdr cache-entry))))
 154         ;; Do we know someone else we could ask about this hash?
 155         (if next-jid
 156             (progn
 157               (setf (car cache-entry) (float-time))
 158               (jabber-send-iq
 159                jc next-jid
 160                "get"
 161                `(query ((xmlns . "http://jabber.org/protocol/disco#info")
 162                         (node . ,(concat node "#" ver))))
 163                #'jabber-process-caps-info-result (list hash node ver)
 164                #'jabber-process-caps-info-error (list hash node ver)))
 165           ;; No, forget about it for now.
 166           (remhash key jabber-caps-cache))))))
 167
 168 (defun jabber-caps-ver-string (query hash)
 169   ;; XEP-0115, section 5.1
 170   ;; 1. Initialize an empty string S.
 171   (with-temp-buffer
 172     (let* ((identities (jabber-xml-get-children query 'identity))
 173            (disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f 'var))
 174                              (jabber-xml-get-children query 'feature)))
 175            (maybe-forms (jabber-xml-get-children query 'x))
 176            (forms (cl-remove-if-not
 177                    (lambda (x)
 178                      ;; Keep elements that are forms and have a FORM_TYPE,
 179                      ;; according to XEP-0128.
 180                      (and (string= (jabber-xml-get-xmlns x) "jabber:x:data")
 181                           (jabber-xdata-formtype x)))
 182                    maybe-forms)))
 183       ;; 2. Sort the service discovery identities [15] by category
 184       ;; and then by type and then by xml:lang (if it exists),
 185       ;; formatted as CATEGORY '/' [TYPE] '/' [LANG] '/'
 186       ;; [NAME]. [16] Note that each slash is included even if the
 187       ;; LANG or NAME is not included (in accordance with XEP-0030,
 188       ;; the category and type MUST be included.
 189       (setq identities (sort identities #'jabber-caps-identity-<))
 190       ;; 3. For each identity, append the 'category/type/lang/name' to
 191       ;; S, followed by the '<' character.
 192       (dolist (identity identities)
 193         (jabber-xml-let-attributes (category type xml:lang name) identity
 194           ;; Use `concat' here instead of passing everything to
 195           ;; `insert', since `concat' tolerates nil values.
 196           (insert (concat category "/" type "/" xml:lang "/" name "<"))))
 197       ;; 4. Sort the supported service discovery features. [17]
 198       (setq disco-features (sort disco-features #'string<))
 199       ;; 5. For each feature, append the feature to S, followed by the
 200       ;; '<' character.
 201       (dolist (f disco-features)
 202         (insert f "<"))
 203       ;; 6. If the service discovery information response includes
 204       ;; XEP-0128 data forms, sort the forms by the FORM_TYPE (i.e.,
 205       ;; by the XML character data of the <value/> element).
 206       (setq forms (sort forms (lambda (a b)
 207                                 (string< (jabber-xdata-formtype a)
 208                                          (jabber-xdata-formtype b)))))
 209       ;; 7. For each extended service discovery information form:
 210       (dolist (form forms)
 211         ;; Append the XML character data of the FORM_TYPE field's
 212         ;; <value/> element, followed by the '<' character.
 213         (insert (jabber-xdata-formtype form) "<")
 214         ;; Sort the fields by the value of the "var" attribute.
 215         (let ((fields (sort (jabber-xml-get-children form 'field)
 216                             (lambda (a b)
 217                               (string< (jabber-xml-get-attribute a 'var)
 218                                        (jabber-xml-get-attribute b 'var))))))
 219           (dolist (field fields)
 220             ;; For each field other than FORM_TYPE:
 221             (unless (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
 222               ;; Append the value of the "var" attribute, followed by the '<' character.
 223               (insert (jabber-xml-get-attribute field 'var) "<")
 224               ;; Sort values by the XML character data of the <value/> element.
 225               (let ((values (sort (mapcar (lambda (value)
 226                                             (car (jabber-xml-node-children value)))
 227                                           (jabber-xml-get-children field 'value))
 228                                   #'string<)))
 229                 ;; For each <value/> element, append the XML character
 230                 ;; data, followed by the '<' character.
 231                 (dolist (value values)
 232                   (insert value "<"))))))))
 233
 234     ;; 8. Ensure that S is encoded according to the UTF-8 encoding
 235     ;; (RFC 3269 [18]).
 236     (let ((s (encode-coding-string (buffer-string) 'utf-8 t))
 237           (algorithm (cdr (assoc hash jabber-caps-hash-names))))
 238       ;; 9. Compute the verification string by hashing S using the
 239       ;; algorithm specified in the 'hash' attribute (e.g., SHA-1 as
 240       ;; defined in RFC 3174 [19]). The hashed data MUST be generated
 241       ;; with binary output and encoded using Base64 as specified in
 242       ;; Section 4 of RFC 4648 [20] (note: the Base64 output MUST NOT
 243       ;; include whitespace and MUST set padding bits to zero). [21]
 244       (base64-encode-string (jabber-caps--secure-hash algorithm s) t))))
 245
 246 (defun jabber-caps--secure-hash (algorithm string)
 247   (cond
 248    ;; `secure-hash' was introduced in Emacs 24
 249    ((fboundp 'secure-hash)
 250     (secure-hash algorithm string nil nil t))
 251    ((eq algorithm 'sha1)
 252     ;; For SHA-1, we can use the `sha1' function.
 253     (sha1 string nil nil t))
 254    (t
 255     (error "Cannot use hash algorithm %s!" algorithm))))
 256
 257 (defun jabber-caps-identity-< (a b)
 258   (let ((a-category (jabber-xml-get-attribute a 'category))
 259         (b-category (jabber-xml-get-attribute b 'category)))
 260     (or (string< a-category b-category)
 261         (and (string= a-category b-category)
 262              (let ((a-type (jabber-xml-get-attribute a 'type))
 263                    (b-type (jabber-xml-get-attribute b 'type)))
 264                (or (string< a-type b-type)
 265                    (and (string= a-type b-type)
 266                         (let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang))
 267                               (b-xml:lang (jabber-xml-get-attribute b 'xml:lang)))
 268                           (string< a-xml:lang b-xml:lang)))))))))
 269
 270 (defvar jabber-caps-default-hash-function "sha-1"
 271   "Hash function to use when sending caps in presence stanzas.
 272 The value should be a key in `jabber-caps-hash-names'.")
 273
 274 (defvar jabber-caps-current-hash nil
 275   "The current disco hash we're sending out in presence stanzas.")
 276
 277 (defconst jabber-caps-node "http://emacs-jabber.sourceforge.net")
 278
 279 ;;;###autoload
 280 (defun jabber-disco-advertise-feature (feature)
 281   (unless (member feature jabber-advertised-features)
 282     (push feature jabber-advertised-features)
 283     (when jabber-caps-current-hash
 284       (jabber-caps-recalculate-hash)
 285       ;; If we're already connected, we need to send updated presence
 286       ;; for the new feature.
 287       (mapc #'jabber-send-current-presence jabber-connections))))
 288
 289 (defun jabber-caps-recalculate-hash ()
 290   "Update `jabber-caps-current-hash' for feature list change.
 291 Also update `jabber-disco-info-nodes', so we return results for
 292 the right node."
 293   (let* ((old-hash jabber-caps-current-hash)
 294          (old-node (and old-hash (concat jabber-caps-node "#" old-hash)))
 295          (new-hash
 296           (jabber-caps-ver-string `(query () ,@(jabber-disco-return-client-info))
 297                                   jabber-caps-default-hash-function))
 298          (new-node (concat jabber-caps-node "#" new-hash)))
 299     (when old-node
 300       (let ((old-entry (assoc old-node jabber-disco-info-nodes)))
 301         (when old-entry
 302           (setq jabber-disco-info-nodes (delq old-entry jabber-disco-info-nodes)))))
 303     (push (list new-node #'jabber-disco-return-client-info nil)
 304           jabber-disco-info-nodes)
 305     (setq jabber-caps-current-hash new-hash)))
 306
 307 ;;;###autoload
 308 (defun jabber-caps-presence-element (_jc)
 309   (unless jabber-caps-current-hash
 310     (jabber-caps-recalculate-hash))
 311
 312   (list
 313    `(c ((xmlns . "http://jabber.org/protocol/caps")
 314         (hash . ,jabber-caps-default-hash-function)
 315         (node . ,jabber-caps-node)
 316         (ver . ,jabber-caps-current-hash)))))
 317
 318 ;;;###autoload
 319 (eval-after-load "jabber-presence"
 320   '(add-to-list 'jabber-presence-element-functions #'jabber-caps-presence-element))
 321
 322 (defvar jabber-advertised-features
 323   (list "http://jabber.org/protocol/disco#info")
 324   "Features advertised on service discovery requests.
 325
 326 Don't add your feature to this list directly.  Instead, call
 327 `jabber-disco-advertise-feature'.")
 328
 329 (defvar jabber-disco-items-nodes
 330   (list
 331    (list "" nil nil))
 332   "Alist of node names and information about returning disco item data.
 333 Key is node name as a string, or \"\" for no node specified.  Value is
 334 a list of two items.
 335
 336 First item is data to return.  If it is a function, that function is
 337 called and its return value is used; if it is a list, that list is
 338 used.  The list should be the XML data to be returned inside the
 339 <query/> element, like this:
 340
 341 \((item ((name . \"Name of first item\")
 342         (jid . \"first.item\")
 343         (node . \"node\"))))
 344
 345 Second item is access control function.  That function is passed the
 346 JID, and returns non-nil if access is granted.  If the second item is
 347 nil, access is always granted.")
 348
 349 (defvar jabber-disco-info-nodes
 350   (list
 351    (list "" #'jabber-disco-return-client-info nil))
 352   "Alist of node names and information returning disco info data.
 353 Key is node name as a string, or \"\" for no node specified.  Value is
 354 a list of two items.
 355
 356 First item is data to return.  If it is a function, that function is
 357 called and its return value is used; if it is a list, that list is
 358 used.  The list should be the XML data to be returned inside the
 359 <query/> element, like this:
 360
 361 \((identity ((category . \"client\")
 362             (type . \"pc\")
 363             (name . \"Jabber client\")))
 364  (feature ((var . \"some-feature\"))))
 365
 366 Second item is access control function.  That function is passed the
 367 JID, and returns non-nil if access is granted.  If the second item is
 368 nil, access is always granted.")
 369
 370 (add-to-list 'jabber-iq-get-xmlns-alist
 371              (cons "http://jabber.org/protocol/disco#info" 'jabber-return-disco-info))
 372 (add-to-list 'jabber-iq-get-xmlns-alist
 373              (cons "http://jabber.org/protocol/disco#items" 'jabber-return-disco-info))
 374 (defun jabber-return-disco-info (jc xml-data)
 375   "Respond to a service discovery request.
 376 See XEP-0030.
 377
 378 JC is the Jabber connection.
 379 XML-DATA is the parsed tree data from the stream (stanzas)
 380 obtained from `xml-parse-region'."
 381   (let* ((to (jabber-xml-get-attribute xml-data 'from))
 382          (id (jabber-xml-get-attribute xml-data 'id))
 383          (xmlns (jabber-iq-xmlns xml-data))
 384          (which-alist (eval (cdr (assoc xmlns
 385                                         (list
 386                                          (cons "http://jabber.org/protocol/disco#info" 'jabber-disco-info-nodes)
 387                                          (cons "http://jabber.org/protocol/disco#items" 'jabber-disco-items-nodes))))))
 388          (node (or
 389                 (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)
 390                 ""))
 391          (return-list (cdr (assoc node which-alist)))
 392          (func (nth 0 return-list))
 393          (access-control (nth 1 return-list)))
 394     (if return-list
 395         (if (and (functionp access-control)
 396                  (not (funcall access-control jc to)))
 397             (jabber-signal-error "Cancel" 'not-allowed)
 398           ;; Access control passed
 399           (let ((result (if (functionp func)
 400                             (funcall func jc xml-data)
 401                           func)))
 402             (jabber-send-iq jc to "result"
 403                             `(query ((xmlns . ,xmlns)
 404                                      ,@(when node
 405                                          (list (cons 'node node))))
 406                                     ,@result)
 407                             nil nil nil nil id)))
 408
 409       ;; No such node
 410       (jabber-signal-error "Cancel" 'item-not-found))))
 411
 412 (defun jabber-disco-return-client-info (&optional jc xml-data)
 413   `(
 414     ;; If running under a window system, this is
 415     ;; a GUI client.  If not, it is a console client.
 416     (identity ((category . "client")
 417                (name . "Emacs Jabber client")
 418                (type . ,(if (memq window-system
 419                                   '(x w32 mac ns))
 420                             "pc"
 421                           "console"))))
 422     ,@(mapcar
 423        #'(lambda (featurename)
 424            `(feature ((var . ,featurename))))
 425        jabber-advertised-features)))
 426
 427 (add-to-list 'jabber-jid-info-menu
 428              (cons "Send items disco query" 'jabber-get-disco-items))
 429 (defun jabber-get-disco-items (jc to &optional node)
 430   "Send a service discovery request for items.
 431
 432 JC is the Jabber connection."
 433   (interactive (list (jabber-read-account)
 434                      (jabber-read-jid-completing "Send items disco request to: " nil nil nil 'full t)
 435                      (jabber-read-node "Node (or leave empty): ")))
 436   (jabber-send-iq jc to
 437                   "get"
 438                   (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#items"))
 439                                        (if (> (length node) 0)
 440                                            (list (cons 'node node)))))
 441                   #'jabber-process-data #'jabber-process-disco-items
 442                   #'jabber-process-data "Item discovery failed"))
 443
 444 (add-to-list 'jabber-jid-info-menu
 445              (cons "Send info disco query" 'jabber-get-disco-info))
 446 (defun jabber-get-disco-info (jc to &optional node)
 447   "Send a service discovery request for info.
 448
 449 JC is the Jabber connection."
 450   (interactive (list (jabber-read-account)
 451                      (jabber-read-jid-completing "Send info disco request to: " nil nil nil 'full t)
 452                      (jabber-read-node "Node (or leave empty): ")))
 453   (jabber-send-iq jc to
 454                   "get"
 455                   (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#info"))
 456                                        (if (> (length node) 0)
 457                                            (list (cons 'node node)))))
 458                   #'jabber-process-data #'jabber-process-disco-info
 459                   #'jabber-process-data "Info discovery failed"))
 460
 461 (defun jabber-process-disco-info (jc xml-data)
 462   "Handle results from info disco requests.
 463
 464 JC is the Jabber connection.
 465 XML-DATA is the parsed tree data from the stream (stanzas)
 466 obtained from `xml-parse-region'."
 467
 468   (let ((beginning (point)))
 469     (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data)))
 470       (cond
 471        ((eq (jabber-xml-node-name x) 'identity)
 472         (let ((name (jabber-xml-get-attribute x 'name))
 473               (category (jabber-xml-get-attribute x 'category))
 474               (type (jabber-xml-get-attribute x 'type)))
 475           (insert (jabber-propertize (if name
 476                                          name
 477                                        "Unnamed")
 478                                      'face 'jabber-title-medium)
 479                   "\n\nCategory:\t" category "\n")
 480           (if type
 481               (insert "Type:\t\t" type "\n"))
 482           (insert "\n")))
 483        ((eq (jabber-xml-node-name x) 'feature)
 484         (let ((var (jabber-xml-get-attribute x 'var)))
 485           (insert "Feature:\t" var "\n")))))
 486     (put-text-property beginning (point)
 487                        'jabber-jid (jabber-xml-get-attribute xml-data 'from))
 488     (put-text-property beginning (point)
 489                        'jabber-account jc)))
 490
 491 (defun jabber-process-disco-items (jc xml-data)
 492   "Handle results from items disco requests.
 493
 494 JC is the Jabber connection.
 495 XML-DATA is the parsed tree data from the stream (stanzas)
 496 obtained from `xml-parse-region'."
 497
 498   (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))
 499     (if items
 500         (dolist (item items)
 501           (let ((jid (jabber-xml-get-attribute item 'jid))
 502                 (name (jabber-xml-get-attribute item 'name))
 503                 (node (jabber-xml-get-attribute item 'node)))
 504             (insert
 505              (jabber-propertize
 506               (concat
 507                (jabber-propertize
 508                 (concat jid "\n" (if node (format "Node: %s\n" node)))
 509                 'face 'jabber-title-medium)
 510                name "\n\n")
 511               'jabber-jid jid
 512               'jabber-account jc
 513               'jabber-node node))))
 514       (insert "No items found.\n"))))
 515
 516 ;; Keys are ("jid" . "node"), where "node" is nil if appropriate.
 517 ;; Values are (identities features), where each identity is ["name"
 518 ;; "category" "type"], and each feature is a string.
 519 (defvar jabber-disco-info-cache (make-hash-table :test 'equal))
 520
 521 ;; Keys are ("jid" . "node").  Values are (items), where each
 522 ;; item is ["name" "jid" "node"] (some values may be nil).
 523 (defvar jabber-disco-items-cache (make-hash-table :test 'equal))
 524
 525 (defun jabber-disco-get-info (jc jid node callback closure-data &optional force)
 526   "Get disco info for JID and NODE, using connection JC.
 527 Call CALLBACK with JC and CLOSURE-DATA as first and second
 528 arguments and result as third argument when result is available.
 529 On success, result is (IDENTITIES FEATURES), where each identity is [\"name\"
 530 \"category\" \"type\"], and each feature is a string.
 531 On error, result is the error node, recognizable by (eq (car result) 'error).
 532
 533 If CALLBACK is nil, just fetch data.  If FORCE is non-nil,
 534 invalidate cache and get fresh data."
 535   (when force
 536     (remhash (cons jid node) jabber-disco-info-cache))
 537   (let ((result (unless force (jabber-disco-get-info-immediately jid node))))
 538     (if result
 539         (and callback (run-with-timer 0 nil callback jc closure-data result))
 540       (jabber-send-iq jc jid
 541                       "get"
 542                       `(query ((xmlns . "http://jabber.org/protocol/disco#info")
 543                                ,@(when node `((node . ,node)))))
 544                       #'jabber-disco-got-info (cons callback closure-data)
 545                       (lambda (jc xml-data callback-data)
 546                         (when (car callback-data)
 547                           (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
 548                       (cons callback closure-data)))))
 549
 550 (defun jabber-disco-got-info (jc xml-data callback-data)
 551   (let ((jid (jabber-xml-get-attribute xml-data 'from))
 552         (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
 553                                         'node))
 554         (result (jabber-disco-parse-info xml-data)))
 555     (puthash (cons jid node) result jabber-disco-info-cache)
 556     (when (car callback-data)
 557       (funcall (car callback-data) jc (cdr callback-data) result))))
 558
 559 (defun jabber-disco-parse-info (xml-data)
 560   "Extract data from an <iq/> stanza containing a disco#info result.
 561 See `jabber-disco-get-info' for a description of the return value.
 562
 563 XML-DATA is the parsed tree data from the stream (stanzas)
 564 obtained from `xml-parse-region'."
 565   (list
 566    (mapcar
 567     #'(lambda (id)
 568         (vector (jabber-xml-get-attribute id 'name)
 569                 (jabber-xml-get-attribute id 'category)
 570                 (jabber-xml-get-attribute id 'type)))
 571     (jabber-xml-get-children (jabber-iq-query xml-data) 'identity))
 572    (mapcar
 573     #'(lambda (feature)
 574         (jabber-xml-get-attribute feature 'var))
 575     (jabber-xml-get-children (jabber-iq-query xml-data) 'feature))))
 576
 577 (defun jabber-disco-get-info-immediately (jid node)
 578   "Get cached disco info for JID and NODE.
 579 Return nil if no info available.
 580
 581 Fill the cache with `jabber-disco-get-info'."
 582   (or
 583    ;; Check "normal" cache...
 584    (gethash (cons jid node) jabber-disco-info-cache)
 585    ;; And then check Entity Capabilities.
 586    (and (null node) (jabber-caps-get-cached jid))))
 587
 588 (defun jabber-disco-get-items (jc jid node callback closure-data &optional force)
 589   "Get disco items for JID and NODE, using connection JC.
 590 Call CALLBACK with JC and CLOSURE-DATA as first and second
 591 arguments and items result as third argument when result is
 592 available.
 593 On success, result is a list of items, where each
 594 item is [\"name\" \"jid\" \"node\"] (some values may be nil).
 595 On error, result is the error node, recognizable by (eq (car result) 'error).
 596
 597 If CALLBACK is nil, just fetch data.  If FORCE is non-nil,
 598 invalidate cache and get fresh data."
 599   (when force
 600     (remhash (cons jid node) jabber-disco-items-cache))
 601   (let ((result (gethash (cons jid node) jabber-disco-items-cache)))
 602     (if result
 603         (and callback (run-with-timer 0 nil callback jc closure-data result))
 604       (jabber-send-iq jc jid
 605                       "get"
 606                       `(query ((xmlns . "http://jabber.org/protocol/disco#items")
 607                                ,@(when node `((node . ,node)))))
 608                       #'jabber-disco-got-items (cons callback closure-data)
 609                       (lambda (jc xml-data callback-data)
 610                         (when (car callback-data)
 611                           (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data))))
 612                       (cons callback closure-data)))))
 613
 614 (defun jabber-disco-got-items (jc xml-data callback-data)
 615   (let ((jid (jabber-xml-get-attribute xml-data 'from))
 616         (node (jabber-xml-get-attribute (jabber-iq-query xml-data)
 617                                         'node))
 618         (result
 619          (mapcar
 620           #'(lambda (item)
 621               (vector
 622                (jabber-xml-get-attribute item 'name)
 623                (jabber-xml-get-attribute item 'jid)
 624                (jabber-xml-get-attribute item 'node)))
 625           (jabber-xml-get-children (jabber-iq-query xml-data) 'item))))
 626     (puthash (cons jid node) result jabber-disco-items-cache)
 627     (when (car callback-data)
 628       (funcall (car callback-data) jc (cdr callback-data) result))))
 629
 630 (defun jabber-disco-get-items-immediately (jid node)
 631   (gethash (cons jid node) jabber-disco-items-cache))
 632
 633 (defun jabber-disco-publish (jc node item-name item-jid item-node)
 634   "Publish the given item under disco node NODE."
 635   (jabber-send-iq jc nil
 636                   "set"
 637                   `(query ((xmlns . "http://jabber.org/protocol/disco#items")
 638                            ,@(when node `((node . ,node))))
 639                           (item ((action . "update")
 640                                  (jid . ,item-jid)
 641                                  ,@(when item-name
 642                                      `((name . ,item-name)))
 643                                  ,@(when item-node
 644                                      `((node . ,item-node))))))
 645                   'jabber-report-success "Disco publish"
 646                   'jabber-report-success "Disco publish"))
 647
 648 (defun jabber-disco-publish-remove (jc node item-jid item-node)
 649   "Remove the given item from published disco items.
 650
 651 JC is the Jabber connection."
 652   (jabber-send-iq jc nil
 653                   "set"
 654                   `(query ((xmlns . "http://jabber.org/protocol/disco#items")
 655                            ,@(when node `((node . ,node))))
 656                           (item ((action . "remove")
 657                                  (jid . ,item-jid)
 658                                  ,@(when item-node
 659                                      `((node . ,item-node))))))
 660                   'jabber-report-success "Disco removal"
 661                   'jabber-report-success "Disco removal"))
 662
 663 (provide 'jabber-disco)
 664
 665 ;;; arch-tag: 71f5c76f-2956-4ed2-b871-9f5fe198092d