lisp/gnus/gravatar.el

   1 ;;; gravatar.el --- Get Gravatars
   2
   3 ;; Copyright (C) 2010-2014 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 'url)
  28 (require 'url-cache)
  29
  30 (defgroup gravatar nil
  31   "Gravatar."
  32   :version "24.1"
  33   :group 'comm)
  34
  35 (defcustom gravatar-automatic-caching t
  36   "Whether to cache retrieved gravatars."
  37   :type 'boolean
  38   :group 'gravatar)
  39
  40 ;; FIXME a time value is not the nicest format for a custom variable.
  41 (defcustom gravatar-cache-ttl (days-to-time 30)
  42   "Time to live for gravatar cache entries."
  43   :type '(repeat integer)
  44   :group 'gravatar)
  45
  46 ;; FIXME Doc is tautological.  What are the options?
  47 (defcustom gravatar-rating "g"
  48   "Default rating for gravatar."
  49   :type 'string
  50   :group 'gravatar)
  51
  52 (defcustom gravatar-size 32
  53   "Default size in pixels for gravatars."
  54   :type 'integer
  55   :group 'gravatar)
  56
  57 (defconst gravatar-base-url
  58   "http://www.gravatar.com/avatar"
  59   "Base URL for getting gravatars.")
  60
  61 (defun gravatar-hash (mail-address)
  62   "Create an hash from MAIL-ADDRESS."
  63   (md5 (downcase mail-address)))
  64
  65 (defun gravatar-build-url (mail-address)
  66   "Return an URL to retrieve MAIL-ADDRESS gravatar."
  67   (format "%s/%s?d=404&r=%s&s=%d"
  68           gravatar-base-url
  69           (gravatar-hash mail-address)
  70           gravatar-rating
  71           gravatar-size))
  72
  73 (defun gravatar-cache-expired (url)
  74   "Check if URL is cached for more than `gravatar-cache-ttl'."
  75   (cond (url-standalone-mode
  76          (not (file-exists-p (url-cache-create-filename url))))
  77         (t (let ((cache-time (url-is-cached url)))
  78              (if cache-time
  79                  (time-less-p
  80                   (time-add
  81                    cache-time
  82                    gravatar-cache-ttl)
  83                   (current-time))
  84                t)))))
  85
  86 (defun gravatar-get-data ()
  87   "Get data from current buffer."
  88   (save-excursion
  89     (goto-char (point-min))
  90     (when (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position))
  91       (when (search-forward "\n\n" nil t)
  92         (buffer-substring (point) (point-max))))))
  93
  94 (eval-and-compile
  95   (cond ((featurep 'xemacs)
  96          (require 'gnus-xmas)
  97          (defalias 'gravatar-create-image 'gnus-xmas-create-image))
  98         ((featurep 'gnus-ems)
  99          (defalias 'gravatar-create-image 'gnus-create-image))
 100         (t
 101          (require 'image)
 102          (defalias 'gravatar-create-image 'create-image))))
 103
 104 (defun gravatar-data->image ()
 105   "Get data of current buffer and return an image.
 106 If no image available, return 'error."
 107   (let ((data (gravatar-get-data)))
 108     (if data
 109         (gravatar-create-image data nil t)
 110       'error)))
 111
 112 (autoload 'help-function-arglist "help-fns")
 113
 114 ;;;###autoload
 115 (defun gravatar-retrieve (mail-address cb &optional cbargs)
 116   "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
 117 You can provide a list of argument to pass to CB in CBARGS."
 118   (let ((url (gravatar-build-url mail-address)))
 119     (if (gravatar-cache-expired url)
 120         (let ((args (list url
 121                           'gravatar-retrieved
 122                           (list cb (when cbargs cbargs)))))
 123           (when (> (length (if (featurep 'xemacs)
 124                                (cdr (split-string (function-arglist 'url-retrieve)))
 125                              (help-function-arglist 'url-retrieve)))
 126                    4)
 127             (setq args (nconc args (list t))))
 128           (apply #'url-retrieve args))
 129       (apply cb
 130                (with-temp-buffer
 131                  (mm-disable-multibyte)
 132                  (url-cache-extract (url-cache-create-filename url))
 133                  (gravatar-data->image))
 134                cbargs))))
 135
 136 ;;;###autoload
 137 (defun gravatar-retrieve-synchronously (mail-address)
 138   "Retrieve MAIL-ADDRESS gravatar and returns it."
 139   (let ((url (gravatar-build-url mail-address)))
 140     (if (gravatar-cache-expired url)
 141         (with-current-buffer (if (featurep 'xemacs)
 142                                  (url-retrieve url)
 143                                (url-retrieve-synchronously url))
 144           (when gravatar-automatic-caching
 145             (url-store-in-cache (current-buffer)))
 146           (let ((data (gravatar-data->image)))
 147             (kill-buffer (current-buffer))
 148             data))
 149       (with-temp-buffer
 150         (mm-disable-multibyte)
 151         (url-cache-extract (url-cache-create-filename url))
 152         (gravatar-data->image)))))
 153
 154
 155 (defun gravatar-retrieved (status cb &optional cbargs)
 156   "Callback function used by `gravatar-retrieve'."
 157   ;; Store gravatar?
 158   (when gravatar-automatic-caching
 159     (url-store-in-cache (current-buffer)))
 160   (if (plist-get status :error)
 161       ;; Error happened.
 162       (apply cb 'error cbargs)
 163     (apply cb (gravatar-data->image) cbargs))
 164   (kill-buffer (current-buffer)))
 165
 166 (provide 'gravatar)
 167
 168 ;;; gravatar.el ends here