[PATCH] Add Gravatar support

[Julien Danjou <julien@danjou.info>]

Signed-off-by: Julien Danjou <julien@danjou.info>
---
 lisp/ChangeLog        |   10 ++++
 lisp/gnus-art.el      |   34 +++++++++++++-
 lisp/gnus-gravatar.el |  112 ++++++++++++++++++++++++++++++++++++++++++++
 lisp/gnus-sum.el      |    6 ++-
 lisp/gravatar.el      |  123 +++++++++++++++++++++++++++++++++++++++++++++++++
 texi/ChangeLog        |    4 ++
 texi/gnus.texi        |   70 +++++++++++++++++++++++++++-
 7 files changed, 355 insertions(+), 4 deletions(-)
 create mode 100644 lisp/gnus-gravatar.el
 create mode 100644 lisp/gravatar.el

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 9733760..c19c5cd 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,13 @@
+2010-09-24  Julien Danjou  <julien@danjou.info>
+
+	* gnus-sum.el: Add support for Gravatars.
+
+	* gnus-art.el: Add support for Gravatars.
+
+	* gnus-gravatar.el: Add this file.
+
+	* gravatar.el: Add this file.
+
 2010-09-24  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
 	* nnimap.el (nnimap-command): Register the last command time so
diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el
index d92d29d..231f9e9 100644
--- a/lisp/gnus-art.el
+++ b/lisp/gnus-art.el
@@ -1529,10 +1529,40 @@ node `(gnus)Picons' for details."
   :type gnus-article-treat-head-custom)
 (put 'gnus-treat-newsgroups-picon 'highlight t)
 
+(defcustom gnus-treat-from-gravatar
+  (when (display-images-p) 'head)
+  "Display gravatars in the From header.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate.  See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+  :version "24.1"
+  :group 'gnus-article-treat
+  :group 'gnus-gravatar
+  :link '(custom-manual "(gnus)Customizing Articles")
+  :link '(custom-manual "(gnus)Gravatars")
+  :type gnus-article-treat-head-custom)
+(put 'gnus-treat-from-gravatar 'highlight t)
+
+(defcustom gnus-treat-mail-gravatar
+  (when (display-images-p) 'head)
+  "Display gravatars in To and Cc headers.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate.  See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+  :version "24.1"
+  :group 'gnus-article-treat
+  :group 'gnus-gravatar
+  :link '(custom-manual "(gnus)Customizing Articles")
+  :link '(custom-manual "(gnus)Gravatars")
+  :type gnus-article-treat-head-custom)
+(put 'gnus-treat-mail-gravatar 'highlight t)
+
 (defcustom gnus-treat-body-boundary
   (if (or gnus-treat-newsgroups-picon
 	  gnus-treat-mail-picon
-	  gnus-treat-from-picon)
+	  gnus-treat-from-picon
+          gnus-treat-from-gravatar
+          gnus-treat-mail-gravatar)
       ;; If there's much decoration, the user might prefer a boundery.
       'head
     nil)
@@ -1669,6 +1699,8 @@ This requires GNU Libidn, and by default only enabled if it is found."
     (gnus-treat-from-picon gnus-treat-from-picon)
     (gnus-treat-mail-picon gnus-treat-mail-picon)
     (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
+    (gnus-treat-from-gravatar gnus-treat-from-gravatar)
+    (gnus-treat-mail-gravatar gnus-treat-mail-gravatar)
     (gnus-treat-highlight-headers gnus-article-highlight-headers)
     (gnus-treat-highlight-signature gnus-article-highlight-signature)
     (gnus-treat-strip-trailing-blank-lines
diff --git a/lisp/gnus-gravatar.el b/lisp/gnus-gravatar.el
new file mode 100644
index 0000000..6b97a54
--- /dev/null
+++ b/lisp/gnus-gravatar.el
@@ -0,0 +1,112 @@
+;;; gnus-gravatar.el --- Gnus Gravatar support
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gravatar)
+
+(defgroup gnus-gravatar nil
+  "Gnus Gravatar."
+  :group 'gnus-visual)
+
+(defcustom gnus-gravatar-size 32
+  "How big should gravatars be displayed."
+  :type 'integer
+  :group 'gnus-gravatar)
+
+(defcustom gnus-gravatar-relief 1
+  "If non-nil, adds a shadow rectangle around the image. The
+value, relief, specifies the width of the shadow lines, in
+pixels. If relief is negative, shadows are drawn so that the
+image appears as a pressed button; otherwise, it appears as an
+unpressed button."
+  :group 'gnus-gravatar)
+
+(defun gnus-gravatar-transform-address (header category)
+  (gnus-with-article-headers
+    (let ((addresses
+           (mail-header-parse-addresses
+            ;; mail-header-parse-addresses does not work (reliably) on
+            ;; decoded headers.
+            (or
+             (ignore-errors
+               (mail-encode-encoded-word-string
+                (or (mail-fetch-field header) "")))
+             (mail-fetch-field header)))))
+      (dolist (address addresses)
+        (gravatar-retrieve
+         (car address)
+         'gnus-gravatar-insert
+         (list header (car address) category))))))
+
+(defun gnus-gravatar-insert (gravatar header address category)
+  "Insert GRAVATAR for ADDRESS in HEADER in current article buffer.
+Set image category to CATEGORY."
+  (unless (eq gravatar 'error)
+    (gnus-with-article-headers
+      (gnus-article-goto-header header)
+      (mail-header-narrow-to-field)
+      (when (and (search-forward address nil t)
+                 (or (search-backward ", " nil t)
+                     (search-backward ": " nil t)))
+        (goto-char (1+ (point)))
+        ;; Do not do anything if there's already a gravatar. This can
+        ;; happens if the buffer has been regenerated in the mean time, for
+        ;; example we were fetching someaddress, and then we change to
+        ;; another mail with the same someaddress.
+        (unless (memq 'gnus-gravatar (text-properties-at (point)))
+          (let ((inhibit-read-only t)
+                (point (point))
+                (gravatar (append
+                           gravatar
+                           `(:ascent center :relief ,gnus-gravatar-relief))))
+            (gnus-put-image gravatar nil category)
+            (put-text-property point (point) 'gnus-gravatar address)
+            (gnus-add-wash-type category)
+            (gnus-add-image category gravatar)))))))
+
+;;;###autoload
+(defun gnus-treat-from-gravatar ()
+  "Display gravatar in the From header.
+If gravatar is already displayed, remove it."
+  (interactive)
+  (gnus-with-article-buffer
+    (if (memq 'from-gravatar gnus-article-wash-types)
+        (gnus-delete-images 'from-gravatar)
+      (gnus-gravatar-transform-address "from" 'from-gravatar))))
+
+;;;###autoload
+(defun gnus-treat-mail-gravatar ()
+  "Display gravatars in the Cc and To headers.
+If gravatars are already displayed, remove them."
+  (interactive)
+    (gnus-with-article-buffer
+      (if (memq 'mail-gravatar gnus-article-wash-types)
+          (gnus-delete-images 'mail-gravatar)
+        (gnus-gravatar-transform-address "cc" 'mail-gravatar)
+        (gnus-gravatar-transform-address "to" 'mail-gravatar))))
+
+(provide 'gnus-gravatar)
+
+;;; gnus-gravatar.el ends here
diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el
index 50f9b32..062a2be 100644
--- a/lisp/gnus-sum.el
+++ b/lisp/gnus-sum.el
@@ -2124,7 +2124,9 @@ increase the score of each group you read."
   "W" gnus-html-show-images
   "f" gnus-treat-from-picon
   "m" gnus-treat-mail-picon
-  "n" gnus-treat-newsgroups-picon)
+  "n" gnus-treat-newsgroups-picon
+  "g" gnus-treat-from-gravatar
+  "h" gnus-treat-mail-gravatar)
 
 (gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map)
   "w" gnus-article-decode-mime-words
@@ -2374,6 +2376,8 @@ increase the score of each group you read."
 	      ["Show picons in From" gnus-treat-from-picon t]
 	      ["Show picons in mail headers" gnus-treat-mail-picon t]
 	      ["Show picons in news headers" gnus-treat-newsgroups-picon t]
+              ["Show Gravatars in From" gnus-treat-from-gravatar t]
+	      ["Show Gravatars in mail headers" gnus-treat-mail-gravatar t]
 	      ("View as different encoding"
 	       ,@(gnus-summary-menu-split
 		  (mapcar
diff --git a/lisp/gravatar.el b/lisp/gravatar.el
new file mode 100644
index 0000000..ec03b1b
--- /dev/null
+++ b/lisp/gravatar.el
@@ -0,0 +1,123 @@
+;;; gravatar.el --- Get Gravatars
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'image)
+(require 'url)
+(require 'url-cache)
+
+(defgroup gravatar nil
+  "Gravatar."
+  :group 'comm)
+
+(defcustom gravatar-automatic-caching t
+  "Whether cache retrieved gravatar."
+  :group 'gravatar)
+
+(defcustom gravatar-cache-ttl (days-to-time 30)
+  "Time to live for gravatar cache entries."
+  :group 'gravatar)
+
+(defcustom gravatar-rating "g"
+  "Default rating for gravatar."
+  :group 'gravatar)
+
+(defcustom gravatar-size 32
+  "Default size in pixels for gravatars."
+  :group 'gravatar)
+
+(defconst gravatar-base-url
+  "http://www.gravatar.com/avatar"
+  "Base URL for getting gravatars.")
+
+(defun gravatar-hash (mail-address)
+  "Create an hash from MAIL-ADDRESS."
+  (md5 (downcase mail-address)))
+
+(defun gravatar-build-url (mail-address)
+  "Return an URL to retrieve MAIL-ADDRESS gravatar."
+  (format "%s/%s?d=404&r=%s&s=%d"
+          gravatar-base-url
+          (gravatar-hash mail-address)
+          gravatar-rating
+          gravatar-size))
+
+(defun gravatar-cache-expired (url)
+  "Check if URL is cached for more than `gravatar-cache-ttl'."
+  (cond (url-standalone-mode
+         (not (file-exists-p (url-cache-create-filename url))))
+        (t (let ((cache-time (url-is-cached url)))
+             (if cache-time
+                 (time-less-p
+                  (time-add
+                   cache-time
+                   gravatar-cache-ttl)
+                  (current-time))
+               t)))))
+
+(defun gravatar-get-data ()
+  "Get data from current buffer."
+  (when (string-match "^HTTP/.+ 200 OK$"
+                      (buffer-substring (point-min) (line-end-position)))
+    (when (search-forward "\n\n" nil t)
+      (buffer-substring (point) (point-max)))))
+
+(defun gravatar-data->image ()
+  "Get data of current buffer and return an image.
+If no image available, return 'error."
+  (let ((data (gravatar-get-data)))
+    (if data
+        (create-image data  nil t)
+      'error)))
+
+;;;###autoload
+(defun gravatar-retrieve (mail-address cb &optional cbargs)
+  "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
+You can provide a list of argument to pass to CB in CBARGS."
+  (let ((url (gravatar-build-url mail-address)))
+    (if (gravatar-cache-expired url)
+        (url-retrieve url
+                      'gravatar-retrieved
+                      (list cb (when cbargs cbargs)))
+      (apply cb
+               (with-temp-buffer
+                 (mm-disable-multibyte)
+                 (url-cache-extract (url-cache-create-filename url))
+                 (gravatar-data->image))
+               cbargs))))
+
+(defun gravatar-retrieved (status cb &optional cbargs)
+  "Callback function used by `gravatar-retrieve'."
+  ;; Store gravatar?
+  (when gravatar-automatic-caching
+    (url-store-in-cache (current-buffer)))
+  (if (plist-get status :error)
+      ;; Error happened.
+      (apply cb 'error cbargs)
+    (apply cb (gravatar-data->image) cbargs)))
+
+(provide 'gravatar)
+
+;;; gravatar.el ends here
diff --git a/texi/ChangeLog b/texi/ChangeLog
index 17022dd..5cedf17 100644
--- a/texi/ChangeLog
+++ b/texi/ChangeLog
@@ -1,3 +1,7 @@
+2010-09-24  Julien Danjou  <julien@danjou.info>
+
+	* gnus.texi: Add Gravatars.
+
 2010-09-23  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
 	* gnus.texi (Startup Variables): Mention gnus-use-backend-marks.
diff --git a/texi/gnus.texi b/texi/gnus.texi
index 7f20f96..678a1e7 100644
--- a/texi/gnus.texi
+++ b/texi/gnus.texi
@@ -589,7 +589,7 @@ Article Treatment
 * Article Buttons::             Click on URLs, Message-IDs, addresses and the like.
 * Article Button Levels::       Controlling appearance of buttons.
 * Article Date::                Grumble, UT!
-* Article Display::             Display various stuff---X-Face, Picons, Smileys
+* Article Display::             Display various stuff---X-Face, Picons, Smileys, Gravatars
 * Article Signature::           What is a signature?
 * Article Miscellanea::         Various other stuff.
 
@@ -9255,7 +9255,8 @@ these articles easier.
 * Article Buttons::             Click on URLs, Message-IDs, addresses and the like.
 * Article Button Levels::       Controlling appearance of buttons.
 * Article Date::                Grumble, UT!
-* Article Display::             Display various stuff---X-Face, Picons, Smileys
+* Article Display::             Display various stuff:
+                                X-Face, Picons, Gravatars, Smileys.
 * Article Signature::           What is a signature?
 * Article Miscellanea::         Various other stuff.
 @end menu
@@ -10299,6 +10300,7 @@ preferred format automatically.
 @cindex picons
 @cindex x-face
 @cindex smileys
+@cindex gravatars
 
 These commands add various frivolous display gimmicks to the article
 buffer in Emacs versions that support them.
@@ -10315,6 +10317,9 @@ their messages with (@pxref{Smileys}).
 Picons, on the other hand, reside on your own system, and Gnus will
 try to match the headers to what you have (@pxref{Picons}).
 
+Gravatars reside on-line and are fetched from
+@uref{http://www.gravatar.com/} (@pxref{Gravatars}).
+
 All these functions are toggles---if the elements already exist,
 they'll be removed.
 
@@ -10353,6 +10358,17 @@ Piconify all mail headers (i. e., @code{Cc}, @code{To})
 Piconify all news headers (i. e., @code{Newsgroups} and
 @code{Followup-To}) (@code{gnus-treat-newsgroups-picon}).
 
+@item W D g
+@kindex W D g (Summary)
+@findex gnus-treat-from-gravatar
+Gravatarify the @code{From} header (@code{gnus-treat-from-gravatar}).
+
+@item W D h
+@kindex W D h (Summary)
+@findex gnus-treat-mail-gravatar
+Gravatarify all mail headers (i. e., @code{Cc}, @code{To})
+(@code{gnus-treat-from-gravatar}).
+
 @item W D D
 @kindex W D D (Summary)
 @findex gnus-article-remove-images
@@ -12631,6 +12647,8 @@ controlling variable is a predicate list, as described above.
 @vindex gnus-treat-from-picon
 @vindex gnus-treat-mail-picon
 @vindex gnus-treat-newsgroups-picon
+@vindex gnus-treat-from-gravatar
+@vindex gnus-treat-mail-gravatar
 @vindex gnus-treat-display-smileys
 @vindex gnus-treat-body-boundary
 @vindex gnus-treat-display-x-face
@@ -12697,6 +12715,11 @@ possible but those listed are probably sufficient for most people.
 
 @xref{Picons}.
 
+@item gnus-treat-from-gravatar (head)
+@item gnus-treat-mail-gravatar (head)
+
+@xref{Gravatars}.
+
 @item gnus-treat-display-smileys (t, integer)
 
 @item gnus-treat-body-boundary (head)
@@ -23709,6 +23732,7 @@ stuff, so Gnus has taken advantage of that.
 * Face::                        Display a funkier, teensier colored image.
 * Smileys::                     Show all those happy faces the way they were meant to be shown.
 * Picons::                      How to display pictures of what you're reading.
+* Gravatars::                   Display the avatar of people you read.
 * XVarious::                    Other XEmacsy Gnusey variables.
 @end menu
 
@@ -24037,6 +24061,48 @@ Ordered list of suffixes on picon file names to try.  Defaults to
 
 @end table
 
+@node Gravatars
+@subsection Gravatars
+
+@iftex
+@iflatex
+\include{gravatars}
+@end iflatex
+@end iftex
+
+A gravatar is an image registered to an e-mail address.
+
+You can submit yours on-line at @uref{http://www.gravatar.com}.
+
+The following variables offer control over how things are displayed.
+
+@table @code
+
+@item gnus-gravatar-size
+@vindex gnus-gravatar-size
+The size in pixels of gravatars. Gravatars are always square, so one
+number for the size is enough.
+
+@item gnus-gravatar-relief
+@vindex gnus-gravatar-relief
+If non-nil, adds a shadow rectangle around the image. The value,
+relief, specifies the width of the shadow lines, in pixels. If relief
+is negative, shadows are drawn so that the image appears as a pressed
+button; otherwise, it appears as an unpressed button.
+
+@end table
+
+If you want to see them in the From field, set:
+@lisp
+(setq gnus-treat-from-gravatar 'head)
+@end lisp
+
+If you want to see them in the Cc and To fields, set:
+
+@lisp
+(setq gnus-treat-mail-gravatar 'head)
+@end lisp
+
 
 @node XVarious
 @subsection Various XEmacs Variables
-- 
1.7.1