Remove nnml-retrieve-groups that is unnecessary and somewhat problematic
[gnus] / lisp / gravatar.el
1 ;;; gravatar.el --- Get Gravatars
2
3 ;; Copyright (C) 2010-2015 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 (url-retrieve-synchronously url)
142           (when gravatar-automatic-caching
143             (url-store-in-cache (current-buffer)))
144           (let ((data (gravatar-data->image)))
145             (kill-buffer (current-buffer))
146             data))
147       (with-temp-buffer
148         (mm-disable-multibyte)
149         (url-cache-extract (url-cache-create-filename url))
150         (gravatar-data->image)))))
151
152
153 (defun gravatar-retrieved (status cb &optional cbargs)
154   "Callback function used by `gravatar-retrieve'."
155   ;; Store gravatar?
156   (when gravatar-automatic-caching
157     (url-store-in-cache (current-buffer)))
158   (if (plist-get status :error)
159       ;; Error happened.
160       (apply cb 'error cbargs)
161     (apply cb (gravatar-data->image) cbargs))
162   (kill-buffer (current-buffer)))
163
164 (provide 'gravatar)
165
166 ;;; gravatar.el ends here