cgit.sxemacs.org Git - gnus/blob - lisp/gravatar.el

   1 ;;; gravatar.el --- Get Gravatars
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Julien Danjou <julien@danjou.info>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'image)
  28 (require 'url)
  29 (require 'url-cache)
  30
  31 (defgroup gravatar nil
  32   "Gravatar."
  33   :group 'comm)
  34
  35 (defcustom gravatar-automatic-caching t
  36   "Whether cache retrieved gravatar."
  37   :group 'gravatar)
  38
  39 (defcustom gravatar-cache-ttl (days-to-time 30)
  40   "Time to live for gravatar cache entries."
  41   :group 'gravatar)
  42
  43 (defcustom gravatar-rating "g"
  44   "Default rating for gravatar."
  45   :group 'gravatar)
  46
  47 (defcustom gravatar-size 32
  48   "Default size in pixels for gravatars."
  49   :group 'gravatar)
  50
  51 (defconst gravatar-base-url
  52   "http://www.gravatar.com/avatar"
  53   "Base URL for getting gravatars.")
  54
  55 (defun gravatar-hash (mail-address)
  56   "Create an hash from MAIL-ADDRESS."
  57   (md5 (downcase mail-address)))
  58
  59 (defun gravatar-build-url (mail-address)
  60   "Return an URL to retrieve MAIL-ADDRESS gravatar."
  61   (format "%s/%s?d=404&r=%s&s=%d"
  62           gravatar-base-url
  63           (gravatar-hash mail-address)
  64           gravatar-rating
  65           gravatar-size))
  66
  67 (defun gravatar-cache-expired (url)
  68   "Check if URL is cached for more than `gravatar-cache-ttl'."
  69   (cond (url-standalone-mode
  70          (not (file-exists-p (url-cache-create-filename url))))
  71         (t (let ((cache-time (url-is-cached url)))
  72              (if cache-time
  73                  (time-less-p
  74                   (time-add
  75                    cache-time
  76                    gravatar-cache-ttl)
  77                   (current-time))
  78                t)))))
  79
  80 (defun gravatar-get-data ()
  81   "Get data from current buffer."
  82   (when (string-match "^HTTP/.+ 200 OK$"
  83                       (buffer-substring (point-min) (line-end-position)))
  84     (when (search-forward "\n\n" nil t)
  85       (buffer-substring (point) (point-max)))))
  86
  87 (defun gravatar-data->image ()
  88   "Get data of current buffer and return an image.
  89 If no image available, return 'error."
  90   (let ((data (gravatar-get-data)))
  91     (if data
  92         (create-image data  nil t)
  93       'error)))
  94
  95 ;;;###autoload
  96 (defun gravatar-retrieve (mail-address cb &optional cbargs)
  97   "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
  98 You can provide a list of argument to pass to CB in CBARGS."
  99   (let ((url (gravatar-build-url mail-address)))
 100     (if (gravatar-cache-expired url)
 101         (url-retrieve url
 102                       'gravatar-retrieved
 103                       (list cb (when cbargs cbargs)))
 104       (apply cb
 105                (with-temp-buffer
 106                  (mm-disable-multibyte)
 107                  (url-cache-extract (url-cache-create-filename url))
 108                  (gravatar-data->image))
 109                cbargs))))
 110
 111 (defun gravatar-retrieved (status cb &optional cbargs)
 112   "Callback function used by `gravatar-retrieve'."
 113   ;; Store gravatar?
 114   (when gravatar-automatic-caching
 115     (url-store-in-cache (current-buffer)))
 116   (if (plist-get status :error)
 117       ;; Error happened.
 118       (apply cb 'error cbargs)
 119     (apply cb (gravatar-data->image) cbargs)))
 120
 121 (provide 'gravatar)
 122
 123 ;;; gravatar.el ends here