diff options
author | Sergey Poznyakoff <gray@gnu.org> | 2017-04-09 20:25:22 +0300 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org> | 2017-04-09 20:25:22 +0300 |
commit | cbc5613658f4ccba5e8ccc5bbae07db83a9bf0e4 (patch) | |
tree | cfa64a7240d296cd08cc6805ab1cb750dd83344b | |
parent | ecbf0d3a1ab03da431257128d66c5a242a0294a5 (diff) | |
download | mailutils-cbc5613658f4ccba5e8ccc5bbae07db83a9bf0e4.tar.gz mailutils-cbc5613658f4ccba5e8ccc5bbae07db83a9bf0e4.tar.bz2 |
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.
-rw-r--r-- | NEWS | 13 | ||||
-rw-r--r-- | doc/texinfo/mailutils.texi | 1 | ||||
-rw-r--r-- | doc/texinfo/programs.texi | 42 | ||||
-rw-r--r-- | scheme/Makefile.am | 30 | ||||
-rw-r--r-- | scheme/mimeheader.scm | 83 | ||||
-rw-r--r-- | scheme/numaddr.scm | 73 | ||||
-rw-r--r-- | scheme/redirect.scm | 59 | ||||
-rw-r--r-- | scheme/reject.scm | 95 | ||||
-rw-r--r-- | scheme/sieve-core.scm | 496 | ||||
-rw-r--r-- | scheme/sieve2scm.scmi | 1090 | ||||
-rw-r--r-- | scheme/vacation.scm | 202 |
11 files changed, 15 insertions, 2169 deletions
@@ -1,4 +1,4 @@ -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 diff --git a/doc/texinfo/mailutils.texi b/doc/texinfo/mailutils.texi index 1cdde58dc..b2c6030fe 100644 --- a/doc/texinfo/mailutils.texi +++ b/doc/texinfo/mailutils.texi @@ -257,7 +257,6 @@ Reading Mail @command{sieve} * sieve interpreter:: A Sieve Interpreter -* sieve2scm:: A Sieve to Scheme Translator and Filter A Sieve Interpreter diff --git a/doc/texinfo/programs.texi b/doc/texinfo/programs.texi index e479944dc..8e420f9ea 100644 --- a/doc/texinfo/programs.texi +++ b/doc/texinfo/programs.texi @@ -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 diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 91fd00470..1b65f593d 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -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) diff --git a/scheme/mimeheader.scm b/scheme/mimeheader.scm deleted file mode 100644 index 113d5f515..000000000 --- a/scheme/mimeheader.scm +++ /dev/null @@ -1,83 +0,0 @@ -;;;; 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))) diff --git a/scheme/numaddr.scm b/scheme/numaddr.scm deleted file mode 100644 index 48a9f3fda..000000000 --- a/scheme/numaddr.scm +++ /dev/null @@ -1,73 +0,0 @@ -;;;; 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)) diff --git a/scheme/redirect.scm b/scheme/redirect.scm deleted file mode 100644 index d4e6151a8..000000000 --- a/scheme/redirect.scm +++ /dev/null @@ -1,59 +0,0 @@ -;;;; 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) '())) - - - diff --git a/scheme/reject.scm b/scheme/reject.scm deleted file mode 100644 index ed80aed18..000000000 --- a/scheme/reject.scm +++ /dev/null @@ -1,95 +0,0 @@ -;;;; 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) '())) - - - - - diff --git a/scheme/sieve-core.scm b/scheme/sieve-core.scm deleted file mode 100644 index 862dfdb2f..000000000 --- a/scheme/sieve-core.scm +++ /dev/null @@ -1,496 +0,0 @@ -;;;; 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 core functionality for the sieve scripts. - -(define-module (mailutils sieve-core)) - -(use-modules (mailutils mailutils)) - -;;; Set to #t when parsing -(define-public sieve-parser #f) - -;;; Name of the input source -(define-public sieve-source "UNKNOWN") - -;;; The email address for originator of error messages. Should be <> -;;; but current mailutils API is unable to parse and handle it. -;;; Site administrators are supposed to replace it with the -;;; actual value. -(define-public sieve-daemon-email "MAILER-DAEMON@localhost") - -;;; The email address of the user whose mailbox is being processed. -;;; If #f, it will be set by sieve-main -(define-public sieve-my-email #f) - -(define SIEVE-WARNING "Warning") -(define SIEVE-ERROR "Error") -(define SIEVE-NOTICE "Notice") - -(defmacro handle-exception (. expr) - `(catch 'mailutils-error - (lambda () ,@expr) - (lambda (key . args) - (runtime-message SIEVE-ERROR - "In function " (car args) ": " - (apply format #f - (list-ref args 1) (list-ref args 2)) - (let ((error-code - (car (list-ref args (1- (length args)))))) - (if (= error-code 0) - "" - (string-append - "; Error code: " - (number->string error-code) - " - " - (mu-strerror error-code)))))))) - -;;; Set to #t if verbose action listing is requested -(define-public sieve-verbose #f) - -(defmacro sieve-verbose-print (action . rest) - `(if sieve-verbose - (let ((uid (false-if-exception - (mu-message-get-uid sieve-current-message)))) - (display ,action) - (display " on msg uid ") - (display uid) - (let ((args (list ,@rest))) - (cond ((not (null? args)) - (display ": ") - (for-each - display - args)))) - (newline)))) - -;;; List of open mailboxes. -;;; Each entry is: (list MAILBOX-NAME OPEN-FLAGS MBOX) -(define sieve-mailbox-list '()) - -;;; Cached mailbox open: Lookup in the list first, if not found, -;;; call mu-mailbox-open and append to the list. -;;; NOTE: second element of each slot (OPEN-FLAGS) is not currently -;;; used, sinse all the mailboxes are open with "cw". -(define (sieve-mailbox-open name flags) - (let ((slot (assoc name sieve-mailbox-list))) - (if slot - (list-ref slot 2) - (let ((mbox (false-if-exception (mu-mailbox-open name flags)))) - (if mbox - (set! sieve-mailbox-list (append - sieve-mailbox-list - (list - (list name flags mbox))))) - mbox)))) - -;;; Close all open mailboxes. -(define (sieve-close-mailboxes) - (for-each - (lambda (slot) - (cond - ((list-ref slot 2) - => (lambda (mbox) - (mu-mailbox-close mbox))))) - sieve-mailbox-list) - (set! sieve-mailbox-list '())) - -(define (sieve-expand-filename filename) - (case (string-ref filename 0) - ((#\/ #\% #\~ #\+ #\=) - filename) - (else - (let ((pw (getpwuid (geteuid)))) - (if (vector? pw) - (string-append (vector-ref pw 5) - "/" - filename) - filename))))) - -;;; Comparators -(define-public sieve-standard-comparators - (list (list "i;octet" string=?) - (list "i;ascii-casemap" string-ci=?))) - -;;; Stop statement - -(define-public (sieve-stop) - (sieve-verbose-print "STOP") - (throw 'sieve-stop)) - -;;; Basic five actions: - -;;; reject is defined in reject.scm - -;;; fileinto - -(define-public (action-fileinto filename) - (let ((name (sieve-expand-filename filename))) - (sieve-verbose-print "FILEINTO" "delivering into " name) - (if (string? name) - (let ((outbox (sieve-mailbox-open name "cw"))) - (cond - (outbox - (handle-exception - (mu-mailbox-append-message outbox sieve-current-message) - (mu-message-delete sieve-current-message))) - (else - (runtime-message SIEVE-ERROR - "Could not open mailbox " name)))) - (runtime-message SIEVE-ERROR - "Could not expand mailbox name " filename)))) - -;;; redirect is defined in redirect.scm - -;;; keep -- does nothing worth mentioning :^) - -(define-public (action-keep) - (sieve-verbose-print "KEEP") - (handle-exception - (mu-message-delete sieve-current-message #f))) - -;;; discard - -(define-public (action-discard) - (sieve-verbose-print "DISCARD" "marking as deleted") - (handle-exception - (mu-message-delete sieve-current-message))) - -;;; Register standard actions -(define-public sieve-standard-actions - (list (list "keep" action-keep '() '()) - (list "discard" action-discard '() '()) - (list "fileinto" action-fileinto (list 'string) '()))) - -;;; Some utilities. - -(define (sieve-get-opt-arg opt-args tag default) - (cond - ((member tag opt-args) => - (lambda (x) - (car (cdr x)))) - (else - default))) - -(define (find-comp opt-args) - (sieve-get-opt-arg opt-args #:comparator string-ci=?)) - -(define (find-match opt-args) - (cond - ((member #:is opt-args) - #:is) - ((member #:contains opt-args) - #:contains) - ((member #:matches opt-args) - #:matches) - ((member #:regex opt-args) - #:regex) - (else - #:is))) - -(define (sieve-str-str str key comp) - (if (string-null? key) - ;; rfc3028: - ;; If a header listed in the header-names argument exists, it contains - ;; the null key (""). However, if the named header is not present, it - ;; does not contain the null key. - ;; This function gets called only if the header was present. So: - #t - (let* ((char (string-ref key 0)) - (str-len (string-length str)) - (key-len (string-length key)) - (limit (- str-len key-len))) - (if (< limit 0) - #f - (call-with-current-continuation - (lambda (xx) - (do ((index 0 (1+ index))) - ((cond - ((> index limit) - #t) - ;; FIXME: This is very inefficient, but I have to use this - ;; provided (string-index str (string-ref key 0)) may not - ;; work... - ((comp (substring str index (+ index key-len)) - key) - (xx #t)) - (else - #f)) #f)) - #f)))))) - -;;; Convert sieve-style regexps to POSIX: - -(define (sieve-regexp-to-posix regexp) - (let ((length (string-length regexp))) - (do ((cl '()) - (escape #f) - (i 0 (1+ i))) - ((= i length) (list->string (reverse cl))) - (let ((ch (string-ref regexp i))) - (cond - (escape - (set! cl (append (list ch) cl)) - (set! escape #f)) - ((char=? ch #\\) - (set! escape #t)) - ((char=? ch #\?) - (set! cl (append (list #\.) cl))) - ((char=? ch #\*) - (set! cl (append (list #\* #\.) cl))) - ((member ch (list #\. #\$ #\^ #\[ #\])) - (set! cl (append (list ch #\\) cl))) - (else - (set! cl (append (list ch) cl)))))))) - - -(define (get-regex match key comp) - (case match - ((#:matches) - (make-regexp (sieve-regexp-to-posix key) - (if (eq? comp string-ci=?) - regexp/icase - '()))) - ((#:regex) - (make-regexp key - (if (eq? comp string-ci=?) - regexp/icase - '()))) - (else - #f))) - -;;;; Standard tests: - -(define-public (test-address header-list key-list . opt-args) - (let ((comp (find-comp opt-args)) - (match (find-match opt-args)) - (part (cond - ((member #:localpart opt-args) - #:localpart) - ((member #:domain opt-args) - #:domain) - (else - #:all)))) - (call-with-current-continuation - (lambda (exit) - (for-each - (lambda (key) - (let ((header-fields (mu-message-get-header-fields - sieve-current-message - header-list)) - (rx (get-regex match key comp))) - (for-each - (lambda (h) - (let ((hdr (cdr h))) - (if hdr - (let ((naddr (mu-address-get-count hdr))) - (do ((n 1 (1+ n))) - ((> n naddr) #f) - (let ((addr (case part - ((#:all) - (mu-address-get-email hdr n)) - ((#:localpart) - (mu-address-get-local hdr n)) - ((#:domain) - (mu-address-get-domain hdr n))))) - (if addr - (case match - ((#:is) - (if (comp addr key) - (exit #t))) - ((#:contains) - (if (sieve-str-str addr key comp) - (exit #t))) - ((#:matches #:regex) - (if (regexp-exec rx addr) - (exit #t)))) - (runtime-message SIEVE-NOTICE - "Can't get address parts for message " - sieve-current-message)))))))) - header-fields))) - key-list) - #f)))) - -(define-public (test-size key-size . comp) - (let ((size (mu-message-get-size sieve-current-message))) - (cond - ((null? comp) ;; An extension. - (= size key-size)) - ((eq? (car comp) #:over) - (> size key-size)) - ((eq? (car comp) #:under) - (< size key-size)) - (else - (runtime-message SIEVE-ERROR "test-size: unknown comparator " comp))))) - -(define-public (test-envelope part-list key-list . opt-args) - (let ((comp (find-comp opt-args)) - (match (find-match opt-args))) - (call-with-current-continuation - (lambda (exit) - (for-each - (lambda (part) - (cond - ((string-ci=? part "From") - (let ((sender (mu-message-get-sender sieve-current-message))) - (for-each - (lambda (key) - (if (comp key sender) - (exit #t))) - key-list))) - (else - (runtime-message SIEVE-ERROR - "Envelope part " part " not supported") - #f))) - part-list) - #f)))) - -(define-public (test-exists header-list) - (call-with-current-continuation - (lambda (exit) - (for-each (lambda (hdr) - (let ((val (mu-message-get-header sieve-current-message hdr))) - (if (or (not val) (= (string-length val) 0)) - (exit #f)))) - header-list) - #t))) - -(define-public (test-header header-list key-list . opt-args) - (let ((comp (find-comp opt-args)) - (match (find-match opt-args))) - (call-with-current-continuation - (lambda (exit) - (for-each - (lambda (key) - (let ((header-fields (mu-message-get-header-fields - sieve-current-message - header-list)) - (rx (get-regex match key comp))) - (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 #:regex) - (if (regexp-exec rx hdr) - (exit #t))))))) - header-fields))) - key-list) - #f)))) - -;;; Register tests: -(define address-part (list (cons "localpart" #f) - (cons "domain" #f) - (cons "all" #f))) -(define match-type (list (cons "is" #f) - (cons "contains" #f) - (cons "matches" #f) - (cons "regex" #f))) -(define size-comp (list (cons "under" #f) - (cons "over" #f))) -(define comparator (list (cons "comparator" 'string))) - -(define-public sieve-standard-tests - (list - (list "address" - test-address - (list 'string-list 'string-list) - (append address-part comparator match-type)) - (list "size" - test-size - (list 'number) - size-comp) - (list "envelope" - test-envelope - (list 'string-list 'string-list) - (append comparator address-part match-type)) - (list "exists" - test-exists - (list 'string-list) - '()) - (list "header" - test-header - (list 'string-list 'string-list) - (append comparator match-type)) - (list "false" #f '() '()) - (list "true" #t '() '()))) - -;;; runtime-message - -(define-public (runtime-message level . text) - (let ((msg (apply string-append - (map (lambda (x) - (format #f "~A" x)) - (append - (list "(in " sieve-source ") ") - text))))) - (if sieve-current-message - (mu-message-set-header sieve-current-message - (string-append "X-Sieve-" level) - msg)) - (if (isatty? (current-error-port)) - (display (string-append level ": " msg "\n") (current-error-port))))) - -;;; Sieve-main -(define-public sieve-mailbox #f) -(define-public sieve-current-message #f) - -(define-public (sieve-run-current-message thunk) - (and (catch 'sieve-stop - thunk - (lambda args - #f)) - (sieve-verbose-print "IMPLICIT KEEP"))) - -(define (sieve-run thunk) - (if (not sieve-my-email) - (set! sieve-my-email (mu-username->email))) -; (DEBUG 1 "Mailbox: " sieve-mailbox) - - (let msg-loop ((msg (mu-mailbox-first-message sieve-mailbox))) - (if (not (eof-object? msg)) - (begin - (set! sieve-current-message msg) - (sieve-run-current-message thunk) - (msg-loop (mu-mailbox-next-message sieve-mailbox))))) - - (sieve-close-mailboxes)) - -(define (sieve-command-line) - (catch #t - (lambda () - (let ((args sieve-script-args)) - (append (list "<temp-file>") args))) - (lambda args (command-line)))) - -(define-public (sieve-main thunk) - (handle-exception - (let* ((cl (sieve-command-line)) - (name (if (and (not (null? (cdr cl))) - (string? (cadr cl))) - (cadr cl) - (mu-user-mailbox-url - (passwd:name (mu-getpwuid (getuid))))))) - - (set! sieve-mailbox (mu-mailbox-open name "rw")) - (sieve-run thunk) - (mu-mailbox-expunge sieve-mailbox) - (mu-mailbox-close sieve-mailbox)))) diff --git a/scheme/sieve2scm.scmi b/scheme/sieve2scm.scmi deleted file mode 100644 index 4bed3 |