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

   1 ;;; jabber-vcard.el --- vcards according to JEP-0054  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2005, 2007  Magnus Henoch
   4
   5 ;; Author: Magnus Henoch <mange@freemail.hu>
   6
   7 ;; This file is a part of jabber.el.
   8
   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.
  13
  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.
  18
  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.
  23
  24 ;;; Commentary:
  25
  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.
  29
  30 ;; Fields not implemented: GEO, LOGO, AGENT, ORG, CATEGORIES, SOUND,
  31 ;; CLASS, KEY.
  32
  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.
  63
  64 ;;; Code:
  65
  66 (require 'jabber-core)
  67 (require 'jabber-widget)
  68 (require 'jabber-iq)
  69 (require 'jabber-avatar)
  70
  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)
  74
  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))))
  94
  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