;;;; 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 "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) (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))))