1;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
2
3;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007 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
52your 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
58your 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
65For 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
75formatting 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
85between gnus-sieve-region-start and gnus-sieve-region-end with
86\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\), then
87execute gnus-sieve-update-shell-command.
88See 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
102between gnus-sieve-region-start and gnus-sieve-region-end with
103\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\).
104See 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-beginning 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.
121Return 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
144For 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
153For 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
162For 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
189For 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
202considered.  This parameter should contain an elisp test
203\(see the documentation of gnus-sieve-test for details\).  For each
204such group, a Sieve IF control structure is generated, having the
205test as the condition and { fileinto \"group.name\"; } as the body.
206
207If CROSSPOST is nil, each conditional body contains a \"stop\" command
208which stops execution after a match is found.
209
210For example: If the INBOX.list.sieve group has the
211
212  (sieve address \"sender\" \"sieve-admin@extundo.com\")
213
214group parameter, (gnus-sieve-script) results in:
215
216  if address \"sender\" \"sieve-admin@extundo.com\" {
217          fileinto \"INBOX.list.sieve\";
218  }
219
220This 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
242