emacs-jabber 0.8.0-3 / usr / share / emacs / site-lisp / emacs-jabber / jabber-vcard.el

;;; jabber-vcard.el --- vcards according to JEP-0054

;; Copyright (C) 2005, 2007  Magnus Henoch

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

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

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; There are great variations in Jabber vcard implementations.  This
;; one adds some spice to the mix, while trying to follow the JEP
;; closely.

;; Fields not implemented: GEO, LOGO, AGENT, ORG, CATEGORIES, SOUND,
;; CLASS, KEY.

;; The internal data structure used for vCards is an alist.  All
;; keys are uppercase symbols.
;;
;; FN, NICKNAME, BDAY, JABBERID, MAILER, TZ, TITLE, ROLE, NOTE,
;; PRODID, REV, SORT-STRING, UID, URL, DESC:
;; Value is a string.
;;
;; N:
;;   Value is an alist, with keys FAMILY, GIVEN, MIDDLE, PREFIX and SUFFIX.
;;
;; ADR:
;;   Value is a list, each element representing a separate address.
;;   The car of each address is a list of types; possible values are
;;   HOME, WORK, POSTAL, PARCEL, DOM, INTL, PREF.
;;   The cdr of each address is an alist, with keys POBOX, EXTADD,
;;   STREET, LOCALITY, REGION, PCODE, CTRY, and values being strings.
;;
;; TEL:
;;   Value is a list, each element representing a separate phone number.
;;   The car of each number is a list of types; possible values are
;;   HOME, WORK, VOICE, FAX, PAGER, MSG, CELL, VIDEO, BBS, MODEM, ISDN,
;;   PCS, PREF
;;   The cdr is the phone number as a string.
;;
;; EMAIL:
;;   Value is a list, each element representing a separate e-mail address.
;;   The car of each address is a list of types; possible values are
;;   HOME, WORK, INTERNET, PREF, X400.  At least one of INTERNET and
;;   X400 is always present.
;;   The cdr is the address as a string.

;;; Code:

(require 'jabber-core)
(require 'jabber-widget)
(require 'jabber-iq)
(require 'jabber-avatar)

(defvar jabber-vcard-photo nil
  "The avatar structure for the photo in the vCard edit buffer.")
(make-variable-buffer-local 'jabber-vcard-photo)

(defun jabber-vcard-parse (vcard)
  "Parse the vCard XML structure given in VCARD.
The top node should be the `vCard' node."
  ;; Hm... stpeter has a <query/> as top node...
  ;;(unless (eq (jabber-xml-node-name vcard) 'vCard)
  ;;  (error "Invalid vCard"))
  (let (result)
    (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ
				 TITLE ROLE NOTE PRODID REV SORT-STRING
				 UID URL DESC))
      ;; There should only be one of each of these.  They are
      ;; used verbatim.
      (let ((node (car (jabber-xml-get-children vcard
						verbatim-node))))
	;; Some clients include the node, but without data
	(when (car (jabber-xml-node-children node))
	  (push (cons (jabber-xml-node-name node)
		      (car (jabber-xml-node-children node)))
		result))))

    ;; Name components
    (let ((node (car (jabber-xml-get-children vcard 'N))))
      ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX
      (push (cons 'N
		  (let (name)
		    (dolist (subnode (jabber-xml-node-children node))
		      (when (and (memq (jabber-xml-node-name subnode)
				       '(FAMILY GIVEN MIDDLE PREFIX SUFFIX))
				 (not (zerop (length
					      (car (jabber-xml-node-children
						    subnode))))))
			(push (cons (jabber-xml-node-name subnode)
				    (car (jabber-xml-node-children
					  subnode)))
			      name)))
		    name))
	    result))

    ;; There can be several addresses
    (let (addresses)
      (dolist (adr (jabber-xml-get-children vcard 'ADR))
	;; Find address type(s)
	(let (types)
	  (dolist (possible-type '(HOME WORK POSTAL PARCEL DOM INTL PREF))
	    (when (jabber-xml-get-children adr possible-type)
	      (push possible-type types)))

	  (let (components)
	    (dolist (component (jabber-xml-node-children adr))
	      (when (and (memq (jabber-xml-node-name component)
			       '(POBOX EXTADD STREET LOCALITY REGION
				       PCODE CTRY))
			 (not (zerop (length
				      (car (jabber-xml-node-children
					    component))))))
		(push (cons (jabber-xml-node-name component)
			    (car (jabber-xml-node-children component)))
		      components)))

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

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

    ;; Likewise for phone numbers
    (let (phone-numbers)
      (dolist (tel (jabber-xml-get-children vcard 'TEL))
	;; Find phone type(s)
	(let ((number (car (jabber-xml-node-children
			    (car (jabber-xml-get-children tel 'NUMBER)))))
	      types)
	  ;; Some clients put no NUMBER node.  Avoid that.
	  (when number
	    (dolist (possible-type '(HOME WORK VOICE FAX PAGER MSG CELL
					  VIDEO BBS MODEM ISDN PCS PREF))
	      (when (jabber-xml-get-children tel possible-type)
		(push possible-type types)))
	    
	    (push (cons types number) phone-numbers))))
	
      (when phone-numbers
	(push (cons 'TEL phone-numbers) result)))

    ;; And for e-mail addresses
    (let (e-mails)
      (dolist (email (jabber-xml-get-children vcard 'EMAIL))
	(let ((userid (car (jabber-xml-node-children
			    (car (jabber-xml-get-children email 'USERID)))))
	      types)
	  ;; Some clients put no USERID node.  Avoid that.
	  (when userid
	    (dolist (possible-type '(HOME WORK INTERNET PREF X400))
	      (when (jabber-xml-get-children email possible-type)
		(push possible-type types)))
	    (unless (or (memq 'INTERNET types)
			(memq 'X400 types))
	      (push 'INTERNET types))
	    
    (push (cons types userid) e-mails))))

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

    ;; JEP-0153: vCard-based avatars
    (let ((photo-tag (car (jabber-xml-get-children vcard 'PHOTO))))
      (when photo-tag
	(let ((type (jabber-xml-path photo-tag '(TYPE "")))
	      (binval (jabber-xml-path photo-tag '(BINVAL ""))))
	  (when (and type binval)
	    (push (list 'PHOTO type binval) result)))))

    result))

(defun jabber-vcard-reassemble (parsed)
  "Create a vCard XML structure from PARSED."
  ;; Save photo in jabber-vcard-photo, to avoid excessive processing.
  (let ((photo (cdr (assq 'PHOTO parsed))))
    (cond
     ;; No photo
     ((null photo)
      (setq jabber-vcard-photo nil))
     ;; Existing photo
     ((listp photo)
      (setq jabber-vcard-photo 
	    (jabber-avatar-from-base64-string 
	     (nth 1 photo) (nth 0 photo))))
     ;; New photo from file
     (t
      (access-file photo "Avatar file not found")
      ;; Maximum allowed size is 8 kilobytes
      (when (> (nth 7 (file-attributes photo)) 8192)
	(error "Avatar bigger than 8 kilobytes"))
      (setq jabber-vcard-photo (jabber-avatar-from-file photo)))))

  `(vCard ((xmlns . "vcard-temp"))
	  ;; Put in simple fields
	  ,@(mapcar
	     (lambda (field)
	       (when (and (assq (car field) jabber-vcard-fields)
			  (not (zerop (length (cdr field)))))
		 (list (car field) nil (cdr field))))
	     parsed)
	  ;; Put in decomposited name
	  (N nil
	     ,@(mapcar
		(lambda (name-part)
		  (when (not (zerop (length (cdr name-part))))
		    (list (car name-part) nil (cdr name-part))))
		(cdr (assq 'N parsed))))
	  ;; Put in addresses
	  ,@(mapcar
	     (lambda (address)
	       (append '(ADR) '(())
		       (mapcar 'list (nth 0 address))
		       (mapcar (lambda (field)
				 (list (car field) nil (cdr field)))
			       (cdr address))))
	     (cdr (assq 'ADR parsed)))
	  ;; Put in phone numbers
	  ,@(mapcar
	     (lambda (phone)
	       (append '(TEL) '(())
		       (mapcar 'list (car phone))
		       (list (list 'NUMBER nil (cdr phone)))))
	     (cdr (assq 'TEL parsed)))
	  ;; Put in e-mail addresses
	  ,@(mapcar
	     (lambda (email)
	       (append '(EMAIL) '(())
		       (mapcar 'list (car email))
		       (list (list 'USERID nil (cdr email)))))
	     (cdr (assq 'EMAIL parsed)))
	  ;; Put in photo
	  ,@(when jabber-vcard-photo
	      `((PHOTO ()
		       (TYPE () ,(avatar-mime-type jabber-vcard-photo))
		       (BINVAL () ,(avatar-base64-data jabber-vcard-photo)))))))
		     
(add-to-list 'jabber-jid-info-menu
	     (cons "Request vcard" 'jabber-vcard-get))

(defun jabber-vcard-get (jc jid)
  "Request vcard from JID."
  (interactive (list (jabber-read-account)
		     (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc)))
  (jabber-send-iq jc jid
		  "get"
		  '(vCard ((xmlns . "vcard-temp")))
		  #'jabber-process-data #'jabber-vcard-display
		  #'jabber-process-data "Vcard request failed"))

(defun jabber-vcard-edit (jc)
  "Edit your own vcard."
  (interactive (list (jabber-read-account)))
  (jabber-send-iq jc nil
		  "get"
		  '(vCard ((xmlns . "vcard-temp")))
		  #'jabber-vcard-do-edit nil
		  #'jabber-report-success "Vcard request failed"))

(defconst jabber-vcard-fields '((FN . "Full name")
				(NICKNAME . "Nickname")
				(BDAY . "Birthday")
				(URL . "URL")
				(JABBERID . "JID")
				(MAILER . "User agent")
				(TZ . "Time zone")
				(TITLE . "Title")
				(ROLE . "Role")
				(REV . "Last changed")
				(DESC . "Description")
				(NOTE . "Note")))

(defconst jabber-vcard-name-fields '((PREFIX . "Prefix")
				     (GIVEN . "Given name")
				     (MIDDLE . "Middle name")
				     (FAMILY . "Family name")
				     (SUFFIX . "Suffix")))

(defconst jabber-vcard-phone-types '((HOME . "Home")
				     (WORK . "Work")
				     (VOICE . "Voice")
				     (FAX . "Fax")
				     (PAGER . "Pager")
				     (MSG . "Message")
				     (CELL . "Cell phone")
				     (VIDEO . "Video")
				     (BBS . "BBS")
				     (MODEM . "Modem")
				     (ISDN . "ISDN")
				     (PCS . "PCS")))

(defconst jabber-vcard-email-types '((HOME . "Home")
				     (WORK . "Work")
				     (INTERNET . "Internet")
				     (X400 . "X400")
				     (PREF . "Preferred")))

(defconst jabber-vcard-address-types '((HOME . "Home")
				       (WORK . "Work")
				       (POSTAL . "Postal")
				       (PARCEL . "Parcel")
				       (DOM . "Domestic")
				       (INTL . "International")
				       (PREF . "Preferred")))

(defconst jabber-vcard-address-fields '((POBOX . "Post box")
					(EXTADD . "Ext. address")
					(STREET . "Street")
					(LOCALITY . "Locality")
					(REGION . "Region")
					(PCODE . "Post code")
					(CTRY . "Country")))

(defun jabber-vcard-display (jc xml-data)
  "Display received vcard."
  (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))))
    (dolist (simple-field jabber-vcard-fields)
      (let ((field (assq (car simple-field) parsed)))
	(when field
	  (insert (cdr simple-field))
	  (indent-to 20)
	  (insert (cdr field) "\n"))))

    (let ((names (cdr (assq 'N parsed))))
      (when names
	(insert "\n")
	(dolist (name-field jabber-vcard-name-fields)
	  (let ((field (assq (car name-field) names)))
	    (when field
	      (insert (cdr name-field))
	      (indent-to 20)
	      (insert (cdr field) "\n"))))))

    (let ((email-addresses (cdr (assq 'EMAIL parsed))))
      (when email-addresses
	(insert "\n")
	(insert (jabber-propertize "E-mail addresses:\n"
				   'face 'jabber-title-medium))
	(dolist (email email-addresses)
	  (insert (mapconcat (lambda (type) 
			       (cdr (assq type jabber-vcard-email-types)))
			     (car email)
			     " "))
	  (insert ": " (cdr email) "\n"))))
	  
    (let ((phone-numbers (cdr (assq 'TEL parsed))))
      (when phone-numbers
	(insert "\n")
	(insert (jabber-propertize "Phone numbers:\n"
				   'face 'jabber-title-medium))
	(dolist (number phone-numbers)
	  (insert (mapconcat (lambda (type) 
			       (cdr (assq type jabber-vcard-phone-types)))
			     (car number)
			     " "))
	  (insert ": " (cdr number) "\n"))))

    (let ((addresses (cdr (assq 'ADR parsed))))
      (when addresses
	(insert "\n")
	(insert (jabber-propertize "Addresses:\n"
				   'face 'jabber-title-medium))
	(dolist (address addresses)
	  (insert (jabber-propertize
		   (mapconcat (lambda (type) 
				(cdr (assq type jabber-vcard-address-types)))
			      (car address)
			      " ")
		   'face 'jabber-title-small))
	  (insert "\n")
	  (dolist (address-field jabber-vcard-address-fields)
	    (let ((field (assq (car address-field) address)))
	      (when field
		(insert (cdr address-field))
		(indent-to 20)
		(insert (cdr field) "\n")))))))

    ;; JEP-0153: vCard-based avatars
    (let ((photo-type (nth 1 (assq 'PHOTO parsed)))
	  (photo-binval (nth 2 (assq 'PHOTO parsed))))
      (when (and photo-type photo-binval)
	(condition-case nil
	    ;; ignore the type, let create-image figure it out.
	    (let ((image (create-image (base64-decode-string photo-binval) nil t)))
	      (insert-image image "[Photo]")
	      (insert "\n"))
	  (error (insert "Couldn't display photo\n")))))))

(defun jabber-vcard-do-edit (jc xml-data closure-data)
  (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))
	start-position)
    (with-current-buffer (get-buffer-create "Edit vcard")
      (jabber-init-widget-buffer nil)

      (setq jabber-buffer-connection jc)

      (setq start-position (point))

      (dolist (simple-field jabber-vcard-fields)
	(widget-insert (cdr simple-field))
	(indent-to 15)
	(let ((default-value (cdr (assq (car simple-field) parsed))))
	  (push (cons (car simple-field)
		      (widget-create 'editable-field (or default-value "")))
		jabber-widget-alist)))
      
      (widget-insert "\n")
      (push (cons 'N
		  (widget-create 
		   '(set :tag "Decomposited name"
			 (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v"))
			 (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v"))
			 (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v"))
			 (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v"))
			 (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v")))
		   :value (cdr (assq 'N parsed))))
	    jabber-widget-alist)

      (widget-insert "\n")
      (push (cons 'ADR
		  (widget-create
		   '(repeat :tag "Postal addresses"
			    (cons
			     :tag "Address"
			     (set :tag "Type"
				  (const :tag "Home" HOME)
				  (const :tag "Work" WORK)
				  (const :tag "Postal" POSTAL)
				  (const :tag "Parcel" PARCEL)
				  (const :tag "Domestic" DOM)
				  (const :tag "International" INTL)
				  (const :tag "Preferred" PREF))
			     (set
			      :tag "Address"
			      (cons :tag "Post box" :format "%t: %v"
				    (const :format "" POBOX) (string :format "%v"))
			      (cons :tag "Ext. address" :format "%t: %v"
				    (const :format "" EXTADD) (string :format "%v"))
			      (cons :tag "Street" :format "%t: %v"
				    (const :format "" STREET) (string :format "%v"))
			      (cons :tag "Locality" :format "%t: %v"
				    (const :format "" LOCALITY) (string :format "%v"))
			      (cons :tag "Region" :format "%t: %v"
				    (const :format "" REGION) (string :format "%v"))
			      (cons :tag "Post code" :format "%t: %v"
				    (const :format "" PCODE) (string :format "%v"))
			      (cons :tag "Country" :format "%t: %v"
				    (const :format "" CTRY) (string :format "%v")))))
		   :value (cdr (assq 'ADR parsed))))
	    jabber-widget-alist)

      (widget-insert "\n")
      (push (cons 'TEL
		  (widget-create
		   '(repeat :tag "Phone numbers"
			    (cons :tag "Number"
				  (set :tag "Type"
				       (const :tag "Home" HOME)
				       (const :tag "Work" WORK)
				       (const :tag "Voice" VOICE)
				       (const :tag "Fax" FAX)
				       (const :tag "Pager" PAGER)
				       (const :tag "Message" MSG)
				       (const :tag "Cell phone" CELL)
				       (const :tag "Video" VIDEO)
				       (const :tag "BBS" BBS)
				       (const :tag "Modem" MODEM)
				       (const :tag "ISDN" ISDN)
				       (const :tag "PCS" PCS))
				  (string :tag "Number")))
		   :value (cdr (assq 'TEL parsed))))
	    jabber-widget-alist)

      (widget-insert "\n")
      (push (cons 'EMAIL
		  (widget-create
		   '(repeat :tag "E-mail addresses"
			    (cons :tag "Address"
				  (set :tag "Type"
				       (const :tag "Home" HOME)
				       (const :tag "Work" WORK)
				       (const :tag "Internet" INTERNET)
				       (const :tag "X400" X400)
				       (const :tag "Preferred" PREF))
				  (string :tag "Address")))
		   :value (cdr (assq 'EMAIL parsed))))
	    jabber-widget-alist)

      (widget-insert "\n")
      (widget-insert "Photo/avatar:\n")
      (let* ((photo (assq 'PHOTO parsed))
	     (avatar (when photo
		       (jabber-avatar-from-base64-string (nth 2 photo)
							 (nth 1 photo)))))
	(push (cons 
	       'PHOTO
	       (widget-create
		`(radio-button-choice (const :tag "None" nil)
				      ,@(when photo
					  (list 
					   `(const :tag 
						   ,(concat
						     "Existing: "
						     (jabber-propertize " "
									'display (jabber-avatar-image avatar)))
						   ,(cdr photo))))
				      (file :must-match t :tag "From file"))
		:value (cdr photo)))
	      jabber-widget-alist))

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

      (widget-setup)
      (widget-minor-mode 1)
      (switch-to-buffer (current-buffer))
      (goto-char start-position))))

(defun jabber-vcard-submit (&rest ignore)
  (let ((to-publish (jabber-vcard-reassemble
		     (mapcar (lambda (entry)
			       (cons (car entry) (widget-value (cdr entry))))
			     jabber-widget-alist))))
    (jabber-send-iq jabber-buffer-connection nil
		    "set"
		    to-publish
		    #'jabber-report-success "Changing vCard"
		    #'jabber-report-success "Changing vCard")
    (when (bound-and-true-p jabber-vcard-avatars-publish)
      (jabber-vcard-avatars-update-current
       jabber-buffer-connection
       (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo))))))

(provide 'jabber-vcard)
;; arch-tag: 65B95E9C-63BD-11D9-94A9-000A95C2FCD0