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