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
Inline Side-by-side
Showing 11 changed files with 15 additions and 2169 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 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))))
#! %GUILE_BINDIR%/guile -s
# Emacs, it's -*- scheme -*-
!#
;;;; GNU Mailutils -- a suite of utilities for electronic mail
;;;; Copyright (C) 1999-2001, 2006-2007, 2009-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 is a Sieve to Scheme translator.
;;;;
;;;; To convert a sieve script into equivalent Scheme program, run:
;;;;
;;;; guile -s sieve2scm.scm --file <sieve-script-name> --output <output-file-name>
;;;;
;;;; To compile and execute a sieve script upon a mailbox, run:
;;;;
;;;; guile -s sieve2scm.scm --file <sieve-script-name> [mailbox-name]
;;;;
(if (not (member "%GUILE_SITE%" %load-path))
(set! %load-path (cons "%GUILE_SITE%" %load-path)))
(use-modules (ice-9 getopt-long)
(ice-9 rdelim)
(mailutils sieve-core))
(set! sieve-parser #t)
(define sieve-debug 0)
(define sieve-libdir "%LIBDIR%")
(define sieve-load-files '())
(define sieve-script-args '())
(define request-verbose #f)
(define error-count 0)
(define current-token #f)
(define putback-list '())
(define input-port #f)
(define input-file "")
(define input-line-number 0)
(define input-line "")
(define input-index 0)
(define input-length 0)
(define nesting-level 0)
(define recovery-line-number -1)
(define recovery-index -1)
(define (DEBUG level . rest)
(if (>= sieve-debug level)
(begin
(display "DEBUG(")
(display level)
(display "):")
(for-each (lambda (x)
(display x))
rest)
(newline))))
;;;; Lexical scanner
(define (delimiter? c)
(or (member c (list #\[ #\] #\{ #\} #\, #\; #\( #\)))
(char-whitespace? c)))
(define (lex-error . rest)
(set! error-count (1+ error-count))
(with-output-to-port
(current-error-port)
(lambda ()
(display input-file)
(display ":")
(display input-line-number)
(display ": ")
(for-each (lambda (x)
(display x))
rest)
(newline)))
#t)
(define (syntax-error . rest)
(set! error-count (1+ error-count))
(with-output-to-port
(current-error-port)
(lambda ()
(display input-file)
(display ":")
(display input-line-number)
(display ": ")
(for-each (lambda (x)
(display x))
rest)
(newline)))
(throw 'syntax-error))
;;; If current input position points to end of line or to a start of
;;; # comment, return #f. Otherwise return cons whose car contains
;;; token type and cdr contains token itself (string).
(define (next-token)
(let ((start (do ((i input-index (1+ i)))
((or (>= i input-length)
(not (char-whitespace? (string-ref input-line i))))
i))))
; (DEBUG 100 "START " start ": " (substring input-line start))
(if (< start input-length)
(let ((char (string-ref input-line start)))
(DEBUG 100 "CHAR " char)
(case char
((#\#)
(set! input-index input-length)
#f)
((#\[ #\] #\{ #\} #\( #\) #\, #\;)
(set! input-index (1+ start))
(cons 'delimiter char))
((#\")
(let ((end (do ((end (1+ start) (1+ end)))
((or (>= end input-length)
(char=? (string-ref input-line end) #\"))
end))))
(if (>= end input-length)
(lex-error "Unterminated string constant"))
(set! input-index (1+ end))
(cons 'string (substring input-line (1+ start) end))))
(else
(DEBUG 100 "MATCH else")
(cond
((and (char=? (string-ref input-line start) #\/)
(< (1+ start) input-length)
(char=? (string-ref input-line (1+ start)) #\*))
(set! input-index (+ start 2))
(cons 'bracket-comment "/*"))
((char-numeric? char)
(let* ((end (do ((end start (1+ end)))
((or
(>= end (1- input-length))
(not (char-numeric?
(string-ref input-line end))))
(cond
((char-numeric? (string-ref input-line end))
(1+ end))
(else
end)))))
(num (string->number (substring input-line start end)))
(q (if (< end input-length)
(string-ref input-line end)
#f))
(k 1))
(case q
((#f) #f) ;; nothing
((#\K)
(set! end (1+ end))
(set! k 1024))
((#\M)
(set! end (1+ end))
(set! k 1048576))
((#\G)
(set! end (1+ end))
(set! k 1073741824))
(else
(if (not (delimiter? q))
(lex-error "Unknown qualifier (" q ")"))))
(set! input-index end)
(cons 'number (* num k))))
(else
(let ((end (do ((end start (1+ end)))
((or (>= end input-length)
(delimiter? (string-ref input-line end)))
end))))
(DEBUG 100 "END " end)
(set! input-index end)
(cond
((char=? char #\:)
(cons 'tag (substring input-line (1+ start) end)))
(else
(cons 'identifier (substring input-line start end))))))))))
#f)))
(define (end-of-line?)
(do ((i input-index (1+ i)))
((or (>= i input-length)
(not (char-whitespace? (string-ref input-line i))))
(>= i input-length))))
(define (read-input-line port)
(set! input-line (read-line port))
(if (not (eof-object? input-line))
(begin
(set! input-line-number (1+ input-line-number))
(set! input-length (string-length input-line))
(set! input-index 0)))
input-line)
(define (next-token-from-port port)
(let ((tok (or (next-token)
(begin
(DEBUG 100 "2nd")
(set! input-line (read-line port))
(if (not (eof-object? input-line))
(begin
(set! input-line-number (1+ input-line-number))
(set! input-length (string-length input-line))
(set! input-index 0)
(next-token))
input-line)))))
(cond
((or (not tok) (eof-object? tok))
tok)
((and (eq? (car tok) 'identifier)
(string=? (cdr tok) "text:")
(end-of-line?))
(let ((text "")
(string-start input-line-number))
(do ((line (read-line port) (read-line port)))
((or (and
(eof-object? line)
(lex-error
"Unexpected end of file in multiline string started on line "
string-start)
(throw 'end-of-file))
(let ((len (string-length line)))
(and (> len 0)
(char=? (string-ref line 0) #\.)
(do ((i 1 (1+ i)))
((or (>= i len)
(not
(char-whitespace?
(string-ref line i))))
(>= i len))))))
#f)
(set! input-line-number (1+ input-line-number))
(if (and (not (string-null? line))
(char=? (string-ref line 0) #\.)
(char=? (string-ref line 1) #\.))
(set! line (substring line 1)))
(set! text (string-append text "\n" line)))
(set! input-length 0)
(set! input-index 0)
(cons 'string text)))
((eq? (car tok) 'bracket-comment)
(let ((comment-start input-line-number))
(set! input-length (- input-length input-index))
(if (> input-length 0)
(begin
(set! input-line
(substring input-line input-index input-length))
(set! input-index 0))
(read-input-line port))
(do ()
((> input-index 0) #f)
(cond
((eof-object? input-line)
(lex-error
"Unexpected end of file in comment started on line "
comment-start)
(throw 'end-of-file))
(else
(let ((t (string-index input-line #\*)))
(if (and t
(< (1+ t) input-length)
(char=? (string-ref input-line (1+ t)) #\/))
(set! input-index (+ t 2))
(read-input-line port))))))))
(else
tok))))
(define (delimiter token c)
(and (pair? token)
(eq? (car token) 'delimiter)
(char=? (cdr token) c)))
(define (identifier token c)
(and (eq? (car token) 'identifier)
(string=? (cdr token) c)))
(define (putback-token)
(set! putback-list (append (list current-token)
putback-list)))
(define (read-token)
(cond
((not (null? putback-list))
(set! current-token (car putback-list))
(set! putback-list (cdr putback-list)))
(else
(set! current-token (do ((token (next-token-from-port input-port)
(next-token-from-port input-port)))
(token token)))))
current-token)
(define (require-semicolon . read)
(if (null? read)
(read-token))
(if (or (eof-object? current-token)
(not (delimiter current-token #\;)))
(syntax-error "Missing ;")
current-token))
(define (require-tag . read)
(if (null? read)
(read-token))
(cond
((eof-object? current-token)
(syntax-error "Expected tag but found " current-token))
((not (eq? (car current-token) 'tag))
(syntax-error "Expected tag but found " (car current-token))))
current-token)
(define (require-string . read)
(if (null? read)
(read-token))
(cond
((eof-object? current-token)
(syntax-error "Expected string but found " current-token))
((not (eq? (car current-token) 'string))
(syntax-error "Expected string but found " (car current-token))))
current-token)
(define (require-number . read)
(if (null? read)
(read-token))
(cond
((eof-object? current-token)
(syntax-error "Expected number but found " current-token))
((not (eq? (car current-token) 'number))
(syntax-error "Expected number but found " (car current-token))))
current-token)
(define (require-string-list . read)
(if (null? read)
(read-token))
(cond
((eof-object? current-token)
(syntax-error "Expected string-list but found " current-token))
((eq? (car current-token) 'string)
(list 'string-list (cdr current-token)))
((not (eq? (car current-token) 'delimiter))
(syntax-error "Expected string-list but found " (car current-token)))
((char=? (cdr current-token) #\[)
(do ((slist '())
(token (read-token) (read-token)))
((if (not (eq? (car token) 'string))
(begin
(syntax-error "Expected string but found " (car token))
#t)
(begin
(set! slist (append slist (list (cdr token))))
(read-token)
(cond
((eof-object? current-token)
(syntax-error "Unexpected end of file in string list")
#t) ;; break;
((eq? (car current-token) 'delimiter)
(cond
((char=? (cdr current-token) #\,) #f) ;; continue
((char=? (cdr current-token) #\]) #t) ;; break
(else
(lex-error "Expected ',' or ']' but found "
(cdr current-token))
#t)))
(else
(lex-error "Expected delimiter but found "
(car current-token))
#t))))
(cons 'string-list slist))))
(else
(syntax-error "Expected '[' but found " (car current-token)))))
(define (require-identifier . read)
(if (null? read)
(read-token))
(cond
((eof-object? current-token)
(syntax-error "1. Expected identifier but found " current-token))
((not (eq? (car current-token) 'identifier))
(syntax-error "2. Expected identifier but found " (car current-token))))
current-token)
;;;;
;;; Syntax tables.
;;; A syntax table is a list of
;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
;;; NAME is a string representing the input language keyword,
;;; FUNCTION is a corresponding function:
;;; (define (foo [arg [arg...]] . opt-args)
;;; OPT-ARG-LIST is a list of optional arguments (tags),
;;; REQ-ARG-LIST is a list of required (positional) arguments
(define (sieve-syntax-table-lookup table name)
(let ((entry (assoc name table)))
(if entry
(cdr entry)
#f)))
(define-macro (sieve-syntax-table-add table name function req-arg-list opt-arg-list)
`(cond
((not (list? ,opt-arg-list))
(lex-error "sieve-syntax-table-add: opt-arg-list must be a list"))
((not (list? ,req-arg-list))
(lex-error "sieve-syntax-table-add: req-arg-list must be a list"))
((not (or (eq? ,function #f)
(eq? ,function #t)
(procedure? ,function)))
(lex-error "sieve-syntax-table-add: bad type for function " ,function))
(else
(set! ,table
(append ,table
(list
(list ,name ,function ,opt-arg-list ,req-arg-list)))))))
;;;;
(defmacro do-for-all (fun rest)
`(for-each
(lambda (x)
(apply ,fun x))
,rest))
;;;; Available syntax tables.
;;;; Comparators
;;; Syntax table for comparators. The opt-arg-list and req-arg-list have
;;; no meaning for comparators, so they are ignored. The handler function
;;; names must start with "comparator-"
(define sieve-comparator-table '())
(define (sieve-find-comparator name)
(sieve-syntax-table-lookup sieve-comparator-table name))
(define (sieve-register-comparator name function)
(sieve-syntax-table-add sieve-comparator-table name function '() '()))
;;; Register standard comparators
(do-for-all sieve-register-comparator sieve-standard-comparators)
;;;; Sieve Tests
;;; Syntax table for tests. Function names must start with "test-"
(define sieve-test-table '())
(define (sieve-find-test name)
(sieve-syntax-table-lookup sieve-test-table name))
(define (sieve-register-test name function req-arg-list opt-arg-list)
(sieve-syntax-table-add sieve-test-table name function
req-arg-list opt-arg-list))
;;; Register standard tests
(do-for-all sieve-register-test sieve-standard-tests)
;;;; Sieve Actions
;;; Syntax table for actions. Function names start with "action-"
(define sieve-action-table '())
(define (sieve-find-action name)
(sieve-syntax-table-lookup sieve-action-table name))
(define (sieve-register-action name function req-arg-list opt-arg-list)
(sieve-syntax-table-add sieve-action-table name function
req-arg-list opt-arg-list))
;;; Register standard actions
(do-for-all sieve-register-action sieve-standard-actions)
;;;;
;;;; Command parsers
;;; sieve-preprocess-arguments: Preprocess and group the arguments. Returns
;;; a cons whose car is a list of all optional arguments, and the cdr is
;;; a list of the rest of the arguments.
;;;
;;; arguments = *argument [test / test-list]
;;; argument = string-list / number / tag
(define (sieve-preprocess-arguments tag-gram)
(do ((opt-list '()) ;; List of optional arguments (tags)
(arg-list '()) ;; List of positional arguments
(last-tag #f) ;; Description of the last tag from tag-gram
(state 'opt) ;; 'opt when scanning optional arguments,
;; 'arg when scanning positional arguments
(token (read-token) (read-token))) ;; Obtain next token
((cond
((eof-object? token)
(syntax-error "Expected argument but found " token))
((eq? (car token) 'tag)
(if (not (eq? state 'opt))
(syntax-error "Misplaced tag: :" (cdr token)))
(set! last-tag (assoc (cdr token) tag-gram))
(if (not last-tag)
(syntax-error
"Tag :" (cdr token) " is not allowed in this context"))
(set! opt-list (append opt-list (list token)))
#f)
((or (eq? (car token) 'number)
(eq? (car token) 'string))
(cond
((and (eq? state 'opt) (pair? last-tag))
(cond
((cdr last-tag)
(if (not (eq? (cdr last-tag) (car token)))
(syntax-error
"Tag :" (car last-tag) " takes " (cdr last-tag) " argument"))
(cond
((string=? (car last-tag) "comparator")
(let ((comp (sieve-find-comparator (cdr token))))
(if (not comp)
(syntax-error "Undefined comparator: " (cdr token)))
(set-cdr! token (car comp)))))
(set! opt-list (append opt-list (list token)))
(set! last-tag #f))
(else
(set! state 'arg)
(set! arg-list (append arg-list (list token))))))
(else
(set! arg-list (append arg-list (list token)))))
#f)
((delimiter token #\[)
(putback-token)
(cond
((and (eq? state 'opt) (pair? last-tag))
(cond
((cdr last-tag)
(if (not (eq? (cdr last-tag) 'string-list))
(syntax-error
"Tag :" (car last-tag) " takes string list argument"))
(set! opt-list (append opt-list (list (require-string-list))))
(set! last-tag #f))
(else
(set! state 'arg)
(set! arg-list (append arg-list (list (require-string-list)))))))
(else
(set! arg-list (append arg-list (list (require-string-list))))))
#f)
(else
#t))
(cons opt-list arg-list))))
;;; sieve-parse-arguments: Parse the arguments to a test or an action.
;;; ENTRY is the syntax table entry to guide the parsing
;;;
(define (sieve-parse-arguments ident entry)
(DEBUG 100 "sieve-parse-arguments" entry)
(let ((arg-list (sieve-preprocess-arguments (car (cdr entry)))))
;; Process positional arguments
(do ((expect (car (cdr (cdr entry))) (cdr expect))
(argl (cdr arg-list) (cdr argl))
(n 1 (1+ n)))
((cond
((null? expect)
(if (not (null? argl))
(syntax-error
"Too many positional arguments for " ident
" (bailed out at " (car argl) ")"))
#t)
((null? argl)
(if (not (null? expect))
(syntax-error
"Too few positional arguments for " ident))
#t)
(else #f)) #f)
(let ((expect-type (car expect))
(arg (car argl)))
(cond
((and (eq? expect-type 'string-list)
(eq? (car arg) 'string))
;; Coerce string to string-list
(sieve-exp-append (list 'list (cdr arg))))
((eq? expect-type (car arg))
(if (eq? expect-type 'string-list)
(sieve-exp-append (append (list 'list) (cdr arg)))
(sieve-exp-append (cdr arg))))
(else
(syntax-error
"Type mismatch in argument " n " to " (cdr ident)
"; expected " expect-type ", but got " (car arg))))))
;; Process optional arguments (tags).
;; They have already been tested
(for-each
(lambda (tag)
(sieve-exp-append (cond
((eq? (car tag) 'tag)
(symbol->keyword
(string->symbol (cdr tag))))
((eq? (car tag) 'string-list)
(append (list 'list) (cdr tag)))
(else
(cdr tag)))))
(car arg-list))))
;;;;
;;;; Parser functions for tests
;;; test-list = "(" test *("," test) ")"
(define (sieve-parse-test-list)
(do ((token (sieve-parse-test) (sieve-parse-test)))
((cond
((delimiter token #\))
#t) ;; break;
((delimiter token #\,)
#f) ;; continue
((eof-object? token)
(syntax-error "Unexpected end of file in test-list")
#t) ;; break
(else
(syntax-error "Expected ',' or ')' but found " (cdr token))
#t)) ;; break
(read-token))))
;;; test = identifier arguments
(define (sieve-parse-test)
(let ((ident (require-identifier)))
(cond
((string=? (cdr ident) "not")
(sieve-exp-begin)
(sieve-exp-append 'not)
(sieve-parse-test)
(sieve-exp-finish))
(else
(read-token)
(cond
((eof-object? current-token)
(syntax-error "Unexpected end of file in conditional"))
((delimiter current-token #\()
(sieve-exp-begin)
(cond
((string=? (cdr ident) "allof")
(sieve-exp-append 'and))
((string=? (cdr ident) "anyof")
(sieve-exp-append 'or))
(else
(syntax-error "Unexpected '('")))
(sieve-parse-test-list)
(sieve-exp-finish))
(else
(let ((test (sieve-find-test (cdr ident))))
(if (not test)
(syntax-error "Unknown test name: " (cdr ident)))
(cond
((procedure? (car test))
(putback-token)
(sieve-exp-begin)
(sieve-exp-append (car test))
(sieve-parse-arguments (cdr ident) test)
(sieve-exp-finish))
(else
(sieve-exp-append (car test))))))))))
current-token)
(define (sieve-parse-block . read)
(if (not (null? read))
(read-token))
(if (delimiter current-token #\{)
(begin
(set! nesting-level (1+ nesting-level))
(do ((token (read-token) (read-token)))
((cond
((eof-object? token)
(syntax-error "Unexpected end of file in block")
#t)
((delimiter token #\})
#t)
(else
(putback-token)
(sieve-parse-command)
#f))) #f)
(set! nesting-level (1- nesting-level)))
(require-semicolon 'dont-read)))
;;; if <test1: test> <block1: block>
(define (sieve-parse-if-internal)
(DEBUG 10 "sieve-parse-if-internal" current-token)
(sieve-exp-begin)
(sieve-parse-test)
(sieve-parse-block)
(sieve-exp-finish)
(read-token)
(cond
((eof-object? current-token) )
((identifier current-token "elsif")
(sieve-parse-if-internal))
((identifier current-token "else")
(sieve-exp-begin 'else)
(sieve-parse-block 'read)
(sieve-exp-finish))
(else
(putback-token))))
(define (sieve-parse-if)
(sieve-exp-begin 'cond)
(sieve-parse-if-internal)
(sieve-exp-finish))
(define (sieve-parse-else)
(syntax-error "else without if"))
(define (sieve-parse-elsif)
(syntax-error "elsif without if"))
;;; require <capabilities: string-list>
(define (sieve-parse-require)
(for-each
(lambda (capability)
(if (not
(cond
((and
(>= (string-length capability) 5)
(string=? (substring capability 0 5) "test-"))
(sieve-find-test (substring capability 5)))
((and
(>= (string-length capability) 11)
(string=? (substring capability 0 11) "comparator-"))
(sieve-find-comparator (substring capability 11)))
(else
(sieve-find-action capability))))
(let ((name (string-append sieve-libdir
"/" capability ".scm")))
(set! sieve-load-files (append sieve-load-files (list name)))
(catch #t
(lambda ()
(load name))
(lambda args
(lex-error "Can't load required capability "
capability)
args)))))
(cdr (require-string-list)))
(require-semicolon))
;;; stop
(define (sieve-parse-stop)
(sieve-exp-begin sieve-stop)
(sieve-exp-finish)
(require-semicolon))
;;;;
;;;; Parser functions for actions
(define (sieve-parse-action)
(let* ((name (cdr current-token))
(descr (sieve-find-action name)))
(cond
(descr
(cond
((car descr)
(sieve-exp-begin 'reg-action)
(sieve-exp-finish)
(sieve-exp-begin (car descr))
(sieve-parse-arguments name descr)
(require-semicolon 'dont-read)
(sieve-exp-finish))
(else
(require-semicolon))))
(else
(syntax-error "Unknown identifier: " name)))))
;;;;
;;;; The parser
(define (sieve-parse-command)
(DEBUG 10 "sieve-parse-command" current-token)
(catch 'syntax-error
(lambda ()
(read-token)
(cond
((or (not current-token)
(eof-object? current-token))) ;; Skip comments and #<eof>
((eq? (car current-token) 'identifier)
;; Process a command
(let ((elt (assoc (string->symbol (cdr current-token))
(list
(cons 'if sieve-parse-if)
(cons 'elsif sieve-parse-elsif)
(cons 'else sieve-parse-else)
(cons 'require sieve-parse-require)
(cons 'stop sieve-parse-stop)))))
(if (not elt)
(sieve-parse-action)
(apply (cdr elt) '()))))
(else
(syntax-error "3. Expected identifier but found "
(cdr current-token)))))
(lambda args
;; Error recovery: skip until we find a ';' or '}'.
(if (and (= input-line-number recovery-line-number)
(= input-index recovery-index))
(begin
(lex-error "ERROR RECOVERY: Skipping to end of file")
(throw 'end-of-file)))
(set! recovery-line-number input-line-number)
(set! recovery-index input-index)
(if (or (delimiter current-token #\})
(delimiter current-token #\;))
(read-token))
(DEBUG 50 "ERROR RECOVERY at " current-token)
(do ((token current-token (read-token)))
((cond
((eof-object? token)
(throw 'end-of-file))
((delimiter token #\;)
#t)
((delimiter token #\})
(cond
((> nesting-level 0)
(putback-token)
#t)
(else
#f)))
((delimiter token #\{)
(sieve-skip-block)
(putback-token)
#f)
(else
#f)) #f))
(DEBUG 50 "ERROR RECOVERY FINISHED AT " current-token)))
current-token)
(define (sieve-skip-block)
(do ((token (read-token) (read-token)))
((cond
((eof-object? token)
(throw 'end-of-file))
((delimiter token #\{)
(sieve-skip-block)
#f)
((delimiter token #\})
#t)
(else
#f)) #f)))
(define (sieve-parse-from-port port)
(set! input-port port)
(do ((token (sieve-parse-command) (sieve-parse-command)))
((eof-object? token) #f)) )
(define (sieve-parse filename)
(if (file-exists? filename)
(catch 'end-of-file
(lambda ()
(set! error-count 0)
(set! current-token #f)
(set! input-file filename)
(set! input-line-number 0)
(set! putback-list '())
(call-with-input-file filename sieve-parse-from-port))
(lambda args args))))
;;;;
;;;; Code generator
(define sieve-exp '()) ;; Expression currently being built
(define sieve-exp-stack '())
(define sieve-code-list '()) ;; Resulting scheme code
(define (sieve-exp-begin . exp)
(set! sieve-exp-stack (append (list sieve-exp) sieve-exp-stack))
(set! sieve-exp exp))
(define (sieve-exp-append exp)
(set! sieve-exp (append sieve-exp (list exp))))
(define (sieve-exp-finish)
(set! sieve-exp (append (car sieve-exp-stack) (list sieve-exp)))
(set! sieve-exp-stack (cdr sieve-exp-stack)))
(define (sieve-code-begin)
(set! sieve-exp-stack '())
(set! sieve-exp '()))
(define (sieve-code-prologue code-list)
(sieve-exp-begin (car code-list))
(let loop ((code-list (cdr code-list)))
(for-each
(lambda (elt)
(cond
((and (list? elt) (not (null? elt)))
(sieve-exp-begin (car elt))
(loop (cdr elt))
(sieve-exp-finish))
(else
(sieve-exp-append elt))))
code-list)))
(define (sieve-code-finish)
(if (not (null? sieve-exp))
(set! sieve-code-list (append sieve-code-list sieve-exp))))
;;; Print the program
(define (sieve-code-print-list exp)
(display "(")
(for-each
(lambda (x)
(cond
((procedure? x)
(display (procedure-name x)))
((list? x)
(sieve-code-print-list x))
(else
(write x)))
(display " "))
exp)
(display ")"))
;;; Save the program
(define (sieve-save-program outfile)
(with-output-to-file
outfile
(lambda ()
(display "#! ")
(display "/bin/sh\n\
# aside from this initial boilerplate, this is actually -*- scheme -*- code\n\
exec ${GUILE-guile} -l $0 -c '(mailutils-main)'\n")
(display (string-append
"# This Guile mailbox parser was made from " filename))
(newline)
(display "# by sieve.scm, GNU %PACKAGE% %VERSION%\n!#")
(newline)
(display
"(if (not (member \"%GUILE_SITE%\" %load-path))\n
(set! %load-path (cons \"%GUILE_SITE%\" %load-path)))\n")
(display "(use-modules (mailutils sieve-core))\n")
(display (string-append
"(set! sieve-source \"" filename "\")"))
(newline)
(for-each
(lambda (file)
(display (string-append
"(load \"" file "\")"))
(newline))
sieve-load-files)
(newline)
(if request-verbose
(display "(set! sieve-verbose #t)\n"))
(display "(define (sieve-filter-thunk) ")
(sieve-code-print-list (car sieve-code-list))
(display ")\n\n")
(display "(define (mailutils-main . rest)\n")
(display " (sieve-main sieve-filter-thunk))\n\n")
(display "(define (mailutils-check-message msg)\n\
(set! sieve-current-message msg)\n\
(sieve-run-current-message sieve-filter-thunk))\n")
(display "\n\
;;;; Local Variables:\n\
;;;; buffer-read-only: t\n\
;;;; End:\n"))))
;;;;
;;;; Main
(define filename #f)
(define output #f)
(define (sieve-usage)
(display "usage: sieve2scm [OPTIONS] [mailbox]\n")
(display "GNU sieve2scm -- compile a Sieve program into Scheme code\n\n")
(display " -f, --file FILENAME Set input file name\n")
(display " -o, --output FILENAME Set output file name\n")
(display " -L, --lib-dir DIRNAME Set sieve library directory name\n")
(display " -d, --debug LEVEL Set debugging level\n")
(display " --version Show program version\n\n")
(display "If -o option is not given, the compiled program is executed\n")
(display "immediately. It operates on the user system mailbox unless\n")
(display "mailbox is given in the command line.\n")
(exit 0))
(define (sieve-version)
(format #t "sieve2scm (~A) ~A~%" mu-package mu-version)
(exit 0))
;;; Parse command line
(define grammar
`((file (single-char #\f)
(value #t))
(output (single-char #\o)
(value #t))
(debug (single-char #\d)
(value #t))
(lib-dir (single-char #\L)
(value #t))
(version)
(verbose (single-char #\v))
(help (single-char #\h))))
(define program-name (car (command-line)))
(for-each
(lambda (x)
(cond
((pair? x)
(case (car x)
((debug)
(set! sieve-debug (string->number (cdr x))))
((file)
(set! filename (cdr x)))
((lib-dir)
(set! sieve-libdir (cdr x)))
((output)
(set! output (cdr x)))
((version)
(sieve-version))
((verbose)
(set! request-verbose #t))
((help)
(sieve-usage))
('()
(set! sieve-script-args (cdr x)))))))
(getopt-long (command-line) grammar))
(cond
((not filename)
(format (current-error-port) "~A: missing input filename~%" program-name)
(sieve-usage))
((not (file-exists? filename))
(format (current-error-port) "~A: Input file ~A does not exist~%" filename)
(exit 0)))
(if (not sieve-libdir)
(set! sieve-libdir
(let ((myname (car (command-line))))
(if (not (char=? (string-ref myname 0) #\/))
(set! myname (string-append (getcwd) "/" myname)))
(let ((slash (string-rindex myname #\/)))
(substring myname 0 slash)))))
(sieve-code-prologue
'(letrec
((implicit-keep #t)
(reg-action (lambda () (set! implicit-keep #f))))))
(sieve-parse filename)
(sieve-exp-append 'implicit-keep)
(sieve-exp-finish)
(sieve-code-finish)
(cond
((> error-count 0)
(display error-count)
(display " errors.")
(newline)
(exit 1))
(output
(sieve-save-program output))
(else
(let ((temp-file (tmpnam))
(saved-umask (umask #o077)))
(sieve-save-program temp-file)
(catch #t
(lambda ()
(set-cdr! (command-line) sieve-script-args)
(load temp-file))
(lambda (key . args)
(apply display-error the-last-stack (current-error-port) args)))
(delete-file temp-file)
(umask saved-umask))))
;;;; End of sieve.scm
;;;; 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))))