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
GNU mailutils NEWS -- history of user-visible changes. 2017-04-08
GNU mailutils NEWS -- history of user-visible changes. 2017-04-09
Copyright (C) 2002-2017 Free Software Foundation, Inc.
See the end of file for copying conditions.
......@@ -87,7 +87,16 @@ defined. Instead, the following constants are defined in config.h:
MAILUTILS_VERSION_PATCH Patchlevel number (or 0, for stable releases).
* movemail: new option --progress-meter
* scheme implementation of the Sieve language discontinued
There's no reason to keep two different implementations of the Sieve
language within the same package. The principal implementation
(libmu_sieve) is faster, much more advanced and rich in features than
the implementation in Scheme. The decision has therefore been taken to
discontinue the latter and to concentrate all efforts on the further
development of the former.
Version 3.2 - 2017-03-11
......
......@@ -257,7 +257,6 @@ Reading Mail
@command{sieve}
* sieve interpreter:: A Sieve Interpreter
* sieve2scm:: A Sieve to Scheme Translator and Filter
A Sieve Interpreter
......
......@@ -5902,14 +5902,11 @@ only the first.
@UNREVISED
Sieve is a language for filtering e-mail messages at time of final
delivery, described in RFC 3028. GNU Mailutils provides two
implementations of this language: a stand-alone @dfn{sieve interpreter}
and a @dfn{sieve translator and filter}. The following sections describe these
utilities in detail.
delivery, described in RFC 3028. GNU Mailutils contains
stand-alone @dfn{sieve interpreter}, which is described in detail below.
@menu
* sieve interpreter:: A Sieve Interpreter
* sieve2scm:: A Sieve to Scheme Translator and Filter
@end menu
@node sieve interpreter
......@@ -6250,41 +6247,6 @@ source for the required action NAME is not available
@end enumerate
@c ***********************************************************************
@page
@node sieve2scm
@subsection A Sieve to Scheme Translator and Filter
@UNREVISED
A Sieve to Scheme Translator @command{sieve2scm} translates a given
Sieve script into an equivalent Scheme program and optionally executes
it. The program itself is written in Scheme and requires presence of
Guile version 1.8 or newer on the system. For more information on
Guile refer to @ref{Top,,Overview,guile,The Guile Reference Manual}.
@table @option
@item -f @var{filename}
@itemx --file @var{filename}
Set input file name.
@item -o @var{filename}
@itemx --output @var{filename}
Set output file name
@item -L @var{dirname}
@itemx --lib-dir @var{dirname}
Set sieve library directory name
@item -d @var{level}
@itemx --debug @var{level}
Set debugging level
@end table
The Scheme programs produced by @command{sieve2scm} can be used with
@command{guimb} or @command{maidag}.
@c ***********************************************************************
@page
@node guimb
@section @command{guimb} --- A Mailbox Scanning and Processing Language
......
......@@ -15,19 +15,7 @@
## You should have received a copy of the GNU General Public License
## along with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
bin_SCRIPTS = sieve2scm guimb
# FIXME: Sieve2scm is temporarly exempted from installchecks because
# it may fail starting during checks, if libguile-mailutils-v- library
# has not been previously installed. The proper fix would be to alter
# %load-path during tests.
AM_INSTALLCHECK_STD_OPTIONS_EXEMPT=sieve2scm
sievemoddir=@MU_GUILE_SIEVE_MOD_DIR@
sieve2scm: sieve2scm.scmi package.sed
$(AM_V_GEN)sed -f package.sed $(srcdir)/sieve2scm.scmi > sieve2scm
$(AM_V_at)chmod +w sieve2scm
bin_SCRIPTS = guimb
guimb: guimb.scmi package.sed
$(AM_V_GEN)sed -f package.sed $(srcdir)/guimb.scmi > guimb
......@@ -37,26 +25,12 @@ package.sed: Makefile
$(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > package.sed
$(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> package.sed
$(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> package.sed
$(AM_V_at)echo 's,%LIBDIR%,$(sievemoddir),g' >> package.sed
$(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> package.sed
$(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> package.sed
CLEANFILES = sieve2scm guimb package.sed
sitedir=@GUILE_SITE@/$(PACKAGE)
site_DATA=sieve-core.scm
sievemod_DATA=\
mimeheader.scm\
numaddr.scm\
redirect.scm\
reject.scm\
vacation.scm
CLEANFILES = guimb package.sed
EXTRA_DIST=\
$(sievemod_DATA)\
sieve-core.scm\
sieve2scm.scmi\
guimb.scmi
installcheck-binSCRIPTS: $(bin_SCRIPTS)
......
;;;; GNU Mailutils -- a suite of utilities for electronic mail
;;;; Copyright (C) 1999-2001, 2007, 2010-2012, 2014-2017 Free Software
;;;; Foundation, Inc.
;;;;
;;;; GNU Mailutils is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3, or (at your option)
;;;; any later version.
;;;;
;;;; GNU Mailutils is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License along
;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
;;;; This module provides GNU extension test "mimeheader".
;;;; Syntax: mimeheader [COMPARATOR] [MATCH-TYPE]
;;;; <header-names: string-list> <key-list: string-list>
;;;;
;;;; The "mimeheader" test evaluates to true if in any part of the
;;;; multipart MIME message a header name from <header-names> list
;;;; matches any key from <key-list>. If the message is not multipart,
;;;; "mimeheader" test is equivalent to "header" test.
;;;;
;;;; The arguments to "mimeheader" test are the same as to "header" test.
;;;; Example:
;;;;
;;;; require [ "mimeheader", "reject"];
;;;; if mimeheader :matches "Content-Type" "*application/msword;*" {
;;;; reject "Please do not send data in a proprietary format.";
;;;; }
(define (test-mimeheader header-list key-list . opt-args)
(if (mu-message-multipart? sieve-current-message)
(let ((mime-count (mu-message-get-num-parts sieve-current-message))
(comp (find-comp opt-args))
(match (find-match opt-args)))
(call-with-current-continuation
(lambda (exit)
(do ((n 1 (1+ n)))
((> n mime-count) #f)
(let ((msg (mu-message-get-part sieve-current-message n)))
(if msg
(for-each
(lambda (key)
(let ((header-fields (mu-message-get-header-fields
msg
header-list))
(rx (if (eq? match #:matches)
(make-regexp (sieve-regexp-to-posix key)
(if (eq? comp string-ci=?)
regexp/icase
'()))
#f)))
(for-each
(lambda (h)
(let ((hdr (cdr h)))
(if hdr
(case match
((#:is)
(if (comp hdr key)
(exit #t)))
((#:contains)
(if (sieve-str-str hdr key comp)
(exit #t)))
((#:matches)
(if (regexp-exec rx hdr)
(exit #t)))))))
header-fields)))
key-list)
#f))))))
(apply test-header header-list key-list opt-args)))
;;; Register the test at compile time
(if sieve-parser
(sieve-register-test "mimeheader"
test-mimeheader
(list 'string-list 'string-list)
(append comparator match-type)))
;;;; GNU Mailutils -- a suite of utilities for electronic mail
;;;; Copyright (C) 1999-2001, 2007, 2010-2012, 2014-2017 Free Software
;;;; Foundation, Inc.
;;;;
;;;; GNU Mailutils is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3, or (at your option)
;;;; any later version.
;;;;
;;;; GNU Mailutils is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License along
;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
;;;; This module provides GNU extension test "numaddr".
;;;; Syntax: numaddr [":over" / ":under"] <header-names: string-list>
;;;; <limit: number>
;;;; The "numaddr" test counts Internet addresses in structured headers
;;;; that contain addresses. It returns true if the total number of
;;;; addresses satisfies the requested relation:
;;;;
;;;; If the argument is ":over" and the number of addresses is greater than
;;;; the number provided, the test is true; otherwise, it is false.
;;;;
;;;; If the argument is ":under" and the number of addresses is less than
;;;; the number provided, the test is true; otherwise, it is false.
;;;;
;;;; If the argument is empty, ":over" is assumed.
;;;; Example:
;;;;
;;;; require [ "numaddr" ];
;;;; if numaddr :over [ "To", "Cc" ] 50 { discard; }
(define (test-numaddr header-list count . comp)
(let ((total-count 0)
(header-fields (mu-message-get-header-fields
sieve-current-message
header-list))
(compfun (cond
((or (null? (car comp)) (eq? (car comp) #:over))
(lambda (val lim)
(> val lim)))
((eq? (car comp) #:under)
(lambda (val lim)
(< val lim)))
(else
(runtime-message SIEVE-ERROR
"test-numaddr: unknown comparator "
comp)))))
(call-with-current-continuation
(lambda (exit)
(for-each
(lambda (h)
(let ((hdr (cdr h)))
(if hdr
(let ((naddr (mu-address-get-count hdr)))
(set! total-count (+ total-count naddr))
(if (compfun total-count count)
(exit #t))))))
header-fields)
#f))))
;;; Register the test at compile time
(if sieve-parser
(sieve-register-test "numaddr"
test-numaddr
(list 'string-list 'number)
size-comp))
;;;; GNU Mailutils -- a suite of utilities for electronic mail
;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
;;;; Software Foundation, Inc.
;;;;
;;;; GNU Mailutils is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3, or (at your option)
;;;; any later version.
;;;;
;;;; GNU Mailutils is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License along
;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
;;;; This module provides sieve's "redirect" action.
;;; rfc3028 says:
;;; "Implementations SHOULD take measures to implement loop control,"
;;; We do this by appending an "X-Sender" header to each message
;;; being redirected. If one of the "X-Sender" headers of the message
;;; contains our email address, we assume it is a loop and bail out.
(define (sent-from-me? msg)
(call-with-current-continuation
(lambda (exit)
(for-each
(lambda (hdr)
(if (and (string-ci=? (car hdr) "X-Sender")
(string-ci=? (mu-address-get-email (cdr hdr))
sieve-my-email))
(exit #t)))
(mu-message-get-header-fields sieve-current-message))
#f)))
;;; redirect action
(define (action-redirect address)
(sieve-verbose-print "REDIRECT" "to address " address)
(handle-exception
(if sieve-my-email
(cond
((sent-from-me? sieve-current-message)
(runtime-message SIEVE-WARNING "Redirection loop detected"))
(else
(let ((out-msg (mu-message-copy sieve-current-message))
(sender (mu-message-get-sender sieve-current-message)))
(mu-message-set-header out-msg "X-Sender" sieve-my-email)
(mu-message-send out-msg #f sender address)
(mu-message-destroy out-msg))
(mu-message-delete sieve-current-message))))))
;;; Register action
(if sieve-parser
(sieve-register-action "redirect" action-redirect (list 'string) '()))
;;;; GNU Mailutils -- a suite of utilities for electronic mail
;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
;;;; Software Foundation, Inc.
;;;;
;;;; GNU Mailutils is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3, or (at your option)
;;;; any later version.
;;;;
;;;; GNU Mailutils is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License along
;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
;;;; This module provides sieve's "reject" action.
(define sieve-option-quote #t)
(define (action-reject reason)
(sieve-verbose-print "REJECT")
(handle-exception
(let ((mime (mu-mime-create 0))
(datestr (strftime "%a, %b %d %H:%M:%S %Y %Z"
(localtime (current-time))))
(sender (mu-message-get-sender sieve-current-message)))
(let* ((mesg (mu-message-create))
(port (mu-message-get-port mesg "w")))
(display "The original message was received at " port)
(display datestr port)
(newline port)
(display "from " port)
(display sender port)
(display ".\n" port)
(display "Message was refused by recipient's mail filtering program.\n"
port)
(display "Reason given was as follows:\n" port)
(newline port)
(display reason port)
(close-output-port port)
(mu-mime-add-part mime mesg))
;; message/delivery-status
(let* ((mesg (mu-message-create))
(port (mu-message-get-port mesg "w")))
(mu-message-set-header mesg "Content-Type" "message/delivery-status")
(display (string-append "Reporting-UA: sieve; "
mu-package-string "\n") port)
(display (string-append "Arrival-Date: " datestr "\n") port)
(newline port)
(display (string-append "Final-Recipient: RFC822; " sieve-my-email "\n")
port)
(display "Action: deleted\n" port);
(display "Disposition: automatic-action/MDN-sent-automatically;deleted\n"
port)
(display (string-append
"Last-Attempt-Date: " datestr "\n") port)
(close-output-port port)
(mu-mime-add-part mime mesg))
;; Quote original message
(let* ((mesg (mu-message-create))
(port (mu-message-get-port mesg "w"))
(in-port (mu-message-get-port sieve-current-message "r" #t)))
(mu-message-set-header mesg "Content-Type" "message/rfc822")
(do ((line (read-line in-port) (read-line in-port)))
((eof-object? line) #f)
(display line port)
(newline port))
(close-input-port in-port)
(close-output-port port)
(mu-mime-add-part mime mesg))
(mu-message-send (mu-mime-get-message mime) #f sieve-daemon-email sender)
(mu-message-delete sieve-current-message))))
;;; Register action
(if sieve-parser
(sieve-register-action "reject" action-reject (list 'string) '()))
;;;; GNU Mailutils -- a suite of utilities for electronic mail
;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
;;;; Software Foundation, Inc.
;;;;
;;;; GNU Mailutils is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3, or (at your option)
;;;; any later version.
;;;;
;;;; GNU Mailutils is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License along
;;;; with GNU Mailutils. If not, see <http://www.gnu.org/licenses/>.
;;;; This module provides "vacation" extension
;;; vacation example:
;;; vacation :days 18
;;; :aliases ["gray@gnu.org", "gray@mirddin.farlep.net"]
;;; :addresses ["bug-mailutils@gnu.org","bug-inetutils@gnu.org"]
;;; :subject "I'm on vacation"
;;; :mime
;;; text:
;;; I am on vacation until July 22. I'll attend your message as soon
;;; as I'm back.
;;; .
;;;
;;; Additionally, the :sender flag may be used to debug the script.
;; Debugging flag
(define vacation-debug #f)
;; Each entry is (cons SENDER DATE), where SENDER is the sender email
;; address (lowercase) and DATE is the date where the first message
;; from this sender was received.
(define vacation-db '())
(define (vacation-downcase name)
(let ((len (string-length name)))
(do ((i 0 (1+ i)))
((= i len) name)
(string-set! name i (char-downcase (string-ref name i))))))
(define (vacation-db-name)
(let ((pwd (mu-getpwuid (getuid))))
(string-append (vector-ref pwd 5) "/.vacation.db")))
(define (vacation-db-load)
(catch #t
(lambda ()
(call-with-input-file (vacation-db-name)
(lambda (port)
(set! vacation-db (read port)))))
(lambda args args)))
(define (vacation-db-save)
(catch #t
(lambda ()
(let ((mask (umask #o077)))
(call-with-output-file (vacation-db-name)
(lambda (port)
(display ";; Vacation database file\n" port)
(display ";; Generated automatically. Please do not edit\n"
port)
(write vacation-db port)))
(umask mask)))
(lambda args args)))
(define (vacation-db-lookup sender days)
(vacation-db-load)
(let ((val (assoc (vacation-downcase sender) vacation-db)))
(cond
(val
(cond
((and days (> days 0))
(<= (- (car (gettimeofday)) (cdr val)) (* days 86400)))
(else
#t)))
(else
#f))))
(define (vacation-db-update msg)
(let* ((sender (vacation-downcase (mu-message-get-sender msg)))
(date (car (gettimeofday)))
(val (assoc sender vacation-db)))
(cond
(val
(set-cdr! val date))
(else
(set! vacation-db (append vacation-db (list
(cons sender date)))))))
(vacation-db-save))
(define vacation-noreply-senders
(list
".*-REQUEST@.*"
".*-RELAY@.*"
".*-OWNER@.*"
"OWNER-.*"
"postmaster@.*"
"UUCP@.*"
"MAILER@.*"
"MAILER-DAEMON@.*"))
(define (vacation-reply? msg aliases addresses days)
(let ((sender (mu-message-get-sender msg)))
(and
;; No message will be sent unless an alias is part of either
;; the "To:" or "Cc:" headers of the mail.
(call-with-current-continuation
(lambda (exit)
(for-each
(lambda (hdr)
(cond
(hdr
(let ((count (mu-address-get-count hdr)))
(do ((i 1 (1+ i)))
((> i count) #f)
(let ((email (mu-address-get-email hdr i)))
(for-each
(lambda (alias)
(if (string-ci=? alias email)
(exit #t)))
aliases)))))))
(list (mu-message-get-header msg "To")
(mu-message-get-header msg "Cc")))
#f))
;; Messages sent from one of the vacation-noreply-senders are not
;; responded to
(call-with-current-continuation
(lambda (exit)
(do ((explist (append vacation-noreply-senders addresses)
(cdr explist)))
((null? explist) #t)
(let ((rx (make-regexp (car explist) regexp/icase)))
(if (regexp-exec rx sender)
(exit #f))))))
;; Messages with Precedence: bulk or junk are not responded to
(let ((prec (mu-message-get-header msg "Precedence")))
(not (and prec (or (string-ci=? prec "bulk")
(string-ci=? prec "junk")))))
;; Senders already in the database get no response
(not (vacation-db-lookup sender days)))))
(define (vacation-send-reply subject text sender)
(let ((sender "root@localhost")
(mesg (mu-message-create)))
(let ((port (mu-message-get-port mesg "w")))
(display text port)
(close-output-port port))
(mu-message-set-header mesg "X-Sender"
(string-append "vacation.scm, " mu-package-string)
#t)
(mu-message-send mesg #f #f sender)))
(define (action-vacation text . opt)
(sieve-verbose-print "VACATION")
(set! vacation-debug (member #:debug opt))
(if vacation-debug
(begin
(display sieve-current-message)(display ": ")))
(cond
((vacation-reply? sieve-current-message
(append (list sieve-my-email)
(sieve-get-opt-arg opt #:aliases '()))
(sieve-get-opt-arg opt #:addresses '())
(sieve-get-opt-arg opt #:days #f))
(vacation-send-reply (sieve-get-opt-arg
opt #:subject
(string-append "Re: "
(mu-message-get-header
sieve-current-message
"Subject")))
text
(sieve-get-opt-arg
opt #:sender
(mu-message-get-sender sieve-current-message)))
(vacation-db-update sieve-current-message)
(if vacation-debug
(display "WILL REPLY\n")))
(vacation-debug
(display "WILL NOT REPLY\n"))))
;;; Register action
(if sieve-parser
(sieve-register-action "vacation"
action-vacation
(list 'string)
(list (cons "days" 'number)
(cons "addresses" 'string-list)
(cons "aliases" 'string-list)
(cons "subject" 'string)
(cons "sender" 'string)
(cons "mime" #f)
(cons "debug" #f))))