cgit.sxemacs.org Git - gnus/blob - lisp/gnus-sieve.el

   1 ;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
   2
   3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   4
   5 ;; Author: NAGY Andras <nagya@inf.elte.hu>,
   6 ;;      Simon Josefsson <simon@josefsson.org>
   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 2, or (at your option)
  13 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Gnus glue to generate complete Sieve scripts from Gnus Group
  28 ;; Parameters with "if" test predicates.
  29
  30 ;;; Code:
  31
  32 (require 'gnus)
  33 (require 'gnus-sum)
  34 (require 'format-spec)
  35 (autoload 'sieve-mode "sieve-mode")
  36 (eval-when-compile
  37   (require 'sieve))
  38
  39 ;; Variables
  40
  41 (defgroup gnus-sieve nil
  42   "Manage sieve scripts in Gnus."
  43   :group 'gnus)
  44
  45 (defcustom gnus-sieve-file "~/.sieve"
  46   "Path to your Sieve script."
  47   :type 'file
  48   :group 'gnus-sieve)
  49
  50 (defcustom gnus-sieve-region-start "\n## Begin Gnus Sieve Script\n"
  51   "Line indicating the start of the autogenerated region in
  52 your Sieve script."
  53   :type 'string
  54   :group 'gnus-sieve)
  55
  56 (defcustom gnus-sieve-region-end "\n## End Gnus Sieve Script\n"
  57   "Line indicating the end of the autogenerated region in
  58 your Sieve script."
  59   :type 'string
  60   :group 'gnus-sieve)
  61
  62 (defcustom gnus-sieve-select-method nil
  63   "Which select method we generate the Sieve script for.
  64
  65 For example: \"nnimap:mailbox\""
  66   :group 'gnus-sieve)
  67
  68 (defcustom gnus-sieve-crosspost t
  69   "Whether the generated Sieve script should do crossposting."
  70   :type 'boolean
  71   :group 'gnus-sieve)
  72
  73 (defcustom gnus-sieve-update-shell-command "echo put %f | sieveshell %s"
  74   "Shell command to execute after updating your Sieve script.  The following
  75 formatting characters are recognized:
  76
  77 %f    Script's file name (gnus-sieve-file)
  78 %s    Server name (from gnus-sieve-select-method)"
  79   :type 'string
  80   :group 'gnus-sieve)
  81
  82 ;;;###autoload
  83 (defun gnus-sieve-update ()
  84   "Update the Sieve script in gnus-sieve-file, by replacing the region
  85 between gnus-sieve-region-start and gnus-sieve-region-end with
  86 \(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\), then
  87 execute gnus-sieve-update-shell-command.
  88 See the documentation for these variables and functions for details."
  89   (interactive)
  90   (gnus-sieve-generate)
  91   (save-buffer)
  92   (shell-command
  93    (format-spec gnus-sieve-update-shell-command
  94                 (format-spec-make ?f gnus-sieve-file
  95                                   ?s (or (cadr (gnus-server-get-method
  96                                                 nil gnus-sieve-select-method))
  97                                          "")))))
  98
  99 ;;;###autoload
 100 (defun gnus-sieve-generate ()
 101   "Generate the Sieve script in gnus-sieve-file, by replacing the region
 102 between gnus-sieve-region-start and gnus-sieve-region-end with
 103 \(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\).
 104 See the documentation for these variables and functions for details."
 105   (interactive)
 106   (require 'sieve)
 107   (find-file gnus-sieve-file)
 108   (goto-char (point-min))
 109   (if (re-search-forward (regexp-quote gnus-sieve-region-start) nil t)
 110       (delete-region (match-end 0)
 111                      (or (re-search-forward (regexp-quote
 112                                              gnus-sieve-region-end) nil t)
 113                          (point)))
 114     (insert sieve-template))
 115   (insert gnus-sieve-region-start
 116           (gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost)
 117           gnus-sieve-region-end))
 118
 119 (defun gnus-sieve-guess-rule-for-article ()
 120   "Guess a sieve rule based on RFC822 article in buffer.
 121 Return nil if no rule could be guessed."
 122   (when (message-fetch-field "sender")
 123     `(sieve address "sender" ,(message-fetch-field "sender"))))
 124
 125 ;;;###autoload
 126 (defun gnus-sieve-article-add-rule ()
 127   (interactive)
 128   (gnus-summary-select-article nil 'force)
 129   (with-current-buffer gnus-original-article-buffer
 130     (let ((rule (gnus-sieve-guess-rule-for-article))
 131           (info (gnus-get-info gnus-newsgroup-name)))
 132       (if (null rule)
 133           (error "Could not guess rule for article")
 134         (gnus-info-set-params info (cons rule (gnus-info-params info)))
 135         (message "Added rule in group %s for article: %s" gnus-newsgroup-name
 136                  rule)))))
 137
 138 ;; Internals
 139
 140 ;; FIXME: do proper quoting of " etc
 141 (defun gnus-sieve-string-list (list)
 142   "Convert an elisp string list to a Sieve string list.
 143
 144 For example:
 145 \(gnus-sieve-string-list '(\"to\" \"cc\"))
 146   => \"[\\\"to\\\", \\\"cc\\\"]\"
 147 "
 148   (concat "[\"" (mapconcat 'identity list "\", \"") "\"]"))
 149
 150 (defun gnus-sieve-test-list (list)
 151   "Convert an elisp test list to a Sieve test list.
 152
 153 For example:
 154 \(gnus-sieve-test-list '((address \"sender\" \"boss@company.com\") (size :over 4K)))
 155   => \"(address \\\"sender\\\" \\\"boss@company.com\\\", size :over 4K)\""
 156   (concat "(" (mapconcat 'gnus-sieve-test list ", ") ")"))
 157
 158 ;; FIXME: do proper quoting
 159 (defun gnus-sieve-test-token (token)
 160   "Convert an elisp test token to a Sieve test token.
 161
 162 For example:
 163 \(gnus-sieve-test-token 'address)
 164   => \"address\"
 165
 166 \(gnus-sieve-test-token \"sender\")
 167   => \"\\\"sender\\\"\"
 168
 169 \(gnus-sieve-test-token '(\"to\" \"cc\"))
 170   => \"[\\\"to\\\", \\\"cc\\\"]\""
 171   (cond
 172    ((symbolp token)            ;; Keyword
 173     (symbol-name token))
 174
 175    ((stringp token)            ;; String
 176     (concat "\"" token "\""))
 177
 178    ((and (listp token)         ;; String list
 179          (stringp (car token)))
 180     (gnus-sieve-string-list token))
 181
 182    ((and (listp token)         ;; Test list
 183          (listp (car token)))
 184     (gnus-sieve-test-list token))))
 185
 186 (defun gnus-sieve-test (test)
 187   "Convert an elisp test to a Sieve test.
 188
 189 For example:
 190 \(gnus-sieve-test '(address \"sender\" \"sieve-admin@extundo.com\"))
 191   => \"address \\\"sender\\\" \\\"sieve-admin@extundo.com\\\"\"
 192
 193 \(gnus-sieve-test '(anyof ((header :contains (\"to\" \"cc\") \"my@address.com\")
 194                           (size :over 100K))))
 195   => \"anyof (header :contains [\\\"to\\\", \\\"cc\\\"] \\\"my@address.com\\\",
 196              size :over 100K)\""
 197   (mapconcat 'gnus-sieve-test-token test " "))
 198
 199 (defun gnus-sieve-script (&optional method crosspost)
 200   "Generate a Sieve script based on groups with select method METHOD
 201 \(or all groups if nil\).  Only groups having a `sieve' parameter are
 202 considered.  This parameter should contain an elisp test
 203 \(see the documentation of gnus-sieve-test for details\).  For each
 204 such group, a Sieve IF control structure is generated, having the
 205 test as the condition and { fileinto \"group.name\"; } as the body.
 206
 207 If CROSSPOST is nil, each conditional body contains a \"stop\" command
 208 which stops execution after a match is found.
 209
 210 For example: If the INBOX.list.sieve group has the
 211
 212   (sieve address \"sender\" \"sieve-admin@extundo.com\")
 213
 214 group parameter, (gnus-sieve-script) results in:
 215
 216   if address \"sender\" \"sieve-admin@extundo.com\" {
 217           fileinto \"INBOX.list.sieve\";
 218   }
 219
 220 This is returned as a string."
 221   (let* ((newsrc (cdr gnus-newsrc-alist))
 222          script)
 223     (dolist (info newsrc)
 224       (when (or (not method)
 225                 (gnus-server-equal method (gnus-info-method info)))
 226         (let* ((group (gnus-info-group info))
 227                (spec (gnus-group-find-parameter group 'sieve t)))
 228           (when spec
 229             (push (concat "if " (gnus-sieve-test spec) " {\n"
 230                           "\tfileinto \"" (gnus-group-real-name group) "\";\n"
 231                           (if crosspost
 232                               ""
 233                             "\tstop;\n")
 234                           "}")
 235                   script)))))
 236     (mapconcat 'identity script "\n")))
 237
 238 (provide 'gnus-sieve)
 239
 240 ;;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3
 241 ;;; gnus-sieve.el ends here