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: Dispatch.pm,v 1.1 2003/01/22 07:45:20 root Exp $
#
# ============================================================
#  $Log: Dispatch.pm,v $
#  Revision 1.1  2003/01/22 07:45:20  root
#  + initial check-in - refactored from 'dispatchmail'
#
#  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 $self->{options}->{VERBOSE} = 1;     # writes reports to STDOUT
my $self->{options}->{TRACE}   = 1;     # writes contents of messages to logfile


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

sub _init_options {
  my $self = shift;
  foreach (qw( base rules LOG VERBOSE TRACE )) {
    $self->{options}->{$_} = $self->{$_};
  }
}

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

# - - - - - - - - - - - - - - - - - - - -
#
#                targets
#
#  declare and initialize some variables
#      these are mostly base paths
#      mail should be delivered to
#
# - - - - - - - - - - - - - - - - - - - -
sub _init_settings {
  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}   = "$self->{settings}->{MAILDIR}/.dispatchmail.log";
  $self->{settings}->{DEFAULT}   = "$self->{settings}->{MAILDIR}/Inbox";
}

sub _override_settings {
  my $self = shift;
  # override $self->{settings}->{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
# - - - - - - - - - - - - - - - - - - - -

sub _run {
  my $self = shift;
  
  # "jump" into processing of new incoming mail and get a "handler" to this mail
  $self->{incoming} = Mail::Audit->new();

}

  sub traceEntry {
  my $self = shift;
    s2f('-' x 40 . '  TRACE  ' . '-' x 10);
    s2f("From:    " . gchomp($self->{incoming}->from));
    s2f("To:      " . gchomp($self->{incoming}->to));
    s2f("Subject: " . gchomp($self->{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 $self->{options}->{TRACE};

  # 0.b. pre flight checks

     # TODO: check if $HOME is empty

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

  # 1. include rules or fallback
    # check if $self->{settings}->{RULESFILE} exists
    if (-f $self->{settings}->{RULESFILE}) {
      report("Loading rules from \"$self->{settings}->{RULESFILE}\".");
      require $self->{settings}->{RULESFILE};
    } else {
      #die("$self->{settings}->{RULESFILE} doesn't exist");
      report("Configured rulesfile \"$self->{settings}->{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"
    # $self->{incoming}->accept();

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

    # catch all mails and route them to a "DEFAULT"-inbox
    jaccept($self->{settings}->{DEFAULT});


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

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

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

  }

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

  sub compareTarget {
    my $pattern = shift;
    my $ok = 0;
    $ok = 1 if ($self->{incoming}->to =~ m/$pattern/);
    $ok = 1 if ($self->{incoming}->cc =~ m/$pattern/);
    $ok = 1 if ($self->{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;
    }

    $self->{incoming}->accept($deliver_to);
  }

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

  sub forward_delivery {
    report("Forwarding delivery to next handler in queue (probably /var/spool/mail).");
    $self->{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  = $self->{settings}->{MAILDIR};
  $rules::incoming = $self->{incoming};
}

sub gchomp {
  my $str = shift;
  chomp($str);
  return $str;
}

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