Annotation of /nfo/perl/scripts/dispatchmail/recieveMail

#!/usr/bin/perl

# ==========================================================================
#
# recieveMail v0.04
#   a simple mail filter done in perl with CPAN-module "Mail::Audit"
#
#
# 2002-11-09, joko@netfrag.org
#   + recieveMail now can run globally (/etc/mail/smrsh!)
#     + $HOME is taken from $ENV{HOME} or $ENV{PWD}
#     + rules are taken from $HOME/Mail/.rules.pm
#     + fallback mechanism(s)
#   + bugfixes
#
# 2002-10-14, joko@netfrag.org
#   + $LOGFILE is used now (recievemail.log)
#   + tracing (uses $LOGFILE)
#   + checks delivery path for existance,
#     changes $LOGFILE if needed
#   
# 2002-07-17, joko@netfrag.org
#   + added filtering by target (destination-routing)
#     (looks in "to", "cc" and "bcc")
#   
# 2001-12-05, joko@netfrag.org
#   + initial internal release
#
#
# TODO:
#   - more sophisticated filtering
#   - configuration-comfort (use perl-arrays and -hashes for rule-declaration)
#   - Html-Gui to add/edit/remove rules
#   - rule base located in LDAP (local delivery routing)
#   - completely hide away regex-stuff and provide simpler wildcarding
#     - hide needed quoting of dots (.) and ats (@) in addresses
#     - provide: beginsWith(string), endsWith(string), beginsAt(string, pos|regex)
#       - this could become a CPAN-module sometimes (?):
#       - "String"-Object to be inherited from gives these methods to you
#       - examples:
#         - routeTo("mbox:/path/to/mbox") if $to->beginsWith("hello");
#         - routeTo("fax:+4930123456")    if $subject->contains("gatefax");
#   - metadata:
#     - add some info about the context we are running in:
#       - console
#       - sendmail/normal
#       - sendmail/smrsh
#     - add some info about the user we are doing this for:
#       - username
#       - home-directory
#
# ==========================================================================

use strict;
# don't use warnings;

use Mail::Audit;
use Data::Dumper;
use Getopt::Long;


# - - - - - - - - - - - - - - - - - - - -
#               options
# - - - - - - - - - - - - - - - - - - - -
my $opt_base      = '';
my $opt_rulesfile = '';
GetOptions(
  'base=s'  => \$opt_base,
  'rules=s' => \$opt_rulesfile,
);
$opt_base ||= $ENV{HOME};
$opt_base ||= $ENV{PWD};


# - - - - - - - - - - - - - - - - - - - -
#
#                targets
#
#  declare and initialize some variables
#      these are mostly base paths
#      mail should be delivered to
#
# - - - - - - - - - - - - - - - - - - - -
#my $HOME = "/home/joko/virtual/joko_mail";
my $USER      = $ENV{USER};
my $HOME      = $opt_base;
my $MAILDIR   = "$HOME/Mail";
my $LOGFILE   = "$MAILDIR/recievemail.log";
my $RULESFILE = "$MAILDIR/.rules.pm";
my $LOCKFILE  = "$HOME/.procmail.lockfile";
my $DEFAULT   = "$MAILDIR/Inbox";
my $DEBUG   = 0;
my $TRACE   = 1;
my $VERBOSE = 1;

# override settings
  # override $RULESFILE if given as option on the command line
  $RULESFILE = $opt_rulesfile if ($opt_rulesfile);
  # change logfile
  $LOGFILE = "recievemail-emerg.log" if (! -e $MAILDIR);


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

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

  # 0.a. pre flight tracing
    if ($TRACE) {
      s2f("Mail from " . gchomp($incoming->from) . " to " . gchomp($incoming->to));
      s2f("Subject: " . gchomp($incoming->subject));
    }

  # 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);
       accept_spool();
     }

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

  # 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 ($TRACE) {
      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("delivering to: $deliver_to");

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

    $incoming->accept($deliver_to);
  }

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


# - - - - - - - - - - - - - - - - - - - -
#             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	joko	1.1	#!/usr/bin/perl
2
3			# ==========================================================================
4	joko	1.2	#
5	joko	1.4	# recieveMail v0.04
6	joko	1.3	# a simple mail filter done in perl with CPAN-module "Mail::Audit"
7			#
8	joko	1.2	#
9	joko	1.4	# 2002-11-09, joko@netfrag.org
10			# + recieveMail now can run globally (/etc/mail/smrsh!)
11			# + $HOME is taken from $ENV{HOME} or $ENV{PWD}
12			# + rules are taken from $HOME/Mail/.rules.pm
13			# + fallback mechanism(s)
14			# + bugfixes
15			#
16	joko	1.3	# 2002-10-14, joko@netfrag.org
17			# + $LOGFILE is used now (recievemail.log)
18			# + tracing (uses $LOGFILE)
19			# + checks delivery path for existance,
20			# changes $LOGFILE if needed
21			#
22			# 2002-07-17, joko@netfrag.org
23			# + added filtering by target (destination-routing)
24			# (looks in "to", "cc" and "bcc")
25			#
26	joko	1.2	# 2001-12-05, joko@netfrag.org
27	joko	1.3	# + initial internal release
28	joko	1.4	#
29			#
30			# TODO:
31	joko	1.2	# - more sophisticated filtering
32	joko	1.4	# - configuration-comfort (use perl-arrays and -hashes for rule-declaration)
33			# - Html-Gui to add/edit/remove rules
34	joko	1.3	# - rule base located in LDAP (local delivery routing)
35	joko	1.4	# - completely hide away regex-stuff and provide simpler wildcarding
36			# - hide needed quoting of dots (.) and ats (@) in addresses
37			# - provide: beginsWith(string), endsWith(string), beginsAt(string, pos\|regex)
38			# - this could become a CPAN-module sometimes (?):
39			# - "String"-Object to be inherited from gives these methods to you
40			# - examples:
41			# - routeTo("mbox:/path/to/mbox") if $to->beginsWith("hello");
42			# - routeTo("fax:+4930123456") if $subject->contains("gatefax");
43			# - metadata:
44			# - add some info about the context we are running in:
45			# - console
46			# - sendmail/normal
47			# - sendmail/smrsh
48			# - add some info about the user we are doing this for:
49			# - username
50			# - home-directory
51	joko	1.2	#
52	joko	1.1	# ==========================================================================
53
54			use strict;
55	joko	1.3	# don't use warnings;
56	joko	1.1
57	joko	1.4	use Mail::Audit;
58			use Data::Dumper;
59			use Getopt::Long;
60
61
62			# - - - - - - - - - - - - - - - - - - - -
63			# options
64			# - - - - - - - - - - - - - - - - - - - -
65			my $opt_base = '';
66			my $opt_rulesfile = '';
67			GetOptions(
68			'base=s' => \$opt_base,
69			'rules=s' => \$opt_rulesfile,
70			);
71			$opt_base \|\|= $ENV{HOME};
72			$opt_base \|\|= $ENV{PWD};
73	joko	1.1
74
75	joko	1.4	# - - - - - - - - - - - - - - - - - - - -
76			#
77			# targets
78			#
79			# declare and initialize some variables
80			# these are mostly base paths
81			# mail should be delivered to
82			#
83			# - - - - - - - - - - - - - - - - - - - -
84			#my $HOME = "/home/joko/virtual/joko_mail";
85			my $USER = $ENV{USER};
86			my $HOME = $opt_base;
87			my $MAILDIR = "$HOME/Mail";
88			my $LOGFILE = "$MAILDIR/recievemail.log";
89			my $RULESFILE = "$MAILDIR/.rules.pm";
90			my $LOCKFILE = "$HOME/.procmail.lockfile";
91			my $DEFAULT = "$MAILDIR/Inbox";
92			my $DEBUG = 0;
93			my $TRACE = 1;
94			my $VERBOSE = 1;
95
96			# override settings
97			# override $RULESFILE if given as option on the command line
98			$RULESFILE = $opt_rulesfile if ($opt_rulesfile);
99			# change logfile
100			$LOGFILE = "recievemail-emerg.log" if (! -e $MAILDIR);
101
102
103			# - - - - - - - - - - - - - - - - - - - -
104			# main
105			# - - - - - - - - - - - - - - - - - - - -
106	joko	1.1
107			# "jump" into processing of new incoming mail and get a "handler" to this mail
108			my $incoming = Mail::Audit->new;
109
110	joko	1.4	# 0.a. pre flight tracing
111			if ($TRACE) {
112			s2f("Mail from " . gchomp($incoming->from) . " to " . gchomp($incoming->to));
113			s2f("Subject: " . gchomp($incoming->subject));
114			}
115
116			# 0.b. pre flight checks
117
118			# TODO: check if $HOME is empty
119
120			# check if $HOME exists
121			if (! -e $MAILDIR) {
122			my $msg = "delivery failed, base directory $MAILDIR does not exist";
123			report($msg);
124			accept_spool();
125			}
126
127			# 1. include rules or fallback
128			# check if $RULESFILE exists
129			if (-f $RULESFILE) {
130			report("loading rules from \"$RULESFILE\"");
131			require $RULESFILE;
132			} else {
133			#die("$RULESFILE doesn't exist");
134			report("configured rulesfile \"$RULESFILE\" doesn't exist");
135			accept_spool();
136			}
137
138			# 2. export required stuff to rules namespace
139			export_symbols();
140
141			# 3. run dispatcher
142			report("running \"rules::dispatch\"");
143			rules::dispatch();
144
145			# 4. dispatcher didn't do anything
146			report("dispatcher could not apply any filter, using default delivery");
147
148			# the default-handler: simply accept all mails and route them to "/var/spool/mail"
149			# $incoming->accept();
150
151			# if you want to reject all mails coming through to here, do a ...
152			# $incoming->reject;
153
154			# catch all mails and route them to a "DEFAULT"-inbox
155			jaccept($DEFAULT);
156
157
158
159
160	joko	1.3
161			# - - - - - - - - - - - - - - - - - - - -
162	joko	1.4	# tracing & reporting
163	joko	1.3	# - - - - - - - - - - - - - - - - - - - -
164			sub s2f {
165			my $str = shift;
166			open(FH, '>>' . $LOGFILE);
167			print FH $str, "\n";
168			close(FH);
169			}
170	joko	1.4
171			sub report {
172			my $msg = shift;
173			# TODO: tracing, debugging
174
175			print $msg, "\n" if $VERBOSE;
176			if ($TRACE) {
177			s2f($msg);
178			}
179
180	joko	1.3	}
181
182	joko	1.1	# - - - - - - - - - - - - - - - - - - - -
183	joko	1.3	# processing mail
184	joko	1.1	# - - - - - - - - - - - - - - - - - - - -
185	joko	1.2
186			sub compareTarget {
187			my $pattern = shift;
188			my $ok = 0;
189			$ok = 1 if ($incoming->to =~ m/$pattern/);
190			$ok = 1 if ($incoming->cc =~ m/$pattern/);
191			$ok = 1 if ($incoming->bcc =~ m/$pattern/);
192			return $ok;
193			}
194
195	joko	1.3	sub jaccept {
196			my $deliver_to = shift;
197	joko	1.4
198			report("delivering to: $deliver_to");
199
200			# check deliver_to path
201			if (! -e $deliver_to) {
202			report("deliver_to path \"$deliver_to\" doesn't exist");
203			accept_spool();
204			return;
205	joko	1.3	}
206	joko	1.4
207	joko	1.3	$incoming->accept($deliver_to);
208			}
209
210	joko	1.4	sub accept_spool {
211			my $path = "/var/spool/mail/$USER";
212			report("defaulting to spool delivery ($path)");
213			$incoming->accept($path);
214	joko	1.2	}
215
216
217	joko	1.4	# - - - - - - - - - - - - - - - - - - - -
218			# helper functions
219			# - - - - - - - - - - - - - - - - - - - -
220
221			sub get_coderef {
222			my $codepack = shift;
223			my $method = shift;
224			$codepack \|\| return '[error]';
225			$method \|\|= '';
226			$method && ($codepack .= '::');
227			return eval '\&' . $codepack . $method . ';';
228			}
229	joko	1.2
230	joko	1.4	sub export_symbols {
231			# my $callpack = 'rules';
232			# my @EXPORT = qw( incoming subject MAILDIR jaccept );
233			# foreach my $sym (@EXPORT) {
234			no strict 'refs';
235			# *{"${callpack}::$sym"} = get_coderef('main', $sym);
236			# }
237			{
238			no strict 'refs';
239			*{"rules::jaccept"} = get_coderef('main', 'jaccept');
240			*{"rules::report"} = get_coderef('main', 'report');
241			*{"rules::compareTarget"} = get_coderef('main', 'compareTarget');
242	joko	1.1	}
243	joko	1.4	$rules::MAILDIR = $MAILDIR;
244			$rules::incoming = $incoming;
245			}
246	joko	1.2
247	joko	1.4	sub gchomp {
248			my $str = shift;
249			chomp($str);
250			return $str;
251			}
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26