crepu.dev Git - config.git/blob - djavu-asus/emacs/elpa/jabber-20230715.456/jabber-disco.el

1 ;; jabber-disco.el - service discovery functions -*- lexical-binding: t; -*-

6 ;; This file is a part of jabber.el.

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.

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.

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

22 (require 'jabber-iq)

23 (require 'jabber-xml)

24 (require 'jabber-menu)

26 ;;; Respond to disco requests

28 ;;;###autoload

29 (eval-after-load "jabber-core"

30 '(add-to-list 'jabber-presence-chain #'jabber-process-caps))

32 (defvar jabber-caps-cache (make-hash-table :test 'equal))

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'.

49 XEP-0115 currently recommends SHA-1, but let's be future-proof.")

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)))))

64 ;;;###autoload

65 (defun jabber-process-caps (jc xml-data)

66 "Look for entity capabilities in presence stanzas.

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 ))))))

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