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

1 ;;; jabber-vcard.el --- vcards according to JEP-0054 -*- lexical-binding: t; -*-

5 ;; Author: Magnus Henoch <mange@freemail.hu>

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

9 ;; This program is free software; you can redistribute it and/or modify

10 ;; it under the terms of the GNU General Public License as published by

11 ;; the Free Software Foundation; either version 2, or (at your option)

12 ;; any later version.

14 ;; This program is distributed in the hope that it will be useful,

15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of

16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

17 ;; GNU General Public License for more details.

19 ;; You should have received a copy of the GNU General Public License

20 ;; along with GNU Emacs; see the file COPYING. If not, write to

21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,

22 ;; Boston, MA 02111-1307, USA.

24 ;;; Commentary:

26 ;; There are great variations in Jabber vcard implementations. This

27 ;; one adds some spice to the mix, while trying to follow the JEP

28 ;; closely.

30 ;; Fields not implemented: GEO, LOGO, AGENT, ORG, CATEGORIES, SOUND,

31 ;; CLASS, KEY.

33 ;; The internal data structure used for vCards is an alist. All

34 ;; keys are uppercase symbols.

35 ;;

36 ;; FN, NICKNAME, BDAY, JABBERID, MAILER, TZ, TITLE, ROLE, NOTE,

37 ;; PRODID, REV, SORT-STRING, UID, URL, DESC:

38 ;; Value is a string.

39 ;;

40 ;; N:

41 ;; Value is an alist, with keys FAMILY, GIVEN, MIDDLE, PREFIX and SUFFIX.

42 ;;

43 ;; ADR:

44 ;; Value is a list, each element representing a separate address.

45 ;; The car of each address is a list of types; possible values are

46 ;; HOME, WORK, POSTAL, PARCEL, DOM, INTL, PREF.

47 ;; The cdr of each address is an alist, with keys POBOX, EXTADD,

48 ;; STREET, LOCALITY, REGION, PCODE, CTRY, and values being strings.

49 ;;

50 ;; TEL:

51 ;; Value is a list, each element representing a separate phone number.

52 ;; The car of each number is a list of types; possible values are

53 ;; HOME, WORK, VOICE, FAX, PAGER, MSG, CELL, VIDEO, BBS, MODEM, ISDN,

54 ;; PCS, PREF

55 ;; The cdr is the phone number as a string.

56 ;;

57 ;; EMAIL:

58 ;; Value is a list, each element representing a separate e-mail address.

59 ;; The car of each address is a list of types; possible values are

60 ;; HOME, WORK, INTERNET, PREF, X400. At least one of INTERNET and

61 ;; X400 is always present.

62 ;; The cdr is the address as a string.

64 ;;; Code:

66 (require 'jabber-core)

67 (require 'jabber-widget)

68 (require 'jabber-iq)

69 (require 'jabber-avatar)

71 (defvar jabber-vcard-photo nil

72 "The avatar structure for the photo in the vCard edit buffer.")

73 (make-variable-buffer-local 'jabber-vcard-photo)

75 (defun jabber-vcard-parse (vcard)

76 "Parse the vCard XML structure given in VCARD.

77 The top node should be the `vCard' node."

78 ;; Hm... stpeter has a <query/> as top node...

79 ;;(unless (eq (jabber-xml-node-name vcard) 'vCard)

80 ;; (error "Invalid vCard"))

81 (let (result)

82 (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ

83 TITLE ROLE NOTE PRODID REV SORT-STRING

84 UID URL DESC))

85 ;; There should only be one of each of these. They are

86 ;; used verbatim.

87 (let ((node (car (jabber-xml-get-children vcard

88 verbatim-node))))

89 ;; Some clients include the node, but without data

90 (when (car (jabber-xml-node-children node))

91 (push (cons (jabber-xml-node-name node)

92 (car (jabber-xml-node-children node)))

93 result))))

95 ;; Name components

96 (let ((node (car (jabber-xml-get-children vcard 'N))))

97 ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX

98 (push (cons 'N

99 (let (name)

100 (dolist (subnode (jabber-xml-node-children node))

101 (when (and (memq (jabber-xml-node-name subnode)

102 '(FAMILY GIVEN MIDDLE PREFIX SUFFIX))

103 (not (zerop (length

104 (car (jabber-xml-node-children

105 subnode))))))

106 (push (cons (jabber-xml-node-name subnode)

107 (car (jabber-xml-node-children

108 subnode)))

109 name)))

110 name))

111 result))

112

113 ;; There can be several addresses

114 (let (addresses)

115 (dolist (adr (jabber-xml-get-children vcard 'ADR))

116 ;; Find address type(s)

117 (let (types)

118 (dolist (possible-type '(HOME WORK POSTAL PARCEL DOM INTL PREF))

119 (when (jabber-xml-get-children adr possible-type)

120 (push possible-type types)))

121

122 (let (components)

123 (dolist (component (jabber-xml-node-children adr))

124 (when (and (memq (jabber-xml-node-name component)

125 '(POBOX EXTADD STREET LOCALITY REGION

126 PCODE CTRY))

127 (not (zerop (length

128 (car (jabber-xml-node-children

129 component))))))

130 (push (cons (jabber-xml-node-name component)

131 (car (jabber-xml-node-children component)))

132 components)))

133

134 (push (cons types components) addresses))))

135

136 (when addresses

137 (push (cons 'ADR addresses) result)))

138

139 ;; Likewise for phone numbers

140 (let (phone-numbers)

141 (dolist (tel (jabber-xml-get-children vcard 'TEL))

142 ;; Find phone type(s)

143 (let ((number (car (jabber-xml-node-children

144 (car (jabber-xml-get-children tel 'NUMBER)))))

145 types)

146 ;; Some clients put no NUMBER node. Avoid that.

147 (when number

148 (dolist (possible-type '(HOME WORK VOICE FAX PAGER MSG CELL

149 VIDEO BBS MODEM ISDN PCS PREF))

150 (when (jabber-xml-get-children tel possible-type)

151 (push possible-type types)))

152

153 (push (cons types number) phone-numbers))))

154

155 (when phone-numbers

156 (push (cons 'TEL phone-numbers) result)))

157

158 ;; And for e-mail addresses

159 (let (e-mails)

160 (dolist (email (jabber-xml-get-children vcard 'EMAIL))

161 (let ((userid (car (jabber-xml-node-children

162 (car (jabber-xml-get-children email 'USERID)))))

163 types)

164 ;; Some clients put no USERID node. Avoid that.

165 (when userid

166 (dolist (possible-type '(HOME WORK INTERNET PREF X400))

167 (when (jabber-xml-get-children email possible-type)

168 (push possible-type types)))

169 (unless (or (memq 'INTERNET types)

170 (memq 'X400 types))

171 (push 'INTERNET types))

172

173 (push (cons types userid) e-mails))))

174

175 (when e-mails

176 (push (cons 'EMAIL e-mails) result)))

177

178 ;; XEP-0153: vCard-based avatars

179 (let ((photo-tag (car (jabber-xml-get-children vcard 'PHOTO))))

180 (when photo-tag

181 (let ((type (jabber-xml-path photo-tag '(TYPE "")))

182 (binval (jabber-xml-path photo-tag '(BINVAL ""))))

183 (when (and type binval)

184 (push (list 'PHOTO type binval) result)))))

185

186 result))

187

188 (defun jabber-vcard-reassemble (parsed)

189 "Create a vCard XML structure from PARSED."

190 ;; Save photo in jabber-vcard-photo, to avoid excessive processing.

191 (let ((photo (cdr (assq 'PHOTO parsed))))

192 (cond

193 ;; No photo

194 ((null photo)

195 (setq jabber-vcard-photo nil))

196 ;; Existing photo

197 ((listp photo)

198 (setq jabber-vcard-photo

199 (jabber-avatar-from-base64-string

200 (nth 1 photo) (nth 0 photo))))

201 ;; New photo from file

202 (t

203 (access-file photo "Avatar file not found")

204 ;; Maximum allowed size is 8 kilobytes

205 (when (> (nth 7 (file-attributes photo)) 8192)

206 (error "Avatar bigger than 8 kilobytes"))

207 (setq jabber-vcard-photo (jabber-avatar-from-file photo)))))

208

209 `(vCard ((xmlns . "vcard-temp"))

210 ;; Put in simple fields

211 ,@(mapcar

212 (lambda (field)

213 (when (and (assq (car field) jabber-vcard-fields)

214 (not (zerop (length (cdr field)))))

215 (list (car field) nil (cdr field))))

216 parsed)

217 ;; Put in decomposited name

218 (N nil

219 ,@(mapcar

220 (lambda (name-part)

221 (when (not (zerop (length (cdr name-part))))

222 (list (car name-part) nil (cdr name-part))))

223 (cdr (assq 'N parsed))))

224 ;; Put in addresses

225 ,@(mapcar

226 (lambda (address)

227 (append '(ADR) '(())

228 (mapcar 'list (nth 0 address))

229 (mapcar (lambda (field)

230 (list (car field) nil (cdr field)))

231 (cdr address))))

232 (cdr (assq 'ADR parsed)))

233 ;; Put in phone numbers

234 ,@(mapcar

235 (lambda (phone)

236 (append '(TEL) '(())

237 (mapcar 'list (car phone))

238 (list (list 'NUMBER nil (cdr phone)))))

239 (cdr (assq 'TEL parsed)))

240 ;; Put in e-mail addresses

241 ,@(mapcar

242 (lambda (email)

243 (append '(EMAIL) '(())

244 (mapcar 'list (car email))

245 (list (list 'USERID nil (cdr email)))))

246 (cdr (assq 'EMAIL parsed)))

247 ;; Put in photo

248 ,@(when jabber-vcard-photo

249 `((PHOTO ()

250 (TYPE () ,(avatar-mime-type jabber-vcard-photo))

251 (BINVAL () ,(avatar-base64-data jabber-vcard-photo)))))))

252

253 (add-to-list 'jabber-jid-info-menu

254 (cons "Request vcard" 'jabber-vcard-get))

255

256 (defun jabber-vcard-get (jc jid)

257 "Request vcard from JID.

258

259 JC is the Jabber connection."

260 (interactive (list (jabber-read-account)

261 (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc)))

262 (jabber-send-iq jc jid

263 "get"

264 '(vCard ((xmlns . "vcard-temp")))

265 #'jabber-process-data #'jabber-vcard-display

266 #'jabber-process-data "Vcard request failed"))

267

268 (defun jabber-vcard-edit (jc)

269 "Edit your own vcard.

270

271 JC is the Jabber connection."

272 (interactive (list (jabber-read-account)))

273 (jabber-send-iq jc nil

274 "get"

275 '(vCard ((xmlns . "vcard-temp")))

276 #'jabber-vcard-do-edit nil

277 #'jabber-report-success "Vcard request failed"))

278

279 (defconst jabber-vcard-fields '((FN . "Full name")

280 (NICKNAME . "Nickname")

281 (BDAY . "Birthday")

282 (URL . "URL")

283 (JABBERID . "JID")

284 (MAILER . "User agent")

285 (TZ . "Time zone")

286 (TITLE . "Title")

287 (ROLE . "Role")

288 (REV . "Last changed")

289 (DESC . "Description")

290 (NOTE . "Note")))

291

292 (defconst jabber-vcard-name-fields '((PREFIX . "Prefix")

293 (GIVEN . "Given name")

294 (MIDDLE . "Middle name")

295 (FAMILY . "Family name")

296 (SUFFIX . "Suffix")))

297

298 (defconst jabber-vcard-phone-types '((HOME . "Home")

299 (WORK . "Work")

300 (VOICE . "Voice")

301 (FAX . "Fax")

302 (PAGER . "Pager")

303 (MSG . "Message")

304 (CELL . "Cell phone")

305 (VIDEO . "Video")

306 (BBS . "BBS")

307 (MODEM . "Modem")

308 (ISDN . "ISDN")

309 (PCS . "PCS")))

310

311 (defconst jabber-vcard-email-types '((HOME . "Home")

312 (WORK . "Work")

313 (INTERNET . "Internet")

314 (X400 . "X400")

315 (PREF . "Preferred")))

316

317 (defconst jabber-vcard-address-types '((HOME . "Home")

318 (WORK . "Work")

319 (POSTAL . "Postal")

320 (PARCEL . "Parcel")

321 (DOM . "Domestic")

322 (INTL . "International")

323 (PREF . "Preferred")))

324

325 (defconst jabber-vcard-address-fields '((POBOX . "Post box")

326 (EXTADD . "Ext. address")

327 (STREET . "Street")

328 (LOCALITY . "Locality")

329 (REGION . "Region")

330 (PCODE . "Post code")

331 (CTRY . "Country")))

332

333 (defun jabber-vcard-display (jc xml-data)

334 "Display received vcard.

335

336 JC is the Jabber connection.

337 XML-DATA is the parsed tree data from the stream (stanzas)

338 obtained from `xml-parse-region'."

339 (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))))

340 (dolist (simple-field jabber-vcard-fields)

341 (let ((field (assq (car simple-field) parsed)))

342 (when field

343 (insert (cdr simple-field))

344 (indent-to 20)

345 (insert (cdr field) "\n"))))

346

347 (let ((names (cdr (assq 'N parsed))))

348 (when names

349 (insert "\n")

350 (dolist (name-field jabber-vcard-name-fields)

351 (let ((field (assq (car name-field) names)))

352 (when field

353 (insert (cdr name-field))

354 (indent-to 20)

355 (insert (cdr field) "\n"))))))

356

357 (let ((email-addresses (cdr (assq 'EMAIL parsed))))

358 (when email-addresses

359 (insert "\n")

360 (insert (jabber-propertize "E-mail addresses:\n"

361 'face 'jabber-title-medium))

362 (dolist (email email-addresses)

363 (insert (mapconcat (lambda (type)

364 (cdr (assq type jabber-vcard-email-types)))

365 (car email)

366 " "))

367 (insert ": " (cdr email) "\n"))))

368

369 (let ((phone-numbers (cdr (assq 'TEL parsed))))

370 (when phone-numbers

371 (insert "\n")

372 (insert (jabber-propertize "Phone numbers:\n"

373 'face 'jabber-title-medium))

374 (dolist (number phone-numbers)

375 (insert (mapconcat (lambda (type)

376 (cdr (assq type jabber-vcard-phone-types)))

377 (car number)

378 " "))

379 (insert ": " (cdr number) "\n"))))

380

381 (let ((addresses (cdr (assq 'ADR parsed))))

382 (when addresses

383 (insert "\n")

384 (insert (jabber-propertize "Addresses:\n"

385 'face 'jabber-title-medium))

386 (dolist (address addresses)

387 (insert (jabber-propertize

388 (mapconcat (lambda (type)

389 (cdr (assq type jabber-vcard-address-types)))

390 (car address)

391 " ")

392 'face 'jabber-title-small))

393 (insert "\n")

394 (dolist (address-field jabber-vcard-address-fields)

395 (let ((field (assq (car address-field) address)))

396 (when field

397 (insert (cdr address-field))

398 (indent-to 20)

399 (insert (cdr field) "\n")))))))

400

401 ;; XEP-0153: vCard-based avatars

402 (let ((photo-type (nth 1 (assq 'PHOTO parsed)))

403 (photo-binval (nth 2 (assq 'PHOTO parsed))))

404 (when (and photo-type photo-binval)

405 (condition-case nil

406 ;; ignore the type, let create-image figure it out.

407 (let ((image (jabber-create-image (base64-decode-string photo-binval) nil t)))

408 (insert-image image "[Photo]")

409 (insert "\n"))

410 (error (insert "Couldn't display photo\n")))))))

411

412 (defun jabber-vcard-do-edit (jc xml-data closure-data)

413 (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))

414 start-position)

415 (with-current-buffer (get-buffer-create "Edit vcard")

416 (jabber-init-widget-buffer nil)

417

418 (setq jabber-buffer-connection jc)

419

420 (setq start-position (point))

421

422 (dolist (simple-field jabber-vcard-fields)

423 (widget-insert (cdr simple-field))

424 (indent-to 15)

425 (let ((default-value (cdr (assq (car simple-field) parsed))))

426 (push (cons (car simple-field)

427 (widget-create 'editable-field (or default-value "")))

428 jabber-widget-alist)))

429

430 (widget-insert "\n")

431 (push (cons 'N

432 (widget-create

433 '(set :tag "Decomposited name"

434 (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v"))

435 (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v"))

436 (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v"))

437 (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v"))

438 (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v")))

439 :value (cdr (assq 'N parsed))))

440 jabber-widget-alist)

441

442 (widget-insert "\n")

443 (push (cons 'ADR

444 (widget-create

445 '(repeat :tag "Postal addresses"

446 (cons

447 :tag "Address"

448 (set :tag "Type"

449 (const :tag "Home" HOME)

450 (const :tag "Work" WORK)

451 (const :tag "Postal" POSTAL)

452 (const :tag "Parcel" PARCEL)

453 (const :tag "Domestic" DOM)

454 (const :tag "International" INTL)

455 (const :tag "Preferred" PREF))

456 (set

457 :tag "Address"

458 (cons :tag "Post box" :format "%t: %v"

459 (const :format "" POBOX) (string :format "%v"))

460 (cons :tag "Ext. address" :format "%t: %v"

461 (const :format "" EXTADD) (string :format "%v"))

462 (cons :tag "Street" :format "%t: %v"

463 (const :format "" STREET) (string :format "%v"))

464 (cons :tag "Locality" :format "%t: %v"

465 (const :format "" LOCALITY) (string :format "%v"))

466 (cons :tag "Region" :format "%t: %v"

467 (const :format "" REGION) (string :format "%v"))

468 (cons :tag "Post code" :format "%t: %v"

469 (const :format "" PCODE) (string :format "%v"))

470 (cons :tag "Country" :format "%t: %v"

471 (const :format "" CTRY) (string :format "%v")))))

472 :value (cdr (assq 'ADR parsed))))

473 jabber-widget-alist)

474

475 (widget-insert "\n")

476 (push (cons 'TEL

477 (widget-create

478 '(repeat :tag "Phone numbers"

479 (cons :tag "Number"

480 (set :tag "Type"

481 (const :tag "Home" HOME)

482 (const :tag "Work" WORK)

483 (const :tag "Voice" VOICE)

484 (const :tag "Fax" FAX)

485 (const :tag "Pager" PAGER)

486 (const :tag "Message" MSG)

487 (const :tag "Cell phone" CELL)

488 (const :tag "Video" VIDEO)

489 (const :tag "BBS" BBS)

490 (const :tag "Modem" MODEM)

491 (const :tag "ISDN" ISDN)

492 (const :tag "PCS" PCS))

493 (string :tag "Number")))

494 :value (cdr (assq 'TEL parsed))))

495 jabber-widget-alist)

496

497 (widget-insert "\n")

498 (push (cons 'EMAIL

499 (widget-create

500 '(repeat :tag "E-mail addresses"

501 (cons :tag "Address"

502 (set :tag "Type"

503 (const :tag "Home" HOME)

504 (const :tag "Work" WORK)

505 (const :tag "Internet" INTERNET)

506 (const :tag "X400" X400)

507 (const :tag "Preferred" PREF))

508 (string :tag "Address")))

509 :value (cdr (assq 'EMAIL parsed))))

510 jabber-widget-alist)

511

512 (widget-insert "\n")

513 (widget-insert "Photo/avatar:\n")

514 (let* ((photo (assq 'PHOTO parsed))

515 (avatar (when photo

516 (jabber-avatar-from-base64-string (nth 2 photo)

517 (nth 1 photo)))))

518 (push (cons

519 'PHOTO

520 (widget-create

521 `(radio-button-choice (const :tag "None" nil)

522 ,@(when photo

523 (list

524 `(const :tag

525 ,(concat

526 "Existing: "

527 (jabber-propertize " "

528 'display (jabber-avatar-image avatar)))

529 ,(cdr photo))))

530 (file :must-match t :tag "From file"))

531 :value (cdr photo)))

532 jabber-widget-alist))

533

534 (widget-insert "\n")

535 (widget-create 'push-button :notify #'jabber-vcard-submit "Submit")

536

537 (widget-setup)

538 (widget-minor-mode 1)

539 (switch-to-buffer (current-buffer))

540 (goto-char start-position))))

541

542 (defun jabber-vcard-submit (&rest ignore)

543 (let ((to-publish (jabber-vcard-reassemble

544 (mapcar (lambda (entry)

545 (cons (car entry) (widget-value (cdr entry))))

546 jabber-widget-alist))))

547 (jabber-send-iq jabber-buffer-connection nil

548 "set"

549 to-publish

550 #'jabber-report-success "Changing vCard"

551 #'jabber-report-success "Changing vCard")

552 (when (bound-and-true-p jabber-vcard-avatars-publish)

553 (jabber-vcard-avatars-update-current

554 jabber-buffer-connection

555 (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo))))))

556

557 (provide 'jabber-vcard)

558 ;; arch-tag: 65B95E9C-63BD-11D9-94A9-000A95C2FCD0