]> code.delx.au - gnu-emacs/blob - lisp/gnus/gnus-notifications.el
[Gnus] Silence XEmacs compilation warnings
[gnu-emacs] / lisp / gnus / gnus-notifications.el
1 ;; gnus-notifications.el -- Send notification on new message in Gnus
2
3 ;; Copyright (C) 2012 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 ;; This implements notifications using `notifications-notify' on new
26 ;; messages received.
27 ;; Use (add-hook 'gnus-after-getting-new-news-hook 'gnus-notifications)
28 ;; to get notifications just after getting the new news.
29
30 ;;; Code:
31
32 (ignore-errors
33 (require 'notifications))
34 (require 'gnus-sum)
35 (require 'gnus-group)
36 (require 'gnus-int)
37 (require 'gnus-art)
38 (require 'gnus-util)
39 (ignore-errors
40 (require 'google-contacts)) ; Optional
41 (require 'gnus-fun)
42
43 (defgroup gnus-notifications nil
44 "Send notifications on new message in Gnus."
45 :group 'gnus)
46
47 (defcustom gnus-notifications-use-google-contacts t
48 "Use Google Contacts to retrieve photo."
49 :type 'boolean
50 :group 'gnus-notifications)
51
52 (defcustom gnus-notifications-use-gravatar t
53 "Use Gravatar to retrieve photo."
54 :type 'boolean
55 :group 'gnus-notifications)
56
57 (defcustom gnus-notifications-minimum-level 1
58 "Minimum group level the message should have to be notified.
59 Any message in a group that has a greater value than this will
60 not get notifications."
61 :type 'integer
62 :group 'gnus-notifications)
63
64 (defcustom gnus-notifications-timeout nil
65 "Timeout used for notifications sent via `notifications-notify'."
66 :type 'integer
67 :group 'gnus-notifications)
68
69 (defvar gnus-notifications-sent nil
70 "Notifications already sent.")
71
72 (defvar gnus-notifications-id-to-msg nil
73 "Map notifications ids to messages.")
74
75 (defun gnus-notifications-action (id key)
76 (when (string= key "read")
77 (let ((group-article (assoc id gnus-notifications-id-to-msg)))
78 (when group-article
79 (let ((group (cadr group-article))
80 (article (nth 2 group-article)))
81 (gnus-fetch-group group (list article)))))))
82
83 (defun gnus-notifications-notify (from subject photo-file)
84 "Send a notification about a new mail.
85 Return a notification id if any, or t on success."
86 (if (fboundp 'notifications-notify)
87 (gnus-funcall-no-warning
88 'notifications-notify
89 :title from
90 :body subject
91 :actions '("read" "Read")
92 :on-action 'gnus-notifications-action
93 :app-icon (gnus-funcall-no-warning
94 'image-search-load-path "gnus/gnus.png")
95 :app-name "Gnus"
96 :category "email.arrived"
97 :timeout gnus-notifications-timeout
98 :image-path photo-file)
99 (message "New message from %s: %s" from subject)
100 ;; Don't return an id
101 t))
102
103 (defun gnus-notifications-get-photo (mail-address)
104 "Get photo for mail address."
105 (let ((google-photo (when (and gnus-notifications-use-google-contacts
106 (fboundp 'google-contacts-get-photo))
107 (ignore-errors
108 (gnus-funcall-no-warning
109 'google-contacts-get-photo mail-address)))))
110 (if google-photo
111 google-photo
112 (when gnus-notifications-use-gravatar
113 (let ((gravatar (ignore-errors
114 (gravatar-retrieve-synchronously mail-address))))
115 (if (eq gravatar 'error)
116 nil
117 (plist-get (cdr gravatar) :data)))))))
118
119 (defun gnus-notifications-get-photo-file (mail-address)
120 "Get a temporary file with an image for MAIL-ADDRESS.
121 You have to delete the temporary image yourself using
122 `delete-image'.
123
124 Returns nil if no image found."
125 (let ((photo (gnus-notifications-get-photo mail-address)))
126 (when photo
127 (let ((photo-file (make-temp-file "gnus-notifications-photo-"))
128 (coding-system-for-write 'binary))
129 (with-temp-file photo-file
130 (insert photo))
131 photo-file))))
132
133 ;;;###autoload
134 (defun gnus-notifications ()
135 "Send a notification on new message.
136 This check for new messages that are in group with a level lower
137 or equal to `gnus-notifications-minimum-level' and send a
138 notification using `notifications-notify' for it.
139
140 This is typically a function to add in
141 `gnus-after-getting-new-news-hook'"
142 (dolist (entry gnus-newsrc-alist)
143 (let ((group (car entry)))
144 ;; Check that the group level is less than
145 ;; `gnus-notifications-minimum-level' and the the group has unread
146 ;; messages.
147 (when (and (<= (gnus-group-level group) gnus-notifications-minimum-level)
148 (let ((unread (gnus-group-unread group)))
149 (and (numberp unread)
150 (> unread 0))))
151 ;; Each group should have an entry in the `gnus-notifications-sent'
152 ;; alist. If not, we add one at this time.
153 (let ((group-notifications (or (assoc group gnus-notifications-sent)
154 ;; Nothing, add one and return it.
155 (assoc group
156 (add-to-list
157 'gnus-notifications-sent
158 (cons group nil))))))
159 (dolist (article (gnus-list-of-unread-articles group))
160 ;; Check if the article already has been notified
161 (unless (memq article (cdr group-notifications))
162 (with-current-buffer nntp-server-buffer
163 (gnus-request-head article group)
164 (article-decode-encoded-words) ; to decode mail addresses, subjects, etc
165 (let* ((address-components (mail-extract-address-components
166 (or (mail-fetch-field "From") "")))
167 (address (cadr address-components)))
168 ;; Ignore mails from ourselves
169 (unless (gnus-string-match-p gnus-ignored-from-addresses
170 address)
171 (let* ((photo-file (gnus-notifications-get-photo-file address))
172 (notification-id (gnus-notifications-notify
173 (or (car address-components) address)
174 (mail-fetch-field "Subject")
175 photo-file)))
176 (when notification-id
177 ;; Register that we did notify this message
178 (setcdr group-notifications (cons article (cdr group-notifications)))
179 (unless (eq notification-id t)
180 ;; Register the notification id for later actions
181 (add-to-list 'gnus-notifications-id-to-msg (list notification-id group article))))
182 (when photo-file
183 (delete-file photo-file)))))))))))))
184
185 (provide 'gnus-notifications)
186
187 ;;; gnus-notifications.el ends here