Skip to content

John McEleney / mailutils

Go to a project
Toggle navigation
Toggle navigation pinning
Commit cbc56136 cbc5613658f4ccba5e8ccc5bbae07db83a9bf0e4 by Sergey Poznyakoff
Options

Remove the Scheme implementation of the Sieve language. 

* NEWS: Describe the change.
* doc/texinfo/mailutils.texi: Remove description of sieve2scm
* doc/texinfo/programs.texi: Likewise.
* scheme/Makefile.am: Remove sieve2scm.
* scheme/mimeheader.scm: Remove.
* scheme/numaddr.scm: Remove.
* scheme/redirect.scm: Remove.
* scheme/reject.scm: Remove.
* scheme/sieve-core.scm: Remove.
* scheme/sieve2scm.scmi: Remove.
* scheme/vacation.scm: Remove.
1 parent ecbf0d3a
Expand all
Inline Side-by-side
Showing 11 changed files with 15 additions and 583 deletions
1 GNU mailutils NEWS -- history of user-visible changes. 2017-04-08 1 GNU mailutils NEWS -- history of user-visible changes. 2017-04-09
2 Copyright (C) 2002-2017 Free Software Foundation, Inc. 2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 See the end of file for copying conditions. 3 See the end of file for copying conditions.
4 4
...@@ -87,7 +87,16 @@ defined. Instead, the following constants are defined in config.h: ...@@ -87,7 +87,16 @@ defined. Instead, the following constants are defined in config.h:
87 MAILUTILS_VERSION_PATCH Patchlevel number (or 0, for stable releases). 87 MAILUTILS_VERSION_PATCH Patchlevel number (or 0, for stable releases).
88 88
89 * movemail: new option --progress-meter 89 * movemail: new option --progress-meter
90 90
91 * scheme implementation of the Sieve language discontinued
92
93 There's no reason to keep two different implementations of the Sieve
94 language within the same package. The principal implementation
95 (libmu_sieve) is faster, much more advanced and rich in features than
96 the implementation in Scheme. The decision has therefore been taken to
97 discontinue the latter and to concentrate all efforts on the further
98 development of the former.
99
91 100
92 Version 3.2 - 2017-03-11 101 Version 3.2 - 2017-03-11
93 102
......
...@@ -257,7 +257,6 @@ Reading Mail ...@@ -257,7 +257,6 @@ Reading Mail
257 @command{sieve} 257 @command{sieve}
258 258
259 * sieve interpreter:: A Sieve Interpreter 259 * sieve interpreter:: A Sieve Interpreter
260 * sieve2scm:: A Sieve to Scheme Translator and Filter
261 260
262 A Sieve Interpreter 261 A Sieve Interpreter
263 262
......
...@@ -5902,14 +5902,11 @@ only the first. ...@@ -5902,14 +5902,11 @@ only the first.
5902 @UNREVISED 5902 @UNREVISED
5903 5903
5904 Sieve is a language for filtering e-mail messages at time of final 5904 Sieve is a language for filtering e-mail messages at time of final
5905 delivery, described in RFC 3028. GNU Mailutils provides two 5905 delivery, described in RFC 3028. GNU Mailutils contains
5906 implementations of this language: a stand-alone @dfn{sieve interpreter} 5906 stand-alone @dfn{sieve interpreter}, which is described in detail below.
5907 and a @dfn{sieve translator and filter}. The following sections describe these
5908 utilities in detail.
5909 5907
5910 @menu 5908 @menu
5911 * sieve interpreter:: A Sieve Interpreter 5909 * sieve interpreter:: A Sieve Interpreter
5912 * sieve2scm:: A Sieve to Scheme Translator and Filter
5913 @end menu 5910 @end menu
5914 5911
5915 @node sieve interpreter 5912 @node sieve interpreter
...@@ -6250,41 +6247,6 @@ source for the required action NAME is not available ...@@ -6250,41 +6247,6 @@ source for the required action NAME is not available
6250 @end enumerate 6247 @end enumerate
6251 6248
6252 @c *********************************************************************** 6249 @c ***********************************************************************
6253
6254 @page
6255 @node sieve2scm
6256 @subsection A Sieve to Scheme Translator and Filter
6257 @UNREVISED
6258
6259 A Sieve to Scheme Translator @command{sieve2scm} translates a given
6260 Sieve script into an equivalent Scheme program and optionally executes
6261 it. The program itself is written in Scheme and requires presence of
6262 Guile version 1.8 or newer on the system. For more information on
6263 Guile refer to @ref{Top,,Overview,guile,The Guile Reference Manual}.
6264
6265 @table @option
6266 @item -f @var{filename}
6267 @itemx --file @var{filename}
6268 Set input file name.
6269
6270 @item -o @var{filename}
6271 @itemx --output @var{filename}
6272 Set output file name
6273
6274 @item -L @var{dirname}
6275 @itemx --lib-dir @var{dirname}
6276 Set sieve library directory name
6277
6278 @item -d @var{level}
6279 @itemx --debug @var{level}
6280 Set debugging level
6281 @end table
6282
6283 The Scheme programs produced by @command{sieve2scm} can be used with
6284 @command{guimb} or @command{maidag}.
6285
6286 @c ***********************************************************************
6287
6288 @page 6250 @page
6289 @node guimb 6251 @node guimb
6290 @section @command{guimb} --- A Mailbox Scanning and Processing Language 6252 @section @command{guimb} --- A Mailbox Scanning and Processing Language
......
...@@ -15,19 +15,7 @@ ...@@ -15,19 +15,7 @@
15 ## You should have received a copy of the GNU General Public License 15 ## You should have received a copy of the GNU General Public License
16 ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>. 16 ## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17 17
18 bin_SCRIPTS = sieve2scm guimb 18 bin_SCRIPTS = guimb
19
20 # FIXME: Sieve2scm is temporarly exempted from installchecks because
21 # it may fail starting during checks, if libguile-mailutils-v- library
22 # has not been previously installed. The proper fix would be to alter
23 # %load-path during tests.
24 AM_INSTALLCHECK_STD_OPTIONS_EXEMPT=sieve2scm
25
26 sievemoddir=@MU_GUILE_SIEVE_MOD_DIR@
27
28 sieve2scm: sieve2scm.scmi package.sed
29 $(AM_V_GEN)sed -f package.sed $(srcdir)/sieve2scm.scmi > sieve2scm
30 $(AM_V_at)chmod +w sieve2scm
31 19
32 guimb: guimb.scmi package.sed 20 guimb: guimb.scmi package.sed
33 $(AM_V_GEN)sed -f package.sed $(srcdir)/guimb.scmi > guimb 21 $(AM_V_GEN)sed -f package.sed $(srcdir)/guimb.scmi > guimb
...@@ -37,26 +25,12 @@ package.sed: Makefile ...@@ -37,26 +25,12 @@ package.sed: Makefile
37 $(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > package.sed 25 $(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > package.sed
38 $(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> package.sed 26 $(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> package.sed
39 $(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> package.sed 27 $(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> package.sed
40 $(AM_V_at)echo 's,%LIBDIR%,$(sievemoddir),g' >> package.sed
41 $(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> package.sed 28 $(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> package.sed
42 $(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> package.sed 29 $(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> package.sed
43 30
44 CLEANFILES = sieve2scm guimb package.sed 31 CLEANFILES = guimb package.sed
45
46 sitedir=@GUILE_SITE@/$(PACKAGE)
47 site_DATA=sieve-core.scm
48
49 sievemod_DATA=\
50 mimeheader.scm\
51 numaddr.scm\
52 redirect.scm\
53 reject.scm\
54 vacation.scm
55 32
56 EXTRA_DIST=\ 33 EXTRA_DIST=\
57 $(sievemod_DATA)\
58 sieve-core.scm\
59 sieve2scm.scmi\
60 guimb.scmi 34 guimb.scmi
61 35
62 installcheck-binSCRIPTS: $(bin_SCRIPTS) 36 installcheck-binSCRIPTS: $(bin_SCRIPTS)
......
1 ;;;; GNU Mailutils -- a suite of utilities for electronic mail
2 ;;;; Copyright (C) 1999-2001, 2007, 2010-2012, 2014-2017 Free Software
3 ;;;; Foundation, Inc.
4 ;;;;
5 ;;;; GNU Mailutils is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 3, or (at your option)
8 ;;;; any later version.
9 ;;;;
10 ;;;; GNU Mailutils is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License along
16 ;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17
18 ;;;; This module provides GNU extension test "mimeheader".
19
20 ;;;; Syntax: mimeheader [COMPARATOR] [MATCH-TYPE]
21 ;;;; <header-names: string-list> <key-list: string-list>
22 ;;;;
23 ;;;; The "mimeheader" test evaluates to true if in any part of the
24 ;;;; multipart MIME message a header name from <header-names> list
25 ;;;; matches any key from <key-list>. If the message is not multipart,
26 ;;;; "mimeheader" test is equivalent to "header" test.
27 ;;;;
28 ;;;; The arguments to "mimeheader" test are the same as to "header" test.
29
30 ;;;; Example:
31 ;;;;
32 ;;;; require [ "mimeheader", "reject"];
33 ;;;; if mimeheader :matches "Content-Type" "*application/msword;*" {
34 ;;;; reject "Please do not send data in a proprietary format.";
35 ;;;; }
36
37 (define (test-mimeheader header-list key-list . opt-args)
38 (if (mu-message-multipart? sieve-current-message)
39 (let ((mime-count (mu-message-get-num-parts sieve-current-message))
40 (comp (find-comp opt-args))
41 (match (find-match opt-args)))
42 (call-with-current-continuation
43 (lambda (exit)
44 (do ((n 1 (1+ n)))
45 ((> n mime-count) #f)
46 (let ((msg (mu-message-get-part sieve-current-message n)))
47 (if msg
48 (for-each
49 (lambda (key)
50 (let ((header-fields (mu-message-get-header-fields
51 msg
52 header-list))
53 (rx (if (eq? match #:matches)
54 (make-regexp (sieve-regexp-to-posix key)
55 (if (eq? comp string-ci=?)
56 regexp/icase
57 '()))
58 #f)))
59 (for-each
60 (lambda (h)
61 (let ((hdr (cdr h)))
62 (if hdr
63 (case match
64 ((#:is)
65 (if (comp hdr key)
66 (exit #t)))
67 ((#:contains)
68 (if (sieve-str-str hdr key comp)
69 (exit #t)))
70 ((#:matches)
71 (if (regexp-exec rx hdr)
72 (exit #t)))))))
73 header-fields)))
74 key-list)
75 #f))))))
76 (apply test-header header-list key-list opt-args)))
77
78 ;;; Register the test at compile time
79 (if sieve-parser
80 (sieve-register-test "mimeheader"
81 test-mimeheader
82 (list 'string-list 'string-list)
83 (append comparator match-type)))
1 ;;;; GNU Mailutils -- a suite of utilities for electronic mail
2 ;;;; Copyright (C) 1999-2001, 2007, 2010-2012, 2014-2017 Free Software
3 ;;;; Foundation, Inc.
4 ;;;;
5 ;;;; GNU Mailutils is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 3, or (at your option)
8 ;;;; any later version.
9 ;;;;
10 ;;;; GNU Mailutils is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License along
16 ;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17
18 ;;;; This module provides GNU extension test "numaddr".
19
20 ;;;; Syntax: numaddr [":over" / ":under"] <header-names: string-list>
21 ;;;; <limit: number>
22 ;;;; The "numaddr" test counts Internet addresses in structured headers
23 ;;;; that contain addresses. It returns true if the total number of
24 ;;;; addresses satisfies the requested relation:
25 ;;;;
26 ;;;; If the argument is ":over" and the number of addresses is greater than
27 ;;;; the number provided, the test is true; otherwise, it is false.
28 ;;;;
29 ;;;; If the argument is ":under" and the number of addresses is less than
30 ;;;; the number provided, the test is true; otherwise, it is false.
31 ;;;;
32 ;;;; If the argument is empty, ":over" is assumed.
33
34 ;;;; Example:
35 ;;;;
36 ;;;; require [ "numaddr" ];
37 ;;;; if numaddr :over [ "To", "Cc" ] 50 { discard; }
38
39 (define (test-numaddr header-list count . comp)
40 (let ((total-count 0)
41 (header-fields (mu-message-get-header-fields
42 sieve-current-message
43 header-list))
44 (compfun (cond
45 ((or (null? (car comp)) (eq? (car comp) #:over))
46 (lambda (val lim)
47 (> val lim)))
48 ((eq? (car comp) #:under)
49 (lambda (val lim)
50 (< val lim)))
51 (else
52 (runtime-message SIEVE-ERROR
53 "test-numaddr: unknown comparator "
54 comp)))))
55 (call-with-current-continuation
56 (lambda (exit)
57 (for-each
58 (lambda (h)
59 (let ((hdr (cdr h)))
60 (if hdr
61 (let ((naddr (mu-address-get-count hdr)))
62 (set! total-count (+ total-count naddr))
63 (if (compfun total-count count)
64 (exit #t))))))
65 header-fields)
66 #f))))
67
68 ;;; Register the test at compile time
69 (if sieve-parser
70 (sieve-register-test "numaddr"
71 test-numaddr
72 (list 'string-list 'number)
73 size-comp))
1 ;;;; GNU Mailutils -- a suite of utilities for electronic mail
2 ;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
3 ;;;; Software Foundation, Inc.
4 ;;;;
5 ;;;; GNU Mailutils is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 3, or (at your option)
8 ;;;; any later version.
9 ;;;;
10 ;;;; GNU Mailutils is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License along
16 ;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17
18 ;;;; This module provides sieve's "redirect" action.
19
20 ;;; rfc3028 says:
21 ;;; "Implementations SHOULD take measures to implement loop control,"
22 ;;; We do this by appending an "X-Sender" header to each message
23 ;;; being redirected. If one of the "X-Sender" headers of the message
24 ;;; contains our email address, we assume it is a loop and bail out.
25
26 (define (sent-from-me? msg)
27 (call-with-current-continuation
28 (lambda (exit)
29 (for-each
30 (lambda (hdr)
31 (if (and (string-ci=? (car hdr) "X-Sender")
32 (string-ci=? (mu-address-get-email (cdr hdr))
33 sieve-my-email))
34 (exit #t)))
35 (mu-message-get-header-fields sieve-current-message))
36 #f)))
37
38 ;;; redirect action
39 (define (action-redirect address)
40 (sieve-verbose-print "REDIRECT" "to address " address)
41 (handle-exception
42 (if sieve-my-email
43 (cond
44 ((sent-from-me? sieve-current-message)
45 (runtime-message SIEVE-WARNING "Redirection loop detected"))
46 (else
47 (let ((out-msg (mu-message-copy sieve-current-message))
48 (sender (mu-message-get-sender sieve-current-message)))
49 (mu-message-set-header out-msg "X-Sender" sieve-my-email)
50 (mu-message-send out-msg #f sender address)
51 (mu-message-destroy out-msg))
52 (mu-message-delete sieve-current-message))))))
53
54 ;;; Register action
55 (if sieve-parser
56 (sieve-register-action "redirect" action-redirect (list 'string) '()))
57
58
59
1 ;;;; GNU Mailutils -- a suite of utilities for electronic mail
2 ;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
3 ;;;; Software Foundation, Inc.
4 ;;;;
5 ;;;; GNU Mailutils is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 3, or (at your option)
8 ;;;; any later version.
9 ;;;;
10 ;;;; GNU Mailutils is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License along
16 ;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17
18 ;;;; This module provides sieve's "reject" action.
19
20 (define sieve-option-quote #t)
21
22 (define (action-reject reason)
23 (sieve-verbose-print "REJECT")
24 (handle-exception
25 (let ((mime (mu-mime-create 0))
26 (datestr (strftime "%a, %b %d %H:%M:%S %Y %Z"
27 (localtime (current-time))))
28 (sender (mu-message-get-sender sieve-current-message)))
29 (let* ((mesg (mu-message-create))
30 (port (mu-message-get-port mesg "w")))
31
32 (display "The original message was received at " port)
33 (display datestr port)
34 (newline port)
35 (display "from " port)
36 (display sender port)
37 (display ".\n" port)
38
39 (display "Message was refused by recipient's mail filtering program.\n"
40 port)
41 (display "Reason given was as follows:\n" port)
42 (newline port)
43 (display reason port)
44
45 (close-output-port port)
46 (mu-mime-add-part mime mesg))
47
48 ;; message/delivery-status
49 (let* ((mesg (mu-message-create))
50 (port (mu-message-get-port mesg "w")))
51 (mu-message-set-header mesg "Content-Type" "message/delivery-status")
52
53 (display (string-append "Reporting-UA: sieve; "
54 mu-package-string "\n") port)
55 (display (string-append "Arrival-Date: " datestr "\n") port)
56 (newline port)
57
58 (display (string-append "Final-Recipient: RFC822; " sieve-my-email "\n")
59 port)
60
61 (display "Action: deleted\n" port);
62 (display "Disposition: automatic-action/MDN-sent-automatically;deleted\n"
63 port)
64 (display (string-append
65 "Last-Attempt-Date: " datestr "\n") port)
66
67 (close-output-port port)
68 (mu-mime-add-part mime mesg))
69
70 ;; Quote original message
71 (let* ((mesg (mu-message-create))
72 (port (mu-message-get-port mesg "w"))
73 (in-port (mu-message-get-port sieve-current-message "r" #t)))
74 (mu-message-set-header mesg "Content-Type" "message/rfc822")
75
76 (do ((line (read-line in-port) (read-line in-port)))
77 ((eof-object? line) #f)
78 (display line port)
79 (newline port))
80
81 (close-input-port in-port)
82 (close-output-port port)
83 (mu-mime-add-part mime mesg))
84
85 (mu-message-send (mu-mime-get-message mime) #f sieve-daemon-email sender)
86 (mu-message-delete sieve-current-message))))
87
88 ;;; Register action
89 (if sieve-parser
90 (sieve-register-action "reject" action-reject (list 'string) '()))
91
92
93
94
95
1 ;;;; GNU Mailutils -- a suite of utilities for electronic mail
2 ;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
3 ;;;; Software Foundation, Inc.
4 ;;;;
5 ;;;; GNU Mailutils is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 3, or (at your option)
8 ;;;; any later version.
9 ;;;;
10 ;;;; GNU Mailutils is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License along
16 ;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
17
18 ;;;; This module provides "vacation" extension
19
20 ;;; vacation example:
21 ;;; vacation :days 18
22 ;;; :aliases ["gray@gnu.org", "gray@mirddin.farlep.net"]
23 ;;; :addresses ["bug-mailutils@gnu.org","bug-inetutils@gnu.org"]
24 ;;; :subject "I'm on vacation"
25 ;;; :mime
26 ;;; text:
27 ;;; I am on vacation until July 22. I'll attend your message as soon
28 ;;; as I'm back.
29 ;;; .
30 ;;;
31 ;;; Additionally, the :sender flag may be used to debug the script.
32
33 ;; Debugging flag
34 (define vacation-debug #f)
35
36 ;; Each entry is (cons SENDER DATE), where SENDER is the sender email
37 ;; address (lowercase) and DATE is the date where the first message
38 ;; from this sender was received.
39 (define vacation-db '())
40
41 (define (vacation-downcase name)
42 (let ((len (string-length name)))
43 (do ((i 0 (1+ i)))
44 ((= i len) name)
45 (string-set! name i (char-downcase (string-ref name i))))))
46
47 (define (vacation-db-name)
48 (let ((pwd (mu-getpwuid (getuid))))
49 (string-append (vector-ref pwd 5) "/.vacation.db")))
50
51 (define (vacation-db-load)
52 (catch #t
53 (lambda ()
54 (call-with-input-file (vacation-db-name)
55 (lambda (port)
56 (set! vacation-db (read port)))))
57 (lambda args args)))
58
59 (define (vacation-db-save)
60 (catch #t
61 (lambda ()
62 (let ((mask (umask #o077)))
63 (call-with-output-file (vacation-db-name)
64 (lambda (port)
65 (display ";; Vacation database file\n" port)
66 (display ";; Generated automatically. Please do not edit\n"
67 port)
68 (write vacation-db port)))
69 (umask mask)))
70 (lambda args args)))
71
72 (define (vacation-db-lookup sender days)
73 (vacation-db-load)
74 (let ((val (assoc (vacation-downcase sender) vacation-db)))
75 (cond
76 (val
77 (cond
78 ((and days (> days 0))
79 (<= (- (car (gettimeofday)) (cdr val)) (* days 86400)))
80 (else
81 #t)))
82 (else
83 #f))))
84
85 (define (vacation-db-update msg)
86 (let* ((sender (vacation-downcase (mu-message-get-sender msg)))
87 (date (car (gettimeofday)))
88 (val (assoc sender vacation-db)))
89 (cond
90 (val
91 (set-cdr! val date))
92 (else
93 (set! vacation-db (append vacation-db (list
94 (cons sender date)))))))
95 (vacation-db-save))
96
97 (define vacation-noreply-senders
98 (list
99 ".*-REQUEST@.*"
100 ".*-RELAY@.*"
101 ".*-OWNER@.*"
102 "OWNER-.*"
103 "postmaster@.*"
104 "UUCP@.*"
105 "MAILER@.*"
106 "MAILER-DAEMON@.*"))
107
108 (define (vacation-reply? msg aliases addresses days)
109 (let ((sender (mu-message-get-sender msg)))
110 (and
111 ;; No message will be sent unless an alias is part of either
112 ;; the "To:" or "Cc:" headers of the mail.
113 (call-with-current-continuation
114 (lambda (exit)
115 (for-each
116 (lambda (hdr)
117 (cond
118 (hdr
119 (let ((count (mu-address-get-count hdr)))
120 (do ((i 1 (1+ i)))
121 ((> i count) #f)
122 (let ((email (mu-address-get-email hdr i)))
123 (for-each
124 (lambda (alias)
125 (if (string-ci=? alias email)
126 (exit #t)))
127 aliases)))))))
128 (list (mu-message-get-header msg "To")
129 (mu-message-get-header msg "Cc")))
130 #f))
131
132 ;; Messages sent from one of the vacation-noreply-senders are not
133 ;; responded to
134 (call-with-current-continuation
135 (lambda (exit)
136 (do ((explist (append vacation-noreply-senders addresses)
137 (cdr explist)))
138 ((null? explist) #t)
139 (let ((rx (make-regexp (car explist) regexp/icase)))
140 (if (regexp-exec rx sender)
141 (exit #f))))))
142
143 ;; Messages with Precedence: bulk or junk are not responded to
144 (let ((prec (mu-message-get-header msg "Precedence")))
145 (not (and prec (or (string-ci=? prec "bulk")
146 (string-ci=? prec "junk")))))
147
148 ;; Senders already in the database get no response
149 (not (vacation-db-lookup sender days)))))
150
151 (define (vacation-send-reply subject text sender)
152 (let ((sender "root@localhost")
153 (mesg (mu-message-create)))
154 (let ((port (mu-message-get-port mesg "w")))
155 (display text port)
156 (close-output-port port))
157 (mu-message-set-header mesg "X-Sender"
158 (string-append "vacation.scm, " mu-package-string)
159 #t)
160 (mu-message-send mesg #f #f sender)))
161
162 (define (action-vacation text . opt)
163 (sieve-verbose-print "VACATION")
164 (set! vacation-debug (member #:debug opt))
165 (if vacation-debug
166 (begin
167 (display sieve-current-message)(display ": ")))
168 (cond
169 ((vacation-reply? sieve-current-message
170 (append (list sieve-my-email)
171 (sieve-get-opt-arg opt #:aliases '()))
172 (sieve-get-opt-arg opt #:addresses '())
173 (sieve-get-opt-arg opt #:days #f))
174 (vacation-send-reply (sieve-get-opt-arg
175 opt #:subject
176 (string-append "Re: "
177 (mu-message-get-header
178 sieve-current-message
179 "Subject")))
180 text
181 (sieve-get-opt-arg
182 opt #:sender
183 (mu-message-get-sender sieve-current-message)))
184 (vacation-db-update sieve-current-message)
185 (if vacation-debug
186 (display "WILL REPLY\n")))
187 (vacation-debug
188 (display "WILL NOT REPLY\n"))))
189
190 ;;; Register action
191 (if sieve-parser
192 (sieve-register-action "vacation"
193 action-vacation
194 (list 'string)
195 (list (cons "days" 'number)
196 (cons "addresses" 'string-list)
197 (cons "aliases" 'string-list)
198 (cons "subject" 'string)
199 (cons "sender" 'string)
200 (cons "mime" #f)
201 (cons "debug" #f))))
202