Mail/Audit/Dispatch.pm

# ============================================================
#
#  Mail::Audit::Dispatch v0.05
#    A simple mail filter done in perl 
#    with the Perl-module "Mail::Audit" 
#    available from CPAN.
#
#  $Id: dispatchmail,v 1.3 2003/01/22 07:16:51 root Exp $
#
# ============================================================
#  $Log: dispatchmail,v $
#  Revision 1.3  2003/01/22 07:16:51  root
#  + sub traceEntry
#  + further refactorings
#
#  Revision 1.2  2003/01/22 05:38:44  collector
#  + prepared refactoring to 'dispatchmail'
#
# ============================================================


package Mail::Audit::Dispatch;

use strict;
# don't use warnings;

use base qw( DesignPattern::Object );


use Mail::Audit;
use Data::Dumper;


use org::netfrag::shortcuts qw( now );


my $LOG     = 1;        # writes reports to logfile
my $VERBOSE = 1;        # writes reports to STDOUT
my $TRACE   = 1;        # writes contents of messages to logfile


sub _init {
  my $self = shift;
  $self->_init_options();
  $self->_init_settings();
  $self->_override_settings();
}

sub _init_options {
  my $self = shift;
  $self->{options}->{base}   = $self->{base};
  $self->{options}->{base} ||= $ENV{HOME};
  $self->{options}->{base} ||= $ENV{PWD};
  $self->{options}->{rules}   = $self->{rules};
}

# - - - - - - - - - - - - - - - - - - - -
#
#                targets
#
#  declare and initialize some variables
#      these are mostly base paths
#      mail should be delivered to
#
# - - - - - - - - - - - - - - - - - - - -
sub _init_paths {
  my $self = shift;
  $self->{settings}->{USER}      = $ENV{USER};
  $self->{settings}->{HOME}      = $self->{options}->{base};
  $self->{settings}->{MAILDIR}   = "$HOME/Mail";
  $self->{settings}->{RULESFILE} = "$HOME/.dispatchmailrc.pm";
  #$self->{settings}->{LOCKFILE}  = "$HOME/.procmail.lockfile";
  $self->{settings}->{LOCKFILE}  = "$HOME/.dispatchmail.lockfile";
  $self->{settings}->{LOGFILE}   = "$MAILDIR/.dispatchmail.log";
  $self->{settings}->{DEFAULT}   = "$MAILDIR/Inbox";
}

sub _override_settings {
  my $self = shift;
  # override $RULESFILE if given as option on the command line
    $self->{settings}->{RULESFILE} = 
      $self->{options}->{rules} if $self->{options}->{rules};
  # change logfile
    $self->{settings}->{LOGFILE} = 
      "recievemail-emerg.log" if (! -e $self->{settings}->{MAILDIR});

    $self->{settings}->{USER} ||= '';
}


# - - - - - - - - - - - - - - - - - - - -
#                 main
# - - - - - - - - - - - - - - - - - - - -

  # "jump" into processing of new incoming mail and get a "handler" to this mail
  my $incoming = Mail::Audit->new;

  sub traceEntry {
    s2f('-' x 40 . '  TRACE  ' . '-' x 10);
    s2f("From:    " . gchomp($incoming->from));
    s2f("To:      " . gchomp($incoming->to));
    s2f("Subject: " . gchomp($incoming->subject));
    s2f('-' x 40 . '  TRACE  ' . '-' x 10);
  }


  # 0.a. pre flight tracing
    my $now = now();
    report("$0 running at $now for user '$USER'.");
    traceEntry() if $TRACE;

  # 0.b. pre flight checks

     # TODO: check if $HOME is empty

     # check if $HOME exists
     if (! -e $MAILDIR) {
       my $msg = "delivery failed, base directory $MAILDIR does not exist";
       report($msg);
       forward_delivery();
     }

  # 1. include rules or fallback
    # check if $RULESFILE exists
    if (-f $RULESFILE) {
      report("Loading rules from \"$RULESFILE\".");
      require $RULESFILE;
    } else {
      #die("$RULESFILE doesn't exist");
      report("Configured rulesfile \"$RULESFILE\" doesn't exist.");
      forward_delivery();
    }

  # 2. export required stuff to rules namespace
    export_symbols();

  # 3. run dispatcher
    report("Running \"rules::dispatch\".");
    rules::dispatch();

  # 4. dispatcher didn't do anything
    report("dispatcher could not apply any filter, using default delivery");

    # the default-handler: simply accept all mails and route them to "/var/spool/mail"
    # $incoming->accept();

    # if you want to reject all mails coming through to here, do a ...
    # $incoming->reject;

    # catch all mails and route them to a "DEFAULT"-inbox
    jaccept($DEFAULT);


  # - - - - - - - - - - - - - - - - - - - -
  #          tracing & reporting
  # - - - - - - - - - - - - - - - - - - - -
  sub s2f {
    my $str = shift;
    open(FH, '>>' . $LOGFILE);
    print FH $str, "\n";
    close(FH);
  }

  sub report {
    my $msg = shift;    
    # TODO: tracing, debugging

    print $msg, "\n" if $VERBOSE;
    if ($LOG) {
      s2f($msg);
    }

  }

  # - - - - - - - - - - - - - - - - - - - -
  #             processing mail
  # - - - - - - - - - - - - - - - - - - - -

  sub compareTarget {
    my $pattern = shift;
    my $ok = 0;
    $ok = 1 if ($incoming->to =~ m/$pattern/);
    $ok = 1 if ($incoming->cc =~ m/$pattern/);
    $ok = 1 if ($incoming->bcc =~ m/$pattern/);
    return $ok;
  }

  sub jaccept {
    my $deliver_to = shift;
    
    report("ACCEPT: $deliver_to");

    # check deliver_to path
    if (! -e $deliver_to) {
      report("deliver_to path \"$deliver_to\" doesn't exist");
      forward_delivery();
      return;
    }

    $incoming->accept($deliver_to);
  }

  sub accept_spool {
    my $path = "/var/spool/mail/$USER";
    report("defaulting to spool delivery ($path)");
    $incoming->accept($path);
  }

  sub forward_delivery {
    report("Forwarding delivery to next handler in queue (probably /var/spool/mail).");
    $incoming->accept;
  }


# - - - - - - - - - - - - - - - - - - - -
#             helper functions
# - - - - - - - - - - - - - - - - - - - -

sub get_coderef {
  my $codepack = shift;
  my $method = shift;
  $codepack || return '[error]';
  $method ||= '';
  $method && ($codepack .= '::');
  return eval '\&' . $codepack . $method . ';';
}

sub export_symbols {
  #  my $callpack = 'rules';
  #  my @EXPORT = qw( incoming subject MAILDIR jaccept );
  #  foreach my $sym (@EXPORT) {
      no strict 'refs';
  #    *{"${callpack}::$sym"} = get_coderef('main', $sym);
  #  }
  {
    no strict 'refs';
    *{"rules::jaccept"}       = get_coderef('main', 'jaccept');
    *{"rules::report"}        = get_coderef('main', 'report');
    *{"rules::compareTarget"} = get_coderef('main', 'compareTarget');
  }
  $rules::MAILDIR  = $MAILDIR;
  $rules::incoming = $incoming;
}

sub gchomp {
  my $str = shift;
  chomp($str);
  return $str;
}
1	root	1.1	# ============================================================
2			#
3			# Mail::Audit::Dispatch v0.05
4			# A simple mail filter done in perl
5			# with the Perl-module "Mail::Audit"
6			# available from CPAN.
7			#
8			# $Id: dispatchmail,v 1.3 2003/01/22 07:16:51 root Exp $
9			#
10			# ============================================================
11			# $Log: dispatchmail,v $
12			# Revision 1.3 2003/01/22 07:16:51 root
13			# + sub traceEntry
14			# + further refactorings
15			#
16			# Revision 1.2 2003/01/22 05:38:44 collector
17			# + prepared refactoring to 'dispatchmail'
18			#
19			# ============================================================
20
21
22			package Mail::Audit::Dispatch;
23
24			use strict;
25			# don't use warnings;
26
27			use base qw( DesignPattern::Object );
28
29
30			use Mail::Audit;
31			use Data::Dumper;
32
33
34			use org::netfrag::shortcuts qw( now );
35
36
37			my $LOG = 1; # writes reports to logfile
38			my $VERBOSE = 1; # writes reports to STDOUT
39			my $TRACE = 1; # writes contents of messages to logfile
40
41
42			sub _init {
43			my $self = shift;
44			$self->_init_options();
45			$self->_init_settings();
46			$self->_override_settings();
47			}
48
49			sub _init_options {
50			my $self = shift;
51			$self->{options}->{base} = $self->{base};
52			$self->{options}->{base} \|\|= $ENV{HOME};
53			$self->{options}->{base} \|\|= $ENV{PWD};
54			$self->{options}->{rules} = $self->{rules};
55			}
56
57			# - - - - - - - - - - - - - - - - - - - -
58			#
59			# targets
60			#
61			# declare and initialize some variables
62			# these are mostly base paths
63			# mail should be delivered to
64			#
65			# - - - - - - - - - - - - - - - - - - - -
66			sub _init_paths {
67			my $self = shift;
68			$self->{settings}->{USER} = $ENV{USER};
69			$self->{settings}->{HOME} = $self->{options}->{base};
70			$self->{settings}->{MAILDIR} = "$HOME/Mail";
71			$self->{settings}->{RULESFILE} = "$HOME/.dispatchmailrc.pm";
72			#$self->{settings}->{LOCKFILE} = "$HOME/.procmail.lockfile";
73			$self->{settings}->{LOCKFILE} = "$HOME/.dispatchmail.lockfile";
74			$self->{settings}->{LOGFILE} = "$MAILDIR/.dispatchmail.log";
75			$self->{settings}->{DEFAULT} = "$MAILDIR/Inbox";
76			}
77
78			sub _override_settings {
79			my $self = shift;
80			# override $RULESFILE if given as option on the command line
81			$self->{settings}->{RULESFILE} =
82			$self->{options}->{rules} if $self->{options}->{rules};
83			# change logfile
84			$self->{settings}->{LOGFILE} =
85			"recievemail-emerg.log" if (! -e $self->{settings}->{MAILDIR});
86
87			$self->{settings}->{USER} \|\|= '';
88			}
89
90
91
92			# - - - - - - - - - - - - - - - - - - - -
93			# main
94			# - - - - - - - - - - - - - - - - - - - -
95
96			# "jump" into processing of new incoming mail and get a "handler" to this mail
97			my $incoming = Mail::Audit->new;
98
99			sub traceEntry {
100			s2f('-' x 40 . ' TRACE ' . '-' x 10);
101			s2f("From: " . gchomp($incoming->from));
102			s2f("To: " . gchomp($incoming->to));
103			s2f("Subject: " . gchomp($incoming->subject));
104			s2f('-' x 40 . ' TRACE ' . '-' x 10);
105			}
106
107
108			# 0.a. pre flight tracing
109			my $now = now();
110			report("$0 running at $now for user '$USER'.");
111			traceEntry() if $TRACE;
112
113			# 0.b. pre flight checks
114
115			# TODO: check if $HOME is empty
116
117			# check if $HOME exists
118			if (! -e $MAILDIR) {
119			my $msg = "delivery failed, base directory $MAILDIR does not exist";
120			report($msg);
121			forward_delivery();
122			}
123
124			# 1. include rules or fallback
125			# check if $RULESFILE exists
126			if (-f $RULESFILE) {
127			report("Loading rules from \"$RULESFILE\".");
128			require $RULESFILE;
129			} else {
130			#die("$RULESFILE doesn't exist");
131			report("Configured rulesfile \"$RULESFILE\" doesn't exist.");
132			forward_delivery();
133			}
134
135			# 2. export required stuff to rules namespace
136			export_symbols();
137
138			# 3. run dispatcher
139			report("Running \"rules::dispatch\".");
140			rules::dispatch();
141
142			# 4. dispatcher didn't do anything
143			report("dispatcher could not apply any filter, using default delivery");
144
145			# the default-handler: simply accept all mails and route them to "/var/spool/mail"
146			# $incoming->accept();
147
148			# if you want to reject all mails coming through to here, do a ...
149			# $incoming->reject;
150
151			# catch all mails and route them to a "DEFAULT"-inbox
152			jaccept($DEFAULT);
153
154
155
156
157
158			# - - - - - - - - - - - - - - - - - - - -
159			# tracing & reporting
160			# - - - - - - - - - - - - - - - - - - - -
161			sub s2f {
162			my $str = shift;
163			open(FH, '>>' . $LOGFILE);
164			print FH $str, "\n";
165			close(FH);
166			}
167
168			sub report {
169			my $msg = shift;
170			# TODO: tracing, debugging
171
172			print $msg, "\n" if $VERBOSE;
173			if ($LOG) {
174			s2f($msg);
175			}
176
177			}
178
179			# - - - - - - - - - - - - - - - - - - - -
180			# processing mail
181			# - - - - - - - - - - - - - - - - - - - -
182
183			sub compareTarget {
184			my $pattern = shift;
185			my $ok = 0;
186			$ok = 1 if ($incoming->to =~ m/$pattern/);
187			$ok = 1 if ($incoming->cc =~ m/$pattern/);
188			$ok = 1 if ($incoming->bcc =~ m/$pattern/);
189			return $ok;
190			}
191
192			sub jaccept {
193			my $deliver_to = shift;
194
195			report("ACCEPT: $deliver_to");
196
197			# check deliver_to path
198			if (! -e $deliver_to) {
199			report("deliver_to path \"$deliver_to\" doesn't exist");
200			forward_delivery();
201			return;
202			}
203
204			$incoming->accept($deliver_to);
205			}
206
207			sub accept_spool {
208			my $path = "/var/spool/mail/$USER";
209			report("defaulting to spool delivery ($path)");
210			$incoming->accept($path);
211			}
212
213			sub forward_delivery {
214			report("Forwarding delivery to next handler in queue (probably /var/spool/mail).");
215			$incoming->accept;
216			}
217
218
219			# - - - - - - - - - - - - - - - - - - - -
220			# helper functions
221			# - - - - - - - - - - - - - - - - - - - -
222
223			sub get_coderef {
224			my $codepack = shift;
225			my $method = shift;
226			$codepack \|\| return '[error]';
227			$method \|\|= '';
228			$method && ($codepack .= '::');
229			return eval '\&' . $codepack . $method . ';';
230			}
231
232			sub export_symbols {
233			# my $callpack = 'rules';
234			# my @EXPORT = qw( incoming subject MAILDIR jaccept );
235			# foreach my $sym (@EXPORT) {
236			no strict 'refs';
237			# *{"${callpack}::$sym"} = get_coderef('main', $sym);
238			# }
239			{
240			no strict 'refs';
241			*{"rules::jaccept"} = get_coderef('main', 'jaccept');
242			*{"rules::report"} = get_coderef('main', 'report');
243			*{"rules::compareTarget"} = get_coderef('main', 'compareTarget');
244			}
245			$rules::MAILDIR = $MAILDIR;
246			$rules::incoming = $incoming;
247			}
248
249			sub gchomp {
250			my $str = shift;
251			chomp($str);
252			return $str;
253			}
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26