jabber-avatar.el

   1 ;;; jabber-avatar.el --- generic functions for avatars
   2
   3 ;; Copyright (C) 2006, 2007, 2008  Magnus Henoch
   4
   5 ;; Author: Magnus Henoch <mange@freemail.hu>
   6
   7 ;; This file is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; This file is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  20 ;; Boston, MA 02110-1301, USA.
  21
  22 ;;; Commentary:
  23
  24 ;; There are several methods for transporting avatars in Jabber
  25 ;; (JEP-0008, JEP-0084, JEP-0153).  They all have in common that they
  26 ;; identify avatars by their SHA1 checksum, and (at least partially)
  27 ;; use Base64-encoded image data.  Thus this library of support
  28 ;; functions for interpreting and caching avatars.
  29
  30 ;; A contact with an avatar has the image in the avatar property of
  31 ;; the JID symbol.  Use `jabber-avatar-set' to set it.
  32
  33 ;;; Code:
  34
  35 (require 'mailcap)
  36 (eval-when-compile (require 'cl))
  37
  38 ;;;; Variables
  39
  40 (defgroup jabber-avatar nil
  41   "Avatar related settings"
  42   :group 'jabber)
  43
  44 (defcustom jabber-avatar-cache-directory "~/.jabber-avatars/"
  45   "Directory to use for cached avatars"
  46   :group 'jabber-avatar
  47   :type 'directory)
  48
  49 (defcustom jabber-avatar-verbose nil
  50   "Display messages about irregularities with other people's avatars."
  51   :group 'jabber-avatar
  52   :type 'boolean)
  53
  54 ;;;; Avatar data handling
  55
  56 (defstruct avatar sha1-sum mime-type url base64-data height width bytes)
  57
  58 (defun jabber-avatar-from-url (url)
  59   "Construct an avatar structure from the given URL.
  60 Retrieves the image to find info about it."
  61   (with-current-buffer (let ((coding-system-for-read 'binary))
  62                          (url-retrieve-synchronously url))
  63     (let* ((case-fold-search t)
  64            (mime-type (ignore-errors
  65                         (search-forward-regexp "^content-type:[ \t]*\\(.*\\)$")
  66                         (match-string 1)))
  67            (data (progn
  68                    (search-forward "\n\n")
  69                    (buffer-substring (point) (point-max)))))
  70       (prog1
  71           (jabber-avatar-from-data data nil mime-type)
  72         (kill-buffer nil)))))
  73
  74 (defun jabber-avatar-from-file (filename)
  75   "Construct an avatar structure from FILENAME."
  76   (require 'mailcap)
  77   (let ((data (with-temp-buffer
  78                 (insert-file-contents-literally filename)
  79                 (buffer-string)))
  80         (mime-type (when (string-match "\\.[^.]+$" filename)
  81                      (mailcap-extension-to-mime (match-string 0 filename)))))
  82     (jabber-avatar-from-data data nil mime-type)))
  83
  84 (defun jabber-avatar-from-base64-string (base64-string &optional mime-type)
  85   "Construct an avatar stucture from BASE64-STRING.
  86 If MIME-TYPE is not specified, try to find it from the image data."
  87   (jabber-avatar-from-data nil base64-string mime-type))
  88
  89 (defun jabber-avatar-from-data (raw-data base64-string &optional mime-type)
  90   "Construct an avatar structure from RAW-DATA and/or BASE64-STRING.
  91 If either is not provided, it is computed.
  92 If MIME-TYPE is not specified, try to find it from the image data."
  93   (let* ((data (or raw-data (base64-decode-string base64-string)))
  94          (bytes (length data))
  95          (sha1-sum (sha1 data))
  96          (base64-data (or base64-string (base64-encode-string raw-data)))
  97          (type (or mime-type
  98                    (cdr (assq (get :type (cdr (create-image data nil t)))
  99                               '((png "image/png")
 100                                 (jpeg "image/jpeg")
 101                                 (gif "image/gif")))))))
 102     (jabber-avatar-compute-size
 103      (make-avatar :mime-type mime-type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes))))
 104
 105 ;; XXX: This function is based on an outdated version of JEP-0084.
 106 ;; (defun jabber-avatar-from-data-node (data-node)
 107 ;;   "Construct an avatar structure from the given <data/> node."
 108 ;;   (jabber-xml-let-attributes
 109 ;;    (content-type id bytes height width) data-node
 110 ;;    (let ((base64-data (car (jabber-xml-node-children data-node))))
 111 ;;      (make-avatar :mime-type content-type :sha1-sum id :bytes bytes
 112 ;;                :height height :width width :base64-data base64-data))))
 113
 114 (defun jabber-avatar-image (avatar)
 115   "Create an image from AVATAR.
 116 Return nil if images of this type are not supported."
 117   (create-image (with-temp-buffer
 118                   (set-buffer-multibyte nil)
 119                   (insert (avatar-base64-data avatar))
 120                   (base64-decode-region (point-min) (point-max))
 121                   (buffer-string))
 122                 nil
 123                 t))
 124
 125 (defun jabber-avatar-compute-size (avatar)
 126   "Compute and set the width and height fields of AVATAR.
 127 Return AVATAR."
 128   ;; image-size only works when there is a window system.
 129   ;; But display-graphic-p doesn't exist on XEmacs...
 130   (let ((size (and (fboundp 'display-graphic-p)
 131                    (display-graphic-p)
 132                    (let ((image (jabber-avatar-image avatar)))
 133                      (and image
 134                           (image-size image t))))))
 135     (when size
 136       (setf (avatar-width avatar) (car size))
 137       (setf (avatar-height avatar) (cdr size)))
 138     avatar))
 139
 140 ;;;; Avatar cache
 141
 142 (defun jabber-avatar-find-cached (sha1-sum)
 143   "Return file name of cached image for avatar identified by SHA1-SUM.
 144 If there is no cached image, return nil."
 145   ;; XXX: file-expand-wildcards doesn't exist in XEmacs
 146   (car (file-expand-wildcards (concat (file-name-as-directory jabber-avatar-cache-directory)
 147                                       sha1-sum
 148                                       ".*"))))
 149
 150 (defun jabber-avatar-cache (avatar)
 151   "Cache the AVATAR."
 152   (let* ((id (avatar-sha1-sum avatar))
 153          (base64-data (avatar-base64-data avatar))
 154          (mime-type (avatar-mime-type avatar))
 155          (extension
 156           (cond
 157            ((string= mime-type "image/png")
 158             ".png")
 159            ((string= mime-type "image/jpeg")
 160             ".jpg")
 161            ((string= mime-type "image/gif")
 162             ".gif")
 163            (t
 164             ".dat")))
 165          (filename (expand-file-name (concat id extension) jabber-avatar-cache-directory))
 166          (buffer (create-file-buffer filename)))
 167     (unless (file-directory-p jabber-avatar-cache-directory)
 168       (make-directory jabber-avatar-cache-directory))
 169
 170     (if (file-exists-p filename)
 171         (when jabber-avatar-verbose
 172           (message "Caching avatar, but %s already exists" filename))
 173       (with-current-buffer buffer
 174         (let ((require-final-newline nil))
 175           (setq buffer-file-coding-system 'binary)
 176           (if (fboundp 'set-buffer-multibyte)
 177               (set-buffer-multibyte nil))
 178           (set-visited-file-name filename t)
 179           (insert base64-data)
 180           (base64-decode-region (point-min) (point-max))
 181           (basic-save-buffer))))
 182     (kill-buffer buffer)))
 183
 184 ;;;; Set avatar for contact
 185
 186 (defun jabber-avatar-set (jid avatar)
 187   "Set the avatar of JID to be AVATAR.
 188 JID is a string containing a bare JID.
 189 AVATAR may be one of:
 190 * An avatar structure.
 191 * The SHA1 sum of a cached avatar.
 192 * nil, meaning no avatar."
 193   ;; We want to optimize for the case of same avatar.
 194   ;; Loading an image is expensive, so do it lazily.
 195   (let ((jid-symbol (jabber-jid-symbol jid))
 196         image hash)
 197     (cond
 198      ((avatar-p avatar)
 199       (setq hash (avatar-sha1-sum avatar))
 200       (setq image (lambda () (jabber-avatar-image avatar))))
 201      ((stringp avatar)
 202       (setq hash avatar)
 203       (setq image (lambda () (create-image (jabber-avatar-find-cached avatar)))))
 204      (t
 205       (setq hash nil)
 206       (setq image #'ignore)))
 207
 208     (unless (string= hash (get jid-symbol 'avatar-hash))
 209       (put jid-symbol 'avatar (funcall image))
 210       (put jid-symbol 'avatar-hash hash)
 211       (jabber-presence-update-roster jid-symbol))))
 212
 213 (provide 'jabber-avatar)
 214 ;; arch-tag: 2405c3f8-8eaa-11da-826c-000a95c2fcd0