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