jabber-vcard.el

   1 ;;; jabber-vcard.el --- vcards according to JEP-0054
   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     ;; JEP-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   (interactive (list (jabber-read-account)
 259                      (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc)))
 260   (jabber-send-iq jc jid
 261                   "get"
 262                   '(vCard ((xmlns . "vcard-temp")))
 263                   #'jabber-process-data #'jabber-vcard-display
 264                   #'jabber-process-data "Vcard request failed"))
 265
 266 (defun jabber-vcard-edit (jc)
 267   "Edit your own vcard."
 268   (interactive (list (jabber-read-account)))
 269   (jabber-send-iq jc nil
 270                   "get"
 271                   '(vCard ((xmlns . "vcard-temp")))
 272                   #'jabber-vcard-do-edit nil
 273                   #'jabber-report-success "Vcard request failed"))
 274
 275 (defconst jabber-vcard-fields '((FN . "Full name")
 276                                 (NICKNAME . "Nickname")
 277                                 (BDAY . "Birthday")
 278                                 (URL . "URL")
 279                                 (JABBERID . "JID")
 280                                 (MAILER . "User agent")
 281                                 (TZ . "Time zone")
 282                                 (TITLE . "Title")
 283                                 (ROLE . "Role")
 284                                 (REV . "Last changed")
 285                                 (DESC . "Description")
 286                                 (NOTE . "Note")))
 287
 288 (defconst jabber-vcard-name-fields '((PREFIX . "Prefix")
 289                                      (GIVEN . "Given name")
 290                                      (MIDDLE . "Middle name")
 291                                      (FAMILY . "Family name")
 292                                      (SUFFIX . "Suffix")))
 293
 294 (defconst jabber-vcard-phone-types '((HOME . "Home")
 295                                      (WORK . "Work")
 296                                      (VOICE . "Voice")
 297                                      (FAX . "Fax")
 298                                      (PAGER . "Pager")
 299                                      (MSG . "Message")
 300                                      (CELL . "Cell phone")
 301                                      (VIDEO . "Video")
 302                                      (BBS . "BBS")
 303                                      (MODEM . "Modem")
 304                                      (ISDN . "ISDN")
 305                                      (PCS . "PCS")))
 306
 307 (defconst jabber-vcard-email-types '((HOME . "Home")
 308                                      (WORK . "Work")
 309                                      (INTERNET . "Internet")
 310                                      (X400 . "X400")
 311                                      (PREF . "Preferred")))
 312
 313 (defconst jabber-vcard-address-types '((HOME . "Home")
 314                                        (WORK . "Work")
 315                                        (POSTAL . "Postal")
 316                                        (PARCEL . "Parcel")
 317                                        (DOM . "Domestic")
 318                                        (INTL . "International")
 319                                        (PREF . "Preferred")))
 320
 321 (defconst jabber-vcard-address-fields '((POBOX . "Post box")
 322                                         (EXTADD . "Ext. address")
 323                                         (STREET . "Street")
 324                                         (LOCALITY . "Locality")
 325                                         (REGION . "Region")
 326                                         (PCODE . "Post code")
 327                                         (CTRY . "Country")))
 328
 329 (defun jabber-vcard-display (jc xml-data)
 330   "Display received vcard."
 331   (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))))
 332     (dolist (simple-field jabber-vcard-fields)
 333       (let ((field (assq (car simple-field) parsed)))
 334         (when field
 335           (insert (cdr simple-field))
 336           (indent-to 20)
 337           (insert (cdr field) "\n"))))
 338
 339     (let ((names (cdr (assq 'N parsed))))
 340       (when names
 341         (insert "\n")
 342         (dolist (name-field jabber-vcard-name-fields)
 343           (let ((field (assq (car name-field) names)))
 344             (when field
 345               (insert (cdr name-field))
 346               (indent-to 20)
 347               (insert (cdr field) "\n"))))))
 348
 349     (let ((email-addresses (cdr (assq 'EMAIL parsed))))
 350       (when email-addresses
 351         (insert "\n")
 352         (insert (jabber-propertize "E-mail addresses:\n"
 353                                    'face 'jabber-title-medium))
 354         (dolist (email email-addresses)
 355           (insert (mapconcat (lambda (type)
 356                                (cdr (assq type jabber-vcard-email-types)))
 357                              (car email)
 358                              " "))
 359           (insert ": " (cdr email) "\n"))))
 360
 361     (let ((phone-numbers (cdr (assq 'TEL parsed))))
 362       (when phone-numbers
 363         (insert "\n")
 364         (insert (jabber-propertize "Phone numbers:\n"
 365                                    'face 'jabber-title-medium))
 366         (dolist (number phone-numbers)
 367           (insert (mapconcat (lambda (type)
 368                                (cdr (assq type jabber-vcard-phone-types)))
 369                              (car number)
 370                              " "))
 371           (insert ": " (cdr number) "\n"))))
 372
 373     (let ((addresses (cdr (assq 'ADR parsed))))
 374       (when addresses
 375         (insert "\n")
 376         (insert (jabber-propertize "Addresses:\n"
 377                                    'face 'jabber-title-medium))
 378         (dolist (address addresses)
 379           (insert (jabber-propertize
 380                    (mapconcat (lambda (type)
 381                                 (cdr (assq type jabber-vcard-address-types)))
 382                               (car address)
 383                               " ")
 384                    'face 'jabber-title-small))
 385           (insert "\n")
 386           (dolist (address-field jabber-vcard-address-fields)
 387             (let ((field (assq (car address-field) address)))
 388               (when field
 389                 (insert (cdr address-field))
 390                 (indent-to 20)
 391                 (insert (cdr field) "\n")))))))
 392
 393     ;; JEP-0153: vCard-based avatars
 394     (let ((photo-type (nth 1 (assq 'PHOTO parsed)))
 395           (photo-binval (nth 2 (assq 'PHOTO parsed))))
 396       (when (and photo-type photo-binval)
 397         (condition-case nil
 398             ;; ignore the type, let create-image figure it out.
 399             (let ((image (create-image (base64-decode-string photo-binval) nil t)))
 400               (insert-image image "[Photo]")
 401               (insert "\n"))
 402           (error (insert "Couldn't display photo\n")))))))
 403
 404 (defun jabber-vcard-do-edit (jc xml-data closure-data)
 405   (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))
 406         start-position)
 407     (with-current-buffer (get-buffer-create "Edit vcard")
 408       (jabber-init-widget-buffer nil)
 409
 410       (setq jabber-buffer-connection jc)
 411
 412       (setq start-position (point))
 413
 414       (dolist (simple-field jabber-vcard-fields)
 415         (widget-insert (cdr simple-field))
 416         (indent-to 15)
 417         (let ((default-value (cdr (assq (car simple-field) parsed))))
 418           (push (cons (car simple-field)
 419                       (widget-create 'editable-field (or default-value "")))
 420                 jabber-widget-alist)))
 421
 422       (widget-insert "\n")
 423       (push (cons 'N
 424                   (widget-create
 425                    '(set :tag "Decomposited name"
 426                          (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v"))
 427                          (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v"))
 428                          (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v"))
 429                          (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v"))
 430                          (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v")))
 431                    :value (cdr (assq 'N parsed))))
 432             jabber-widget-alist)
 433
 434       (widget-insert "\n")
 435       (push (cons 'ADR
 436                   (widget-create
 437                    '(repeat :tag "Postal addresses"
 438                             (cons
 439                              :tag "Address"
 440                              (set :tag "Type"
 441                                   (const :tag "Home" HOME)
 442                                   (const :tag "Work" WORK)
 443                                   (const :tag "Postal" POSTAL)
 444                                   (const :tag "Parcel" PARCEL)
 445                                   (const :tag "Domestic" DOM)
 446                                   (const :tag "International" INTL)
 447                                   (const :tag "Preferred" PREF))
 448                              (set
 449                               :tag "Address"
 450                               (cons :tag "Post box" :format "%t: %v"
 451                                     (const :format "" POBOX) (string :format "%v"))
 452                               (cons :tag "Ext. address" :format "%t: %v"
 453                                     (const :format "" EXTADD) (string :format "%v"))
 454                               (cons :tag "Street" :format "%t: %v"
 455                                     (const :format "" STREET) (string :format "%v"))
 456                               (cons :tag "Locality" :format "%t: %v"
 457                                     (const :format "" LOCALITY) (string :format "%v"))
 458                               (cons :tag "Region" :format "%t: %v"
 459                                     (const :format "" REGION) (string :format "%v"))
 460                               (cons :tag "Post code" :format "%t: %v"
 461                                     (const :format "" PCODE) (string :format "%v"))
 462                               (cons :tag "Country" :format "%t: %v"
 463                                     (const :format "" CTRY) (string :format "%v")))))
 464                    :value (cdr (assq 'ADR parsed))))
 465             jabber-widget-alist)
 466
 467       (widget-insert "\n")
 468       (push (cons 'TEL
 469                   (widget-create
 470                    '(repeat :tag "Phone numbers"
 471                             (cons :tag "Number"
 472                                   (set :tag "Type"
 473                                        (const :tag "Home" HOME)
 474                                        (const :tag "Work" WORK)
 475                                        (const :tag "Voice" VOICE)
 476                                        (const :tag "Fax" FAX)
 477                                        (const :tag "Pager" PAGER)
 478                                        (const :tag "Message" MSG)
 479                                        (const :tag "Cell phone" CELL)
 480                                        (const :tag "Video" VIDEO)
 481                                        (const :tag "BBS" BBS)
 482                                        (const :tag "Modem" MODEM)
 483                                        (const :tag "ISDN" ISDN)
 484                                        (const :tag "PCS" PCS))
 485                                   (string :tag "Number")))
 486                    :value (cdr (assq 'TEL parsed))))
 487             jabber-widget-alist)
 488
 489       (widget-insert "\n")
 490       (push (cons 'EMAIL
 491                   (widget-create
 492                    '(repeat :tag "E-mail addresses"
 493                             (cons :tag "Address"
 494                                   (set :tag "Type"
 495                                        (const :tag "Home" HOME)
 496                                        (const :tag "Work" WORK)
 497                                        (const :tag "Internet" INTERNET)
 498                                        (const :tag "X400" X400)
 499                                        (const :tag "Preferred" PREF))
 500                                   (string :tag "Address")))
 501                    :value (cdr (assq 'EMAIL parsed))))
 502             jabber-widget-alist)
 503
 504       (widget-insert "\n")
 505       (widget-insert "Photo/avatar:\n")
 506       (let* ((photo (assq 'PHOTO parsed))
 507              (avatar (when photo
 508                        (jabber-avatar-from-base64-string (nth 2 photo)
 509                                                          (nth 1 photo)))))
 510         (push (cons
 511                'PHOTO
 512                (widget-create
 513                 `(radio-button-choice (const :tag "None" nil)
 514                                       ,@(when photo
 515                                           (list
 516                                            `(const :tag
 517                                                    ,(concat
 518                                                      "Existing: "
 519                                                      (jabber-propertize " "
 520                                                                         'display (jabber-avatar-image avatar)))
 521                                                    ,(cdr photo))))
 522                                       (file :must-match t :tag "From file"))
 523                 :value (cdr photo)))
 524               jabber-widget-alist))
 525
 526       (widget-insert "\n")
 527       (widget-create 'push-button :notify #'jabber-vcard-submit "Submit")
 528
 529       (widget-setup)
 530       (widget-minor-mode 1)
 531       (switch-to-buffer (current-buffer))
 532       (goto-char start-position))))
 533
 534 (defun jabber-vcard-submit (&rest ignore)
 535   (let ((to-publish (jabber-vcard-reassemble
 536                      (mapcar (lambda (entry)
 537                                (cons (car entry) (widget-value (cdr entry))))
 538                              jabber-widget-alist))))
 539     (jabber-send-iq jabber-buffer-connection nil
 540                     "set"
 541                     to-publish
 542                     #'jabber-report-success "Changing vCard"
 543                     #'jabber-report-success "Changing vCard")
 544     (when (bound-and-true-p jabber-vcard-avatars-publish)
 545       (jabber-vcard-avatars-update-current
 546        jabber-buffer-connection
 547        (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo))))))
 548
 549 (provide 'jabber-vcard)
 550 ;; arch-tag: 65B95E9C-63BD-11D9-94A9-000A95C2FCD0