diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2001-08-03 19:11:14 +0000 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2001-08-03 19:11:14 +0000 |
commit | be88df89923a4dcb46e90b360ad3d06481d4f816 (patch) | |
tree | 5d2d57d8fac99bb3dcbae21a6f921092d5385c1c /guimb/scm/sieve-core.scm | |
parent | 1965e71c422d3d908aef7c6c1daad3ba3aab7559 (diff) | |
download | mailutils-be88df89923a4dcb46e90b360ad3d06481d4f816.tar.gz mailutils-be88df89923a4dcb46e90b360ad3d06481d4f816.tar.bz2 |
Sieve core functions for scripts generated by sieve.scm.
Diffstat (limited to 'guimb/scm/sieve-core.scm')
-rw-r--r-- | guimb/scm/sieve-core.scm | 326 |
1 files changed, 326 insertions, 0 deletions
diff --git a/guimb/scm/sieve-core.scm b/guimb/scm/sieve-core.scm new file mode 100644 index 000000000..6e1247bd0 --- /dev/null +++ b/guimb/scm/sieve-core.scm @@ -0,0 +1,326 @@ +;;;; GNU mailutils - a suite of utilities for electronic mail +;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;;;; +;;;; This program 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 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program 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 this program; if not, write to the Free Software +;;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; This module provides core functionality for the sieve scripts. + +;;; Comparators +(cond + (sieve-parser + (sieve-register-comparator "i;octet" string=?) + (sieve-register-comparator "i;ascii-casemap" string-ci=?))) + +;;; Stop statement + +(define (sieve-stop) + (exit)) + +;;; Basic five actions: + +;;; reject + +(define sieve-option-quote #f) +(define sieve-indent-prefix "\t") + +(define (action-reject reason) + (let* ((out-msg (mu-message-create)) + (outbody (mu-message-get-body out-msg)) + (inbody (mu-message-get-body sieve-current-message))) + (mu-message-set-header out-msg "To" + (mu-message-get-header in-msg "From")) + (mu-message-set-header out-msg "Cc" + (mu-message-get-header in-msg "Cc")) + (mu-message-set-header out-msg "Subject" + (string-append + "Re: " + (mu-message-get-header in-msg "Subject"))) + (mu-body-write outbody reason) + + (cond + (sieve-option-quote + (mu-body-write outbody "\n\nOriginal message:\n") + (do ((hdr (mu-message-get-header-fields sieve-current-message) + (cdr hdr))) + ((null? hdr) #f) + (let ((s (car hdr))) + (mu-body-write outbody (string-append + sieve-indent-prefix + (car s) ": " (cdr s) "\n")))) + (mu-body-write outbody (string-append indent-prefix "\n")) + (do ((line (mu-body-read-line inbody) (mu-body-read-line inbody))) + ((eof-object? line) #f) + (mu-body-write outbody (string-append sieve-indent-prefix line))))) + + (mu-message-send out-msg))) + +;;; fileinto + +(define (action-fileinto filename) + (let ((outbox (mu-mailbox-open filename "cw"))) + (cond + (outbox + (mu-mailbox-append-message outbox sieve-current-message) + (mu-mailbox-close outbox) + (mu-message-delete sieve-current-message))))) + +;;; redirect is defined in redirect.scm + +;;; keep -- does nothing worth mentioning :^) + +;;; discard + +(define (action-discard) + (mu-message-delete sieve-current-message)) + +;;; Register standard actions +(cond + (sieve-parser + (sieve-register-action "keep" #f) + (sieve-register-action "discard" action-discard) + (sieve-register-action "reject" action-reject 'string) + (sieve-register-action "fileinto" action-fileinto 'string))) + + +;;; Some utilities. + +(define (find-comp opt-args) + (cond + ((member #:comparator opt-args) => + (lambda (x) + (car (cdr x)))) + (else + string-ci=?))) + +(define (find-match opt-args) + (cond + ((member #:is opt-args) + #:is) + ((member #:contains opt-args) + #:contains) + ((member #:matches opt-args) + #:matches) + (else + #:is))) + +(define (sieve-str-str str key comp) + (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 (make-shared-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))) + (else + (set! cl (append (list ch) cl)))))))) + +;;;; Standard tests: + + +(define (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 ((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 (mu-message-get-header sieve-current-message 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) + (if (regexp-exec rx addr) + (exit #t)))) + (runtime-error LOG_NOTICE + "Can't get address parts for message " + sieve-current-message)))))))) + header-list))) + key-list) + #f)))) + +(define (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-error LOG_CRIT "test-size: unknown comparator " comp))))) + +(define (test-envelope part key-list . opt-list) + #f) + +(define (test-exists header-list) + (call-with-current-continuation + (lambda (exit) + (for-each (lambda (hdr) + (if (not (mu-message-get-header sieve-current-message hdr)) + (exit #f))) + header-list) + #t))) + +(define (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 ((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 (mu-message-get-header sieve-current-message 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-list))) + 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))) +(define size-comp (list (cons "under" #f) + (cons "over" #f))) +(define comparator (list (cons "comparator" 'string))) + +(cond + (sieve-parser + (sieve-register-test "address" + test-address + (append address-part comparator match-type) + (list 'string-list 'string-list)) + (sieve-register-test "size" + test-size + size-comp + (list 'number)) +; (sieve-register-test "envelope" +; test-envelope +; (append comparator address-part match-type) +; (list 'string-list 'string-list)) + (sieve-register-test "exists" + test-exists + '() + (list 'string-list)) + (sieve-register-test "header" + test-header + (append comparator match-type) + (list 'string-list 'string-list)) + (sieve-register-test "false" #f '() '()) + (sieve-register-test "true" #t '() '()))) + +;;; runtime-error +(define (runtime-error level . text) + (display (string-append "RUNTIME ERROR in " sieve-source ": ")) + (for-each + (lambda (s) + (display s)) + text) + (newline)) + +;;; Sieve-main +(define sieve-current-message #f) +(define (sieve-main) + (let ((count (mu-mailbox-messages-count current-mailbox))) + (do ((n 1 (1+ n))) + ((> n count) #f) + (set! sieve-current-message + (mu-mailbox-get-message current-mailbox n)) + (sieve-process-message)))) |