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