Mail-Milter-0.06004075500000520000011000000000001015145064000116445ustar tvwsrcMail-Milter-0.06/t004075500000520000011000000000001015145064000121075ustar tvwsrcMail-Milter-0.06/t/01_chain.t010064400000520000011000000023431002313313700137310ustar tvwsrc# $Header: /cvsroot/pmilter/Mail-Milter/t/01_chain.t,v 1.2 2004/03/06 11:46:51 rob_au Exp $ # Copyright (c) 2002-2004 Todd Vierling # Copyright (c) 2004 Robert Casey # # This file is covered by the terms in the file COPYRIGHT supplied with this # software distribution. BEGIN { use Test::More 'tests' => 9; use_ok('Mail::Milter::Chain'); } # Perform some basic tests of the module constructor and available methods. can_ok( 'Mail::Milter::Chain', 'accept_break', 'create_callback', 'dispatch', 'new', 'register' ); ok( my $chain = Mail::Milter::Chain->new ); isa_ok( $chain, 'Mail::Milter::Chain' ); # The testing of the accept_break method is fashioned around the described # behaviour in the module POD. eval { $chain->accept_break() }; ok( defined $@ ); is( $chain->accept_break(1), $chain ); is( $chain->accept_break(0), $chain ); # Test the register function for the registration of new milter interfaces # within the Mail::Milter::Chain object. eval { $chain->register }; ok( defined $@ ); eval { $chain->register( '' ) }; ok( defined $@ ); 1; __END__ Mail-Milter-0.06/t/00_milter.t010064400000520000011000000011141001735377500141540ustar tvwsrc# $Header: /cvsroot/pmilter/Mail-Milter/t/00_milter.t,v 1.1 2004/02/26 11:26:53 rob_au Exp $ # Copyright (c) 2002-2004 Todd Vierling # Copyright (c) 2004 Robert Casey # # This file is covered by the terms in the file COPYRIGHT supplied with this # software distribution. BEGIN { use Test::More 'tests' => 2; use_ok('Mail::Milter'); } # Perform some basic tests of the available methods for the Mail::Milter # module. can_ok( 'Mail::Milter', 'resolve_callback' ); 1; __END__ Mail-Milter-0.06/t/02_object.t010064400000520000011000000052501001735377500141350ustar tvwsrc# $Header: /cvsroot/pmilter/Mail-Milter/t/02_object.t,v 1.1 2004/02/26 11:26:53 rob_au Exp $ # Copyright (c) 2002-2004 Todd Vierling # Copyright (c) 2004 Robert Casey # # This file is covered by the terms in the file COPYRIGHT supplied with this # software distribution. BEGIN { use Test::More 'tests' => 40; use_ok('Mail::Milter::Object'); use_ok('Sendmail::Milter'); } # Perform some basic tests of the module constructor and available methods - # Whilst the underlying package object is not normally examined directly, # this is performed in the testing of Mail::Milter::Object as a result of # it's intended used as the callbacks argument to the Sendmail::Milter # register method. can_ok( 'Mail::Milter::Object', 'new' ); ok( my $callback = TestMMO->new ); isa_ok( $callback, 'Mail::Milter::Object' ); isa_ok( $callback, 'HASH' ); my @callbacks = keys %Sendmail::Milter::DEFAULT_CALLBACKS; foreach my $name (@callbacks) { my $method = sprintf('%s_callback', $name); SKIP: { skip(3, "- No such package method $method") unless UNIVERSAL::can( $callback, $method ); # Unfortunately, one test which cannot be performed is a direct comparison of # the code references - This is due to the creation of an anonymous # subroutine to call the underlying code reference within the # Mail::Milter::Object constructor. # # In place of this comparison of code references, return values from these # code references are used for comparison. ok( exists $callback->{$name}, $method ); my $subroutine = $callback->{$name}; isa_ok( $subroutine, 'CODE' ); is( &$subroutine, $callback->$method() ); } } # Test that the additional package methods test1_callback and test2_callback # have been defined within the package namespace and ensure that these have # not been incorporated into the package object. ok( UNIVERSAL::can( $callback, 'test1_callback' ) ); ok( ! exists $callback->{'test1_callback'} ); ok( UNIVERSAL::can( $callback, 'test2_callback' ) ); ok( ! exists $callback->{'test2_callback'} ); package TestMMO; use base Mail::Milter::Object; sub connect_callback () { 1 } sub helo_callback () { 2 } sub envfrom_callback () { 3 } sub envrcpt_callback () { 4 } sub header_callback () { 5 } sub eoh_callback () { 6 } sub body_callback () { 7 } sub eom_callback () { 8 } sub close_callback () { 9 } sub abort_callback () { 10 } sub test1_callback () {} sub test2_callback () {} 1; __END__ Mail-Milter-0.06/lib004075500000520000011000000000001015145064000124125ustar tvwsrcMail-Milter-0.06/lib/Mail004075500000520000011000000000001015145064000132745ustar tvwsrcMail-Milter-0.06/lib/Mail/Milter004075500000520000011000000000001015145064000145305ustar tvwsrcMail-Milter-0.06/lib/Mail/Milter/Wrapper.pm010064400000520000011000000100141001744400400165540ustar tvwsrc# $Id: Wrapper.pm,v 1.5 2004/02/26 19:24:52 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Wrapper; use 5.006; use strict; use warnings; use Carp; use Mail::Milter; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Wrapper - Perl extension for wrappering milter objects =head1 SYNOPSIS use Mail::Milter::Wrapper; my $milter = ...; my $wrapper = new Mail::Milter::Wrapper($milter, \&foo); use Sendmail::Milter; ... Sendmail::Milter::register('foo', $wrapper, SMFI_CURR_ACTS); =head1 DESCRIPTION Mail::Milter::Wrapper wraps another milter, allowing for interception of the passed arguments and/or return code of the contained milter. =head1 METHODS =over 4 =item new(MILTER, CODEREF[, CALLBACK ...]) Creates a Mail::Milter::Wrapper object. MILTER is the milter to wrap, which may be a plain hash reference or an instance of a hashref object such as C. CODEREF is the wrapper subroutine. CALLBACKs, if specified, are named callbacks which are needed by the wrapper, even if the contained milter does not use them. The wrapper subroutine will be called with the following arguments, in this order: * reference to the wrapper * name of callback * subroutine reference to call into the wrapped milter * arguments for the callback (>= 0) This subroutine should ALWAYS pass the "close" callback through to the contained milter. Failure to do so may corrupt the contained milter's state information and cause memory leaks. As an example, a simple subroutine which just passes the callback through might be written as: sub callback_wrapper { shift; # don't need $this my $cbname = shift; my $callback_sub = shift; &$callback_sub(@_); } =cut sub new ($$&;@) { my $this = bless {}, shift; my $callbacks = shift; my $wrapper_sub = shift || croak 'new Wrapper: wrapper_sub is undef'; my %needed_cbs = map { $_ => 1 } @_; my $pkg = caller; foreach my $cbname (keys %Sendmail::Milter::DEFAULT_CALLBACKS) { my $cbref = $callbacks->{$cbname}; if (defined($cbref)) { $cbref = Mail::Milter::resolve_callback($cbref, $pkg); } elsif (defined($needed_cbs{$cbname})) { $cbref = sub { SMFIS_CONTINUE; }; } next unless defined($cbref); $this->{$cbname} = sub { &$wrapper_sub($this, $cbname, $cbref, @_); }; } $this; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L, L =cut Mail-Milter-0.06/lib/Mail/Milter/Module004075500000520000011000000000001015145064000157555ustar tvwsrcMail-Milter-0.06/lib/Mail/Milter/Module/HeaderFromMissing.pm010064400000520000011000000057641001744400400217470ustar tvwsrc# $Id: HeaderFromMissing.pm,v 1.4 2004/02/26 19:24:52 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::HeaderFromMissing; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Module::HeaderFromMissing - milter to reject messages missing a From: header =head1 SYNOPSIS use Mail::Milter::Module::HeaderFromMissing; my $milter = new Mail::Milter::Module::HeaderFromMissing(); my $milter2 = &HeaderFromMissing; # convenience =head1 DESCRIPTION This milter module rejects any message at the DATA stage that is missing the From: header. This header should never be absent on any message, even if that message is missing Date: or Subject:. =cut our @EXPORT = qw(&HeaderFromMissing); sub HeaderFromMissing { new Mail::Milter::Module::HeaderFromMissing(@_); } sub envfrom_callback { shift; # $this my $ctx = shift; $ctx->setpriv(0); SMFIS_CONTINUE; } sub header_callback { shift; # $this my $ctx = shift; my $hname = shift; $ctx->setpriv(1) if (lc($hname) eq 'from'); SMFIS_CONTINUE; } sub eoh_callback { shift; # $this my $ctx = shift; unless ($ctx->getpriv()) { $ctx->setreply("554", "5.7.1", "Mandatory From: header missing from message"); return SMFIS_REJECT; } SMFIS_ACCEPT; } 1; __END__ =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/HeloRawLiteral.pm010064400000520000011000000055251001744400400212520ustar tvwsrc# $Id: HeloRawLiteral.pm,v 1.4 2004/02/26 19:24:52 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::HeloRawLiteral; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Module::HeloRawLiteral - milter to check for an IP literal without brackets in HELO =head1 SYNOPSIS use Mail::Milter::Module::HeloRawLiteral; my $milter = new Mail::Milter::Module::HeloRawLiteral(); my $milter2 = &HeloRawLiteral; # convenience =head1 DESCRIPTION RFC2821:4.1.3 specifies that raw IP addresses may be used in HELO, but only if they are enclosed in [square brackets]. Spam engines sometimes forget the brackets, so this milter will catch them. =cut our @EXPORT = qw(&HeloRawLiteral); sub HeloRawLiteral { new Mail::Milter::Module::HeloRawLiteral(@_); } sub helo_callback { shift; # $this my $ctx = shift; my $helo = shift; if ($helo =~ /^([\d\.]+|[^\[].*:.*[^\]])$/) { $ctx->setreply("554", "5.7.1", "HELO/EHLO $helo: command rejected: raw IP literal not in [square brackets], required by RFC2821:4.1.3"); return SMFIS_REJECT; } SMFIS_ACCEPT; } 1; __END__ =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/MailDomainDNSBL.pm010064400000520000011000000166141015144471100211760ustar tvwsrc# $Id: MailDomainDNSBL.pm,v 1.6 2004/11/25 21:08:25 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::MailDomainDNSBL; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants use Socket; use UNIVERSAL; our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Module::MailDomainDNSBL - milter to accept/reject mail whose sender domain matches a DNSBL =head1 SYNOPSIS use Mail::Milter::Module::MailDomainDNSBL; my $milter = new Mail::Milter::Module::MailDomainDNSBL('foo.spamlist.dom'); my $milter2 = &MailDomainDNSBL('foo.spamlist.dom'); # convenience $milter2->set_message('Mail from %M disallowed'); =head1 DESCRIPTION This milter module rejects any mail from a sender's domain (in the MAIL FROM part of the SMTP transaction, not in the From: header) matching a given DNS Blocking List (DNSBL). It can also function as a whitelisting Chain element; see C. The check used by this module is a simple "A" record lookup, via the standard "gethostbyname" lookup mechanism. This method does not require the use of Net::DNS and is thus typically very fast. =head1 METHODS =over 4 =cut our @EXPORT = qw(&MailDomainDNSBL); sub MailDomainDNSBL { new Mail::Milter::Module::MailDomainDNSBL(@_); } =pod =item new(DNSBL) =item new(DNSBL, MATCHRECORD[, ...]) =item new(DNSBL, SUBREF) Creates a MailDomainDNSBL object. DNSBL is the root host hierarchy to use for lookups. Three methods of matching can be used: If no additional arguments are provided, the match succeeds if there is any address entry present for the DNSBL lookup; the values are not examined. If one or more MATCHRECORD values are supplied, they are string representations of IPv4 addresses. If any of these match record values is the same as any address record returned by the DNSBL lookup, the match succeeds. If a SUBREF (reference to a subroutine; may be an anonymous inline C) is supplied, it is called for each of the address records returned by the DNSBL lookup. The subroutine should return 0 or undef to indicate a failed match, and nonzero to indicate a successful match. The subroutine receives two arguments: a binary-encoded four byte scalar that should be transformed as needed with C or C, and the domain name being checked by the DNSBL. =cut sub new ($$;@) { my $this = Mail::Milter::Object::new(shift); my $dnsbl = $this->{_dnsbl} = shift; $this->{_accept} = 0; $this->{_ignoretempfail} = 0; $this->{_message} = 'Access denied to sender address %M (domain is listed by %L)'; if (UNIVERSAL::isa($_[0], 'CODE')) { $this->{_matcher} = shift; } else { my @records; foreach my $record (@_) { my $addr = inet_aton($record); croak "new MailDomainDNSBL: address $record is not a valid IPv4 address" unless defined($addr); push(@records, $addr); } if (scalar @records) { $this->{_matcher} = sub { my $addr = shift; foreach my $record (@records) { return 1 if ($addr eq $record); } undef; }; } else { $this->{_matcher} = sub { 1 }; } } $this; } =pod =item accept_match(FLAG) If FLAG is 0 (the default), a matching DNSBL will cause the mail to be rejected. If FLAG is 1, a matching DNSBL will cause this module to return SMFIS_ACCEPT instead. This allows a C to be used inside a C container (in C mode), to function as a whitelist rather than a blacklist. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub accept_match ($$) { my $this = shift; my $flag = shift; croak 'accept_match: flag argument is undef' unless defined($flag); $this->{_accept} = $flag; $this; } =pod =item ignore_tempfail(FLAG) If FLAG is 0 (the default), a DNSBL lookup which fails the underlying DNS query will cause the milter to return a temporary failure result (SMFIS_TEMPFAIL). If FLAG is 1, a temporary DNS failure will be treated as if the lookup resulted in an empty record set (SMFIS_CONTINUE). This method returns a reference to the object itself, allowing this method call to be chained. =cut sub ignore_tempfail ($$) { my $this = shift; my $flag = shift; croak 'ignore_tempfail: flag argument is undef' unless defined($flag); $this->{_ignoretempfail} = $flag; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting messages. This string may contain the substring C<%M>, which will be replaced by the matching e-mail address, or C<%L>, which will be replaced by the name of the matching DNSBL. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub envfrom_callback { my $this = shift; my $ctx = shift; my $from = lc(shift); $from =~ s/^$//; return SMFIS_CONTINUE if ($from eq ''); # null <> sender my $fromdomain = $from; $fromdomain =~ s/^[^\@]+\@//; my $dnsbl = $this->{_dnsbl}; my $lookup = $fromdomain.'.'.$dnsbl; my @lookup_addrs; (undef, undef, undef, undef, @lookup_addrs) = gethostbyname($lookup); unless (scalar @lookup_addrs) { # h_errno 1 == HOST_NOT_FOUND return SMFIS_CONTINUE if ($? == 1 || $this->{_ignoretempfail}); $ctx->setreply('451', '4.7.1', "Temporary failure in DNS lookup for $lookup"); return SMFIS_TEMPFAIL; } foreach my $lookup_addr (@lookup_addrs) { if (&{$this->{_matcher}}($lookup_addr, $fromdomain)) { return SMFIS_ACCEPT if $this->{_accept}; my $msg = $this->{_message}; if (defined($msg)) { $msg =~ s/%M/$from/g; $msg =~ s/%L/$dnsbl/g; $ctx->setreply('550', '5.7.1', $msg); } return SMFIS_REJECT; } } SMFIS_CONTINUE; # don't whitelist a fallthrough } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/MailDomainDotMX.pm010064400000520000011000000122111015145016100213100ustar tvwsrc# $Id: MailDomainDotMX.pm,v 1.1 2004/11/25 21:36:49 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::MailDomainDotMX; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants use Socket; use UNIVERSAL; our $VERSION = '0.01'; =pod =head1 NAME Mail::Milter::Module::MailDomainDotMX - milter to reject mail whose sender domain publishes a null MX record =head1 SYNOPSIS use Mail::Milter::Module::MailDomainDotMX; my $milter = new Mail::Milter::Module::MailDomainDotMX; my $milter2 = &MailDomainDotMX; # convenience $milter2->set_message('Mail from %M domain invalid (has dot-MX record)'); =head1 DESCRIPTION This milter module rejects any mail from a sender's domain (in the MAIL FROM part of the SMTP transaction, not in the From: header) if that domain publishes a "null", or "dot" MX record. Such a record looks like the following in DNS: example.com. IN MX 0 . This lookup requires the Net::DNS module to be installed in order to fetch the MX record. An extra check as to whether the MX is valid is not (yet) done here. It is currently assumed that the MTA does rudimentary checking for the presence of a valid MX or A record on the sending domain. =head1 METHODS =over 4 =cut our @EXPORT = qw(&MailDomainDotMX); sub MailDomainDotMX { new Mail::Milter::Module::MailDomainDotMX(@_); } =pod =item new() Creates a MailDomainDotMX object. There are no arguments to configure this module, as it is a fixed check. =cut sub new ($) { my $this = Mail::Milter::Object::new(shift); $this->{_ignoretempfail} = 0; $this->{_message} = 'Access denied to sender address %M (domain publishes a deliberately invalid MX record)'; $this; } =pod =item ignore_tempfail(FLAG) If FLAG is 0 (the default), a DNS lookup which fails the underlying DNS query will cause the milter to return a temporary failure result (SMFIS_TEMPFAIL). If FLAG is 1, a temporary DNS failure will be treated as if the lookup resulted in an empty record set (SMFIS_CONTINUE). This method returns a reference to the object itself, allowing this method call to be chained. =cut sub ignore_tempfail ($$) { my $this = shift; my $flag = shift; croak 'ignore_tempfail: flag argument is undef' unless defined($flag); $this->{_ignoretempfail} = $flag; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting messages. This string may contain the substring C<%M>, which will be replaced by the matching e-mail address. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub envfrom_callback { my $this = shift; my $ctx = shift; my $from = lc(shift); $from =~ s/^$//; return SMFIS_CONTINUE if ($from eq ''); # null <> sender my $fromdomain = $from; $fromdomain =~ s/^[^\@]+\@//; my $res = new Net::DNS::Resolver; my $query = $res->query($fromdomain, 'MX'); if (!defined($query)) { return SMFIS_CONTINUE if $this->{_ignoretempfail}; $ctx->setreply('451', '4.7.1', "Temporary failure in DNS lookup for $fromdomain"); return SMFIS_TEMPFAIL; } foreach my $rr (grep { $_->type eq 'MX' } $query->answer) { if ($rr->exchange eq '') { my $msg = $this->{_message}; if (defined($msg)) { $msg =~ s/%M/$from/g; $ctx->setreply('554', '5.7.1', $msg); } return SMFIS_REJECT; } } SMFIS_CONTINUE; # don't whitelist a fallthrough } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/HeaderRegex.pm010064400000520000011000000072141003711020500205470ustar tvwsrc# $Id: HeaderRegex.pm,v 1.5 2004/04/12 14:21:41 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::HeaderRegex; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Module::HeaderRegex - milter to accept/reject messages with certain headers =head1 SYNOPSIS use Mail::Milter::Module::HeaderRegex; my $milter = new Mail::Milter::Module::HeaderRegex('^Foo: '); my $milter2 = &HeaderRegex('^Foo: Bar'); # convenience =head1 DESCRIPTION This milter module rejects messages at DATA phase if one of the message's headers matches user-supplied regular expressions. =head1 METHODS =over 4 =cut our @EXPORT = qw(&HeaderRegex); sub HeaderRegex { new Mail::Milter::Module::HeaderRegex(@_); } =pod =item new(REGEX[, ...]) Accepts one or more regular expressions, as strings or qr// precompiled regexes. They are tested in sequence, and the first match terminates checking. =cut sub new ($$;@) { my $this = Mail::Milter::Object::new(shift); $this->{_message} = 'Malformed or invalid header %H: in message'; croak 'new HeaderRegex: no regexes supplied' unless scalar @_; $this->{_regexes} = [ map qr/$_/i, @_ ]; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting messages. This string may contain the substring C<%H>, which will be replaced by the matching header name. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub header_callback { my $this = shift; my $ctx = shift; my $hname = shift; my $header = "$hname: ".(shift); foreach my $rx (@{$this->{_regexes}}) { if ($header =~ $rx) { my $msg = $this->{_message}; if (defined($msg)) { $msg =~ s/%H/$hname/g; $ctx->setreply('554', '5.7.1', $msg); } return SMFIS_REJECT; } } SMFIS_CONTINUE; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/ConnectMatchesHostname.pm010064400000520000011000000140431003711020500227570ustar tvwsrc# $Id: ConnectMatchesHostname.pm,v 1.4 2004/04/12 15:27:00 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::ConnectMatchesHostname; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants use Socket; our $VERSION = '0.01'; =pod =head1 NAME Mail::Milter::Module::ConnectMatchesHostname - milter to accept/reject connecting hosts matching regex(es) =head1 SYNOPSIS use Mail::Milter::Module::ConnectMatchesHostname; my $milter = new Mail::Milter::Module::ConnectMatchesHostname; my $milter2 = &ConnectMatchesHostname; # convenience $milter2->set_message('Connecting hostname %H looks like a dynamic address'); =head1 DESCRIPTION This milter module rejects any connecting host whose hostname contains one of a group of built-in patterns that match the IP address of the connecting host. This is normally used to detect dynamic pool addresses. Currently the following patterns embedded in the hostname are considered matching, where 10.11.12.13 is the IPv4 address of the connecting host. In the following cases, the string must be preceded by a non-digit character or otherwise must be at the start of the hostname. 010.011.012.013. (optionally without internal dots, or with - in place of .) 013.012.011.010. (optionally with - in place of .) 10.11.12.13. (optionally without internal dots, or with - in place of .) 13.12.11.10. (optionally with - in place of .) 0A0B0C0D (hexadecimal, ignoring case) More specific patterns are anticipated to be added in the future. Because of this, if you use ConnectMatchesHostname, pay attention to this perldoc manual page when updating to a newer version of Mail::Milter. One final note. ISPs can and do use "dynamic-looking" reverse DNS entries for what they consider to be legitimate server addresses. This is not ideal, and may require embedding this module in a Chain set to "accept_break" with regular expressions; for example: my $milter = new Mail::Milter::Chain( &ConnectRegex( '\.fooisp\.com$', )->accept_match(1); &ConnectMatchesHostname, )->accept_break(1); =head1 METHODS =over 4 =cut our @EXPORT = qw(&ConnectMatchesHostname); sub ConnectMatchesHostname { new Mail::Milter::Module::ConnectMatchesHostname(@_); } =pod =item new() Creates a ConnectMatchesHostname object. =cut sub new ($) { my $this = Mail::Milter::Object::new(shift); $this->{_message} = 'Connecting hostname %H looks like a dynamic pool address (contains the connecting address %A)'; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting connections. This string may contain the substring C<%H>, which will be replaced by the matching hostname, and/or the substring C<%A>, which will be replaced by the matching IP address. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub connect_callback { my $this = shift; my $ctx = shift; my $hostname = shift; my $pack = shift; my $addr; return SMFIS_ACCEPT if ($hostname =~ /^\[/); # We want IPv4 only (for now). $addr = eval { my @unpack = unpack_sockaddr_in($pack); inet_ntoa($unpack[1]); } unless defined($addr); return SMFIS_ACCEPT unless defined($addr); my ($i1, $i2, $i3, $i4) = split(/\./, $addr); my $f1 = sprintf('%03d', $i1); my $f2 = sprintf('%03d', $i2); my $f3 = sprintf('%03d', $i3); my $f4 = sprintf('%03d', $i4); my $hex = sprintf('%08x', unpack('N', pack('C4', $i1, $i2, $i3, $i4))); if ( $hostname =~ /(?:\A|\D)$i1[\.-]$i2[\.-]$i3[\.-]$i4\D/ || $hostname =~ /(?:\A|\D)$f1[\.-]?$f2[\.-]?$f3[\.-]?$f4\D/ || $hostname =~ /(?:\A|\D)$i4[\.-]$i3[\.-]$i2[\.-]$i1\D/ || $hostname =~ /(?:\A|\D)$f4[\.-]?$f3[\.-]?$f2[\.-]?$f1\D/ || $hostname =~ /$hex/i ) { my $msg = $this->{_message}; if (defined($msg)) { $msg =~ s/%H/$hostname/g; $msg =~ s/%A/$addr/g; $ctx->setreply('554', '5.7.1', $msg); } return SMFIS_REJECT; } SMFIS_ACCEPT; } 1; __END__ =back =head1 BUGS In Sendmail 8.11 and 8.12, a milter rejection at "connect" stage does not allow the reply message to be set -- it simply becomes "not accepting messages". However, this module still attempts to set the reply code and message in the hope that this will be fixed. The implementation of this module could be much more efficient. =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/ConnectRegex.pm010064400000520000011000000130061001744400400207510ustar tvwsrc# $Id: ConnectRegex.pm,v 1.10 2004/02/26 19:24:52 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::ConnectRegex; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants use Socket; our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Module::ConnectRegex - milter to accept/reject connecting hosts matching regex(es) =head1 SYNOPSIS use Mail::Milter::Module::ConnectRegex; my $milter = new Mail::Milter::Module::ConnectRegex('^foo$'); my $milter2 = &ConnectRegex(qw{^foo$ ^bar$}); # convenience $milter2->set_message('Connections from %H disallowed'); =head1 DESCRIPTION This milter module rejects any connecting host whose hostname or IP address matches user-supplied regular expressions. It can also function as a whitelisting Chain element; see C. =head1 METHODS =over 4 =cut our @EXPORT = qw(&ConnectRegex); sub ConnectRegex { new Mail::Milter::Module::ConnectRegex(@_); } =pod =item new(REGEX[, ...]) Accepts one or more regular expressions, as strings or qr// precompiled regexes. They are tested in sequence, and the first match terminates checking. Note that all IP address literals will be enclosed in [square brackets]; so to test an IP address rather than a hostname, ensure those brackets exist: ^\[ADDRESS\]$ =cut sub new ($$;@) { my $this = Mail::Milter::Object::new(shift); $this->{_accept} = 0; $this->{_message} = 'Not accepting connections from %H'; croak 'new ConnectRegex: no regexes supplied' unless scalar @_; $this->{_regexes} = [ map qr/$_/i, @_ ]; $this; } =pod =item accept_match(FLAG) If FLAG is 0 (the default), a matching regex will cause the connection to be rejected. If FLAG is 1, a matching regex will cause this module to return SMFIS_ACCEPT instead. This allows a C to be used inside a C container (in C mode), to function as a whitelist rather than a blacklist. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub accept_match ($$) { my $this = shift; my $flag = shift; croak 'accept_match: flag argument is undef' unless defined($flag); $this->{_accept} = $flag; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting connections. This string may contain the substring C<%H>, which will be replaced by the matching hostname or IP address. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub connect_callback { my $this = shift; my $ctx = shift; my $hostname = shift; my $pack = shift; my $addr; if ($hostname =~ /^\[/) { $addr = $hostname; undef $hostname; } # First try IPv4 unpacking. $addr = eval { my @unpack = unpack_sockaddr_in($pack); '['.inet_ntoa($unpack[1]).']'; } unless defined($addr); $addr = eval { require Socket6; my @unpack = Socket6::unpack_sockaddr_in6($pack); '['.Socket6::inet_ntop(&Socket6::AF_INET6, $unpack[1]).']'; } unless defined($addr); foreach my $rx (@{$this->{_regexes}}) { my $match; if (defined($hostname) && $hostname =~ $rx) { $match = $hostname; } elsif (defined($addr) && $addr =~ $rx) { $match = $addr; } if (defined($match)) { my $msg = $this->{_message}; return SMFIS_ACCEPT if $this->{_accept}; if (defined($msg)) { $msg =~ s/%H/$match/g; $ctx->setreply('554', '5.7.1', $msg); } return SMFIS_REJECT; } } SMFIS_CONTINUE; # don't whitelist a fallthrough } 1; __END__ =back =head1 BUGS In Sendmail 8.11 and 8.12, a milter rejection at "connect" stage does not allow the reply message to be set -- it simply becomes "not accepting messages". However, this module still attempts to set the reply code and message in the hope that this will be fixed. =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/VirusBounceSpew.pm010064400000520000011000000123371015144471100215020ustar tvwsrc# $Id: VirusBounceSpew.pm,v 1.9 2004/09/23 15:11:13 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::VirusBounceSpew; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.01'; =pod =head1 NAME Mail::Milter::Module::VirusBounceSpew - milter to reject antivirus messages typically sent to forged "senders" =head1 SYNOPSIS use Mail::Milter::Module::VirusBounceSpew; my $milter = new Mail::Milter::Module::VirusBounceSpew; my $milter2 = &VirusBounceSpew; # convenience =head1 DESCRIPTION This module rejects messages at the DATA phase by searching for known signs of misconfigured antivirus software. An increasing problem on the Internet as of this writing is a tendency for viruses and trojans to send mail with a forged envelope from address. This is triggering antivirus warning messages back to these forged senders. =head1 METHODS =over 4 =cut our @EXPORT = qw(&VirusBounceSpew); sub VirusBounceSpew { new Mail::Milter::Module::VirusBounceSpew(@_); } =pod =item new() Creates a VirusBounceSpew milter object. The match rules are internally hardcoded and may be examined by reading the module source. =cut sub new ($$;@) { my $this = Mail::Milter::Object::new(shift); $this->{_message} = 'Antivirus warning messages are not accepted here. Please configure your antivirus software not to send warning messages to forged senders!'; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting messages. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub header_callback { my $this = shift; my $ctx = shift; my $hname = shift; my $header = "$hname: ".(shift); if ( $header =~ /^From: amavisd(?:-new)? {_message}; if (defined($msg)) { $ctx->setreply('554', '5.7.1', $msg); } return SMFIS_REJECT; } SMFIS_CONTINUE; } 1; __END__ =back =head1 BUGS The rules could be much simpler, but at risk of catching legit mail. A future release will simplify the regex tests. =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/HeloUnqualified.pm010064400000520000011000000062731001744400400214530ustar tvwsrc# $Id: HeloUnqualified.pm,v 1.4 2004/02/26 19:24:52 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::HeloUnqualified; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Module::HeloUnqualified - milter to check for an unqualified HELO name =head1 SYNOPSIS use Mail::Milter::Module::HeloUnqualified; my $milter = new Mail::Milter::Module::HeloUnqualified([EXCEPT]); my $milter2 = &HeloUnqualified([EXCEPT]); # convenience =head1 DESCRIPTION This milter module rejects any domain name that HELOs without a dot, and which is not an IPv4/IPv6 literal. Whether or not the HELO value corresponds to the connecting host is not checked by this module. If the EXCEPT argument is supplied, it should be a regex enclosed in a string which will be exempted from this check. Commonly, '^localhost' is excepted. =cut our @EXPORT = qw(&HeloUnqualified); sub HeloUnqualified { new Mail::Milter::Module::HeloUnqualified(@_); } sub new ($;$) { my $this = Mail::Milter::Object::new(shift); my $except = shift; $this->{_except} = qr/$except/i if defined($except); $this; } sub helo_callback { my $this = shift; my $ctx = shift; my $helo = shift; if (($helo !~ /\./) && ($helo !~ /^\[.*\]$/) && !(defined($this->{_except}) && $helo =~ $this->{_except})) { $ctx->setreply("554", "5.7.1", "HELO/EHLO $helo: command rejected: domain name not qualified"); return SMFIS_REJECT; } SMFIS_ACCEPT; } 1; __END__ =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/ConnectDNSBL.pm010064400000520000011000000172221003757231400205550ustar tvwsrc# $Id: ConnectDNSBL.pm,v 1.6 2004/04/15 18:37:56 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::ConnectDNSBL; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants use Socket; use UNIVERSAL; our $VERSION = '0.02'; =pod =head1 NAME Mail::Milter::Module::ConnectDNSBL - milter to accept/reject connecting hosts matching DNSBLs =head1 SYNOPSIS use Mail::Milter::Module::ConnectDNSBL; my $milter = new Mail::Milter::Module::ConnectDNSBL('foo.spamlist.dom'); my $milter2 = &ConnectDNSBL('foo.spamlist.dom'); # convenience $milter2->set_message('Connections from %A disallowed'); =head1 DESCRIPTION This milter module rejects any connecting host whose IPv4 address matches a given DNS Blocking List (DNSBL). It can also function as a whitelisting Chain element; see C. The check used by this module is a simple "A" record lookup, via the standard "gethostbyname" lookup mechanism. This method does not require the use of Net::DNS and is thus typically very fast. (Note: If the connecting host is not using IPv4, this module will simply be a passthrough using SMFIS_CONTINUE.) =head1 METHODS =over 4 =cut our @EXPORT = qw(&ConnectDNSBL); sub ConnectDNSBL { new Mail::Milter::Module::ConnectDNSBL(@_); } =pod =item new(DNSBL) =item new(DNSBL, MATCHRECORD[, ...]) =item new(DNSBL, SUBREF) Creates a ConnectDNSBL object. DNSBL is the root host hierarchy to use for lookups. Three methods of matching can be used: If no additional arguments are provided, the match succeeds if there is any address entry present for the DNSBL lookup; the values are not examined. If one or more MATCHRECORD values are supplied, they are string representations of IPv4 addresses. If any of these match record values is the same as any address record returned by the DNSBL lookup, the match succeeds. If a SUBREF (reference to a subroutine; may be an anonymous inline C) is supplied, it is called for each of the address records returned by the DNSBL lookup. The subroutine should return 0 or undef to indicate a failed match, and nonzero to indicate a successful match. The subroutine receives a binary-encoded four byte scalar that should be transformed as needed with C or C. =cut sub new ($$;@) { my $this = Mail::Milter::Object::new(shift); my $dnsbl = $this->{_dnsbl} = shift; $this->{_accept} = 0; $this->{_ignoretempfail} = 0; $this->{_message} = 'Access denied to host %A (address is listed by %L)'; if (UNIVERSAL::isa($_[0], 'CODE')) { $this->{_matcher} = shift; } else { my @records; foreach my $record (@_) { my $addr = inet_aton($record); croak "new ConnectDNSBL: address $record is not a valid IPv4 address" unless defined($addr); push(@records, $addr); } if (scalar @records) { $this->{_matcher} = sub { my $addr = shift; foreach my $record (@records) { return 1 if ($addr eq $record); } undef; }; } else { $this->{_matcher} = sub { 1 }; } } $this; } =pod =item accept_match(FLAG) If FLAG is 0 (the default), a matching DNSBL will cause the connection to be rejected. If FLAG is 1, a matching DNSBL will cause this module to return SMFIS_ACCEPT instead. This allows a C to be used inside a C container (in C mode), to function as a whitelist rather than a blacklist. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub accept_match ($$) { my $this = shift; my $flag = shift; croak 'accept_match: flag argument is undef' unless defined($flag); $this->{_accept} = $flag; $this; } =pod =item ignore_tempfail(FLAG) If FLAG is 0 (the default), a DNSBL lookup which fails the underlying DNS query will cause the milter to return a temporary failure result (SMFIS_TEMPFAIL). If FLAG is 1, a temporary DNS failure will be treated as if the lookup resulted in an empty record set (SMFIS_CONTINUE). This method returns a reference to the object itself, allowing this method call to be chained. =cut sub ignore_tempfail ($$) { my $this = shift; my $flag = shift; croak 'ignore_tempfail: flag argument is undef' unless defined($flag); $this->{_ignoretempfail} = $flag; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting connections. This string may contain the substring C<%A>, which will be replaced by the matching IPv4 address, or C<%L>, which will be replaced by the name of the matching DNSBL. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub connect_callback { my $this = shift; my $ctx = shift; shift; # $hostname my $pack = shift; my $addr = eval { my @unpack = unpack_sockaddr_in($pack); $unpack[1]; }; return SMFIS_CONTINUE unless defined($addr); my $dnsbl = $this->{_dnsbl}; my $lookup = join('.', reverse(unpack('C4', $addr))).'.'.$dnsbl; my @lookup_addrs; (undef, undef, undef, undef, @lookup_addrs) = gethostbyname($lookup); unless (scalar @lookup_addrs) { # h_errno 1 == HOST_NOT_FOUND return SMFIS_CONTINUE if ($? == 1 || $this->{_ignoretempfail}); $ctx->setreply('451', '4.7.1', "Temporary failure in DNS lookup for $lookup"); return SMFIS_TEMPFAIL; } foreach my $lookup_addr (@lookup_addrs) { if (&{$this->{_matcher}}($lookup_addr)) { return SMFIS_ACCEPT if $this->{_accept}; my $msg = $this->{_message}; if (defined($msg)) { my $haddr = inet_ntoa($addr); $msg =~ s/%A/$haddr/g; $msg =~ s/%L/$dnsbl/g; $ctx->setreply('554', '5.7.1', $msg); } return SMFIS_REJECT; } } SMFIS_CONTINUE; # don't whitelist a fallthrough } 1; __END__ =back =head1 BUGS In Sendmail 8.11 and 8.12, a milter rejection at "connect" stage does not allow the reply message to be set -- it simply becomes "not accepting messages". However, this module still attempts to set the reply code and message in the hope that this will be fixed. =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Module/HeloRegex.pm010064400000520000011000000074071003652321000202550ustar tvwsrc# $Id: HeloRegex.pm,v 1.1 2004/04/12 14:24:08 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Module::HeloRegex; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.01'; =pod =head1 NAME Mail::Milter::Module::HeloRegex - milter to accept/reject connections with certain HELO values =head1 SYNOPSIS use Mail::Milter::Module::HeloRegex; my $milter = new Mail::Milter::Module::HeloRegex('^foo\.com$'); my $milter2 = &HeloRegex('^foo\.com$'); # convenience =head1 DESCRIPTION This milter module rejects entire SMTP connections if the connecting client issues a HELO command matching user-supplied regular expressions. Note that only the initial word of the HELO string is tested; any EHLO parameters are not checked by the regexes. =head1 METHODS =over 4 =cut our @EXPORT = qw(&HeloRegex); sub HeloRegex { new Mail::Milter::Module::HeloRegex(@_); } =pod =item new(REGEX[, ...]) Accepts one or more regular expressions, as strings or qr// precompiled regexes. They are tested in sequence, and the first match terminates checking. =cut sub new ($$;@) { my $this = Mail::Milter::Object::new(shift); $this->{_message} = 'HELO parameter "%H" not permitted at this site'; croak 'new HeloRegex: no regexes supplied' unless scalar @_; $this->{_regexes} = [ map qr/$_/i, @_ ]; $this; } =pod =item set_message(MESSAGE) Sets the message used when rejecting messages. This string may contain the substring C<%H>, which will be replaced by the matching HELO parameter. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub set_message ($$) { my $this = shift; $this->{_message} = shift; $this; } sub helo_callback { my $this = shift; my $ctx = shift; my $helo = shift; # ignore additional parameters foreach my $rx (@{$this->{_regexes}}) { if ($helo =~ $rx) { my $msg = $this->{_message}; if (defined($msg)) { $msg =~ s/%H/$helo/g; $ctx->setreply('554', '5.7.1', $msg); } return SMFIS_REJECT; } } SMFIS_CONTINUE; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/ContextWrapper.pm010064400000520000011000000125411001744400200201260ustar tvwsrc# $Id: ContextWrapper.pm,v 1.4 2004/02/26 19:24:50 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::ContextWrapper; use 5.006; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; our $AUTOLOAD; =pod =head1 NAME Mail::Milter::ContextWrapper - Perl extension for wrappering the milter context =head1 SYNOPSIS use Mail::Milter::ContextWrapper; my $oldctx = ($ctx from callback); # in the connect_callback $oldctx->setpriv(new Mail::Milter::ContextWrapper($ctx, { methodname => \&methodimpl[, ...] })); # in all callbacks my $newctx = $ctx->getpriv(); # in the close_callback $oldctx->setpriv(undef); =head1 DESCRIPTION Mail::Milter::ContextWrapper wraps the milter context with replacement methods defined by the caller. This can be used to intercept context object actions and manipulate them from within a Mail::Milter::Wrapper. Because the wrappering must occur on every callback, this implementation suggests embedding the wrapper inside the private data of the milter itself. This works with existing milters by providing separate "setpriv" and "getpriv" methods within the wrapper that do not propagate up to the embedded context object. =head1 METHODS =over 4 =item new(CTX, { NAME => \&SUB[, ...] }) Creates a Mail::Milter::ContextWrapper object. This should be called from the "connect" callback and passed back to C. NAMEs are names of methods to override within the wrapper. These methods will be called with the wrapper as first argument (like a normal object method). =cut sub new ($$$) { my $this = bless {}, shift; $this->{ctx} = shift; $this->{methods} = shift; $this->{keys} = {}; $this; } # private autoloader method sub AUTOLOAD { my $sub = $AUTOLOAD; my $this = $_[0]; $sub =~ s/^Mail::Milter::ContextWrapper:://; my $subref = $this->{methods}{$sub}; $subref = sub { my $this = shift; $this->get_ctx()->$sub(@_); } unless defined($subref); goto &$subref; } # since AUTOLOAD is here, we need a DESTROY sub DESTROY { my $this = shift; %$this = (); } =pod =item getpriv() Returns a private data item set by C. See L for more information. This implementation stores the datum in the wrapper, thus allowing the parent context to store a reference to the wrapper itself. This method cannot be overridden by the user. =cut sub getpriv ($) { my $this = shift; $this->{priv}; } =pod =item get_ctx() Returns the parent context object stored within this wrapper. Typically used by method overrides to defer back to the real method. This method cannot be overridden by the user. =cut sub get_ctx ($) { my $this = shift; $this->{ctx}; } =pod =item get_key(NAME) Get a keyed data item separate from the C private data. This provides out-of-band data storage that need not clobber the single "priv" data item used by most milters. =cut sub get_key ($$) { my $this = shift; my $key = shift; $this->{keys}{$key}; } =pod =item getpriv() Sets a private data item to be returned by C. See L for more information. This implementation stores the datum in the wrapper, thus allowing the parent context to store a reference to the wrapper itself. This method cannot be overridden by the user. =cut sub setpriv ($) { my $this = shift; $this->{priv} = shift; 1; } =pod =item set_key(NAME, VALUE) =item set_key(NAME => VALUE) Set a keyed data item separate from the C private data. This provides out-of-band data storage that need not clobber the single "priv" data item used by most milters. =cut sub set_key ($$$) { my $this = shift; my $key = shift; $this->{keys}{$key} = shift; 1; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L, L =cut Mail-Milter-0.06/lib/Mail/Milter/Chain.pm010064400000520000011000000173741015145031400161760ustar tvwsrc# $Id: Chain.pm,v 1.10 2004/04/23 15:51:39 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Chain; use 5.006; use strict; use warnings; use Carp; use Mail::Milter; use Sendmail::Milter 0.18; # get needed constants use UNIVERSAL; our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Chain - Perl extension for chaining milter callbacks =head1 SYNOPSIS use Mail::Milter::Chain; my $chain = new Mail::Milter::Chain({ connect => \&foo, ... }, ...); $chain->register({ connect => \&bar, ... }); $chain->register({ connect => \&baz, ... }); $chain->accept_break(1); use Sendmail::Milter; ... Sendmail::Milter::register('foo', $chain, SMFI_CURR_ACTS); =head1 DESCRIPTION Mail::Milter::Chain allows multiple milter callback sets to be registered in a single milter server instance, simulating multiple milters running in separate servers. This is typically much less resource intensive than running each milter in its own server process. Any contained milter returning SMFIS_REJECT, SMFIS_TEMPFAIL, or SMFIS_DISCARD will terminate the entire chain and return the respective code up to the containing chain or milter server. Normally, a milter returning SMFIS_ACCEPT will remove only that milter from the chain, allowing others to continue processing the message. Alternatively, SMFIS_ACCEPT can be made to terminate the entire chain as is done for error results; see C below. A C is itself a milter callback hash reference, and can thus be passed directly to C or another Mail::Milter::Chain container. IMPORTANT CAVEAT: Once this object has been registered with a parent container (a milter or another chain), DO NOT call C on this object any longer. This will result in difficult to diagnose problems at callback time. =head1 METHODS =over 4 =item new([HASHREF, ...]) Creates a Mail::Milter::Chain object. For convenience, accepts one or more hash references corresponding to individual callback sets that will be registered with this chain. =cut sub new ($) { my $this = bless {}, shift; $this->{_acceptbreak} = 0; $this->{_chain} = []; # "connect" and "helo" use the global chain, and whittle out # callbacks to be ignored for the rest of the connection. $this->{connect} = sub { $this->{_curchain} = [ @{$this->{_chain}} ]; $this->dispatch('connect', @_); }; $this->{helo} = sub { my $rc = $this->dispatch('helo', @_); $this->{_connchain} = [ @{$this->{_curchain}} ]; $rc; }; # "envfrom" uses the chain whittled by "connect" and "helo" # each pass through. $this->{envfrom} = sub { $this->{_curchain} = [ @{$this->{_connchain}} ]; $this->dispatch('envfrom', @_); }; # "close" must use the global chain always, and must also # clean up any internal state. Every callback must be called; # there are no shortcuts. $this->{close} = sub { my $ctx = shift; my $chain = $this->{_chain}; for (my $i = 0; $i < scalar @$chain; $i++) { my $cb = $chain->[$i]; $ctx->setpriv($cb->{_priv}); &{$cb->{close}}($ctx, @_) if defined($cb->{close}); } $ctx->setpriv(undef); SMFIS_CONTINUE; }; foreach my $callbacks (@_) { $this->register($callbacks); } $this; } =pod =item accept_break(FLAG) If FLAG is 0 (the default), SMFIS_ACCEPT will only remove the current milter from the list of callbacks, thus simulating a completely independent milter server. If FLAG is 1, SMFIS_ACCEPT will terminate the entire chain and propagate SMFIS_ACCEPT up to the parent chain or milter server. This allows a milter to provide a sort of "whitelist" effect, where SMFIS_ACCEPT speaks for the entire chain rather than just one milter callback set. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub accept_break ($$) { my $this = shift; my $flag = shift; croak 'accept_break: flag argument is undef' unless defined($flag); $this->{_acceptbreak} = $flag; $this; } # internal method to add dispatch closure hook as a callback sub create_callback ($$) { my $this = shift; my $cbname = shift; return 0 if defined($this->{$cbname}); $this->{$cbname} = sub { $this->dispatch($cbname, @_); }; 1; } # internal method to dispatch a callback sub dispatch ($$;@) { my $this = shift; my $cbname = shift; my $ctx = shift; # @_ is remaining args my $chain = $this->{_curchain}; my $rc = SMFIS_CONTINUE; for (my $i = 0; $i < scalar @$chain; $i++) { my $cb = $chain->[$i]; $ctx->setpriv($cb->{_priv}); my $newrc = defined($cb->{$cbname}) ? &{$cb->{$cbname}}($ctx, @_) : $rc; if ($newrc == SMFIS_TEMPFAIL || $newrc == SMFIS_REJECT) { # If "envrcpt", these are special and don't nuke. $rc = $newrc; @$chain = () unless $cbname eq 'envrcpt'; } elsif ($newrc == SMFIS_DISCARD) { $rc = $newrc; @$chain = (); } elsif ($newrc == SMFIS_ACCEPT) { if ($this->{_acceptbreak}) { @$chain = (); } else { splice(@$chain, $i, 1); $i--; } } elsif ($newrc != SMFIS_CONTINUE) { warn "chain element returned invalid result $newrc\n"; $rc = SMFIS_TEMPFAIL; @$chain = (); } $cb->{_priv} = $ctx->getpriv(); } # If we're still at SMFIS_CONTINUE and the chain is empty, # convert to a SMFIS_ACCEPT to bubble up to the parent. $rc = SMFIS_ACCEPT if ($rc == SMFIS_CONTINUE && !scalar @$chain); $ctx->setpriv(undef); $rc; } =pod =item register(HASHREF) Registers a callback set with this chain. Do not call after this chain has itself been registered with a parent container (chain or milter server). =cut sub register ($$) { my $this = shift; my $callbacks = shift; my $pkg = caller; croak 'register: callbacks is undef' unless defined($callbacks); croak 'register: callbacks not hash ref' unless UNIVERSAL::isa($callbacks, 'HASH'); # make internal copy, and convert to code references my $ncallbacks = {}; foreach my $cbname (keys %Sendmail::Milter::DEFAULT_CALLBACKS) { my $cb = $callbacks->{$cbname}; next unless defined($cb); $ncallbacks->{$cbname} = Mail::Milter::resolve_callback($cb, $pkg); $this->create_callback($cbname); } # add to chain push(@{$this->{_chain}}, $ncallbacks); 1; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L, L =cut Mail-Milter-0.06/lib/Mail/Milter/Wrapper004075500000520000011000000000001015145064000161505ustar tvwsrcMail-Milter-0.06/lib/Mail/Milter/Wrapper/DecodeSRS.pm010064400000520000011000000101151012456415500203420ustar tvwsrc# $Id: DecodeSRS.pm,v 1.1 2004/09/23 15:14:53 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Wrapper::DecodeSRS; use 5.006; use base Exporter; use base Mail::Milter::Wrapper; use strict; use warnings; use Carp; use Mail::Milter::ContextWrapper; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.01'; =pod =head1 NAME Mail::Milter::Wrapper::DecodeSRS - milter wrapper to decode SRS-encoded return path =head1 SYNOPSIS use Mail::Milter::Wrapper::DecodeSRS; my $milter = ...; my $wrapper = new Mail::Milter::Wrapper::DecodeSRS($milter); my $wrapper2 = &DecodeSRS($milter); # convenience =head1 DESCRIPTION Mail::Milter::Wrapper::DecodeSRS is a convenience milter wrapper which decodes MAIL FROM: return paths which have been encoded by the Sender Rewrite Scheme, SRS. (More information: http://www.libsrs2.org/) This wrapper internally understands both the SRS0 and SRS1 encoding schemes documented by the Mail::SRS author. The decoded address is made available to the contained milter via the C callback, in the same way that a raw address would. NOTE: If the address is not SRS encoded, the contained milter is NOT called for the duration of the message; instead, SMFIS_ACCEPT is returned. This is because the milter writer is expected to use this wrapper in a chain that also includes the contained milter without wrapping, in order to prevent a malicious sender from using SRS to bypass access checks. For instance, the following is a proper usage of this wrapper in a chain: my $envfrommilter = ...; my $combinedmilter = new Mail::Milter::Chain( new Mail::Milter::Wrapper::UnwrapSRS($envfrommilter), $envfrommilter ); This behavior can also be used if, e.g., the MTA already does one form of MAIL FROM: check, and the contained milter repeats that same database check against SRS rewritten addresses. (A good example would be a milter emulating Sendmail's access_db map.) =cut our @EXPORT = qw(&DecodeSRS); sub DecodeSRS { new Mail::Milter::Wrapper::DecodeSRS(@_); } sub new ($$) { my $this = Mail::Milter::Wrapper::new(shift, shift, \&wrapper, qw{connect close}); $this; } # internal methods sub wrapper { my $this = shift; my $cbname = shift; my $callback_sub = shift; if ($cbname eq 'envfrom') { if ($_[1] !~ /^tv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Wrapper/RejectMsgEditor.pm010064400000520000011000000074161001744400500216230ustar tvwsrc# $Id: RejectMsgEditor.pm,v 1.6 2004/02/26 19:24:53 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Wrapper::RejectMsgEditor; use 5.006; use base Exporter; use base Mail::Milter::Wrapper; use strict; use warnings; use Carp; use Mail::Milter::ContextWrapper; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Wrapper::RejectMsgEditor - milter wrapper to edit rejection messages =head1 SYNOPSIS use Mail::Milter::Wrapper::RejectMsgEditor; my $milter = ...; my $wrapper = new Mail::Milter::Wrapper::RejectMsgEditor($milter, \&sub); my $wrapper2 = &RejectMsgEditor($milter, \&sub); # convenience =head1 DESCRIPTION Mail::Milter::Wrapper::RejectMsgEditor is a convenience milter wrapper which allows editing of the messages returned for all SMFIS_REJECT rejections. The subroutine provided should edit $_ and need not return any value. If the contained milter did not call C<$ctx->setreply()> before returning a rejection code, then a default message will be used. For example: my $wrapped_milter = &RejectMsgEditor($milter, sub { s,$, - Please e-mail postmaster\@foo.com for assistance., }); =cut our @EXPORT = qw(&RejectMsgEditor); sub RejectMsgEditor { new Mail::Milter::Wrapper::RejectMsgEditor(@_); } sub new ($$\&) { my $this = Mail::Milter::Wrapper::new(shift, shift, \&wrapper, qw{connect close}); $this->{_editor} = shift; $this; } # internal methods sub wrapper { my $this = shift; my $cbname = shift; my $callback_sub = shift; my $oldctx = shift; my $newctx = $oldctx->getpriv(); unless (defined($newctx)) { $newctx = new Mail::Milter::ContextWrapper($oldctx, { setreply => sub { shift->set_key(reply => [ @_ ]); }, }); $oldctx->setpriv($newctx); } my $rc = &$callback_sub($newctx, @_); my $reply = $newctx->get_key('reply'); $newctx->set_key(reply => undef); if ($rc == SMFIS_REJECT) { $reply = [ 554, '5.7.0', 'Command rejected' ] unless $reply; local $_ = $reply->[2]; &{$this->{_editor}}; $reply->[2] = $_; } $oldctx->setreply(@$reply) if $reply; $oldctx->setpriv(undef) if ($cbname eq 'close'); $rc; } 1; __END__ =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Wrapper/DeferToRCPT.pm010064400000520000011000000127411015145031500206070ustar tvwsrc# $Id: DeferToRCPT.pm,v 1.8 2004/04/23 15:54:14 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Wrapper::DeferToRCPT; use 5.006; use base Exporter; use base Mail::Milter::Wrapper; use strict; use warnings; use Carp; use Mail::Milter::ContextWrapper; use Sendmail::Milter 0.18; # get needed constants our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Wrapper::DeferToRCPT - milter wrapper to delay failure returns =head1 SYNOPSIS use Mail::Milter::Wrapper::DeferToRCPT; my $milter = ...; my $wrapper = new Mail::Milter::Wrapper::DeferToRCPT($milter); my $wrapper2 = &DeferToRCPT($milter); # convenience =head1 DESCRIPTION Mail::Milter::Wrapper::DeferToRCPT is a convenience milter wrapper which defers any error return during the "connect", "helo", and/or "envfrom" callbacks to the "envrcpt" callback. Many broken client mailers exist in the real world and will do such things as instantaneously reconnect when receiving an error at the MAIL FROM: stage. This wrapper ensures that errors are never propagated back to the MTA until at least the RCPT TO: phase. Errors in "connect" and "helo" will apply to the entire SMTP transaction. Errors in "envfrom" will only apply to that particular message. This wrapper can also be used to enhance logging. Though the contained milter may wish to reject a mail in progress, it may be useful for logging purposes to capture the HELO string, sender, and recipient addresses of each attempted mail. =cut our @EXPORT = qw(&DeferToRCPT); sub DeferToRCPT { new Mail::Milter::Wrapper::DeferToRCPT(@_); } sub new ($$) { Mail::Milter::Wrapper::new(shift, shift, \&wrapper, qw{connect envfrom envrcpt close}); } # internal methods sub wrapper { my $this = shift; my $cbname = shift; my $callback_sub = shift; my $oldctx = shift; my $newctx = $oldctx->getpriv(); unless (defined($newctx)) { $newctx = new Mail::Milter::ContextWrapper($oldctx, { setreply => sub { shift->set_key(reply => [ @_ ]); }, }); $oldctx->setpriv($newctx); } # If rejection is pending, "stage" has the value: # 0, if rejected in "connect" or "helo" for whole connection. # 1, if rejected in "envfrom". # 2, if rejected in "envrcpt" or later. my $rc = $newctx->get_key('rc'); if ($cbname eq 'connect' || $cbname eq 'close') { # # Always start fresh. # $newctx->set_key(stage => 0); $newctx->set_key(reply => undef); $newctx->set_key(rc => ($rc = SMFIS_CONTINUE)); } elsif ($cbname eq 'envfrom') { # # If we've reached this point naturally or the last # reject was in "envfrom", then reset state. # if ($rc == SMFIS_CONTINUE || $newctx->get_key('stage') >= 1) { $newctx->set_key(stage => 1); $newctx->set_key(reply => undef); $newctx->set_key(rc => ($rc = SMFIS_CONTINUE)); } } elsif ($cbname eq 'envrcpt') { # # If we've reached this point naturally, then reset state. # if ($rc == SMFIS_CONTINUE) { $newctx->set_key(stage => 2); $newctx->set_key(reply => undef); $newctx->set_key(rc => $rc); } } # Only call the callback if there is not a pending error. $rc = &$callback_sub($newctx, @_) if ($rc == SMFIS_CONTINUE); if (($cbname eq 'connect' || $cbname eq 'helo' || $cbname eq 'envfrom') && ($rc == SMFIS_TEMPFAIL || $rc == SMFIS_REJECT)) { # # Convert error to pending, and return CONTINUE. # $newctx->set_key(rc => $rc); $rc = SMFIS_CONTINUE; } # Propagate the replycode only if we'll be returning an error. if ($rc == SMFIS_TEMPFAIL || $rc == SMFIS_REJECT) { my $reply = $newctx->get_key('reply'); if ($reply) { $reply->[0] = 550 if ($reply->[0] == 554); $oldctx->setreply(@$reply); } } if ($newctx->get_key('stage') >= 2) { # # If we weren't rejected in stages 0 or 1, then reset state. # $newctx->set_key(rc => SMFIS_CONTINUE); $newctx->set_key(reply => undef); } $oldctx->setpriv(undef) if ($cbname eq 'close'); $rc; } 1; __END__ =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.06/lib/Mail/Milter/Object.pm010064400000520000011000000076141001744400300163550ustar tvwsrc# $Id: Object.pm,v 1.3 2004/02/26 19:24:51 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter::Object; use 5.006; use base Exporter; use strict; use warnings; use Sendmail::Milter 0.18; # get needed constants use Symbol; use UNIVERSAL; our $VERSION = '0.03'; =pod =head1 NAME Mail::Milter::Object - Perl extension to encapsulate a milter in an object =head1 SYNOPSIS package Foo; use base Mail::Milter::Object; sub connect_callback { my $this = shift; my $ctx = shift; my @connect_args = @_; ... } ... my $milter = new Foo; =head1 DESCRIPTION Normally, milters passed to C consist of nondescript hash references. C transforms these callback hashes into fully qualified objects that are easier to maintain and understand. In conjunction with C, this also allows for a more modular approach to milter implementation, by allowing each milter to be a small, granular object that can exist independently of other milters. Each object inheriting from this class has access to the hash reference making up the object itself. Two caveats must be noted when accessing this hashref: * Key names used for private data should be prefixed by an underscore (_) in order to prevent accidental recognition as a callback name. * Since a milter object can be reused many times throughout its existence, and perhaps reentrantly if threads are in use, the hashref should contain only global configuration data for this object rather than per-message data. Data stored per message or connection should be stashed in the milter context object by calling C and C on the context object. =head1 METHODS =over 4 =item new() Creates a new C. The fully qualified class is scanned for milter callback methods with names of the form CALLBACK_callback. If such a method exists, a corresponding callback entry point is added to this object. =cut sub new ($) { my $this = bless {}, shift; foreach my $cbname (keys %Sendmail::Milter::DEFAULT_CALLBACKS) { my $fullcbname = $cbname.'_callback'; next unless (UNIVERSAL::can($this, $fullcbname)); $this->{$cbname} = sub { $this->$fullcbname(@_); }; } $this; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L, L. =cut Mail-Milter-0.06/lib/Mail/Milter.pm010064400000520000011000000051621015145031400151440ustar tvwsrc# $Id: Milter.pm,v 1.24 2004/11/25 21:36:49 tvierling Exp $ # # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. package Mail::Milter; use 5.006; use strict; use warnings; use Carp; use Symbol; use UNIVERSAL; our $VERSION = '0.06'; # internal function to resolve a callback from name to coderef sub resolve_callback ($$) { my $cb = shift; my $pkg = shift; unless (UNIVERSAL::isa($cb, 'CODE')) { my $cbref = qualify_to_ref($cb, $pkg); croak "callback points to nonexistent sub ${pkg}::${cb}" unless exists(&$cbref); $cb = \&$cb; } $cb; } 1; __END__ =pod =head1 NAME Mail::Milter - Perl extension modules for mail filtering via milter =head1 SEE ALSO L L L L the Mail::Milter::Module::* manpages -- these include: * ConnectASNBL * ConnectDNSBL * ConnectMatchesHostname * ConnectRegex * HeaderFromMissing * HeaderRegex * HeloRawLiteral * HeloRegex * HeloUnqualified * MailDomainDNSBL * MailDomainDotMX * VirusBounceSpew the Mail::Milter::Wrapper::* manpages -- these include: * DecodeSRS * DeferToRCPT * RejectMsgEditor =cut Mail-Milter-0.06/examples004075500000520000011000000000001015145064000134625ustar tvwsrcMail-Milter-0.06/examples/duh.org004075500000520000011000000000001015145064000150305ustar tvwsrcMail-Milter-0.06/examples/duh.org/milter.pl010075500000520000011000000240561015145031400167450ustar tvwsrc#!/usr/local/bin/perl -w -I../../lib # $Id: milter.pl,v 1.23 2004/07/30 17:31:47 tvierling Exp $ # # Copyright (c) 2002 Todd Vierling . # This file is hereby released to the public and is free for any use. # # This is the actual Mail::Milter instance running in production on the # duh.org mail server as of the RCS datestamp above. This may be useful # to you as a template or suggestion for your own milter installation. # use strict; use warnings; use Carp qw{verbose}; use Mail::Milter::Chain; use Mail::Milter::Module::ConnectASNBL; use Mail::Milter::Module::ConnectDNSBL; use Mail::Milter::Module::ConnectMatchesHostname; use Mail::Milter::Module::ConnectRegex; use Mail::Milter::Module::HeaderFromMissing; use Mail::Milter::Module::HeaderRegex; use Mail::Milter::Module::HeloRawLiteral; use Mail::Milter::Module::HeloRegex; use Mail::Milter::Module::HeloUnqualified; use Mail::Milter::Module::MailDomainDNSBL; use Mail::Milter::Module::VirusBounceSpew; use Mail::Milter::Wrapper::DeferToRCPT; use Mail::Milter::Wrapper::RejectMsgEditor; use Sendmail::Milter 0.18; use Socket; # # This file is arranged in top-down order. Objects constructed # closer to the top have deeper nesting into the milter tree, # and will be reached last; conversely, objects at the bottom are # reached first. # ##### Bad headers # # It would be nice if we rejected before DATA, but alas, that's not # always possible. However, there are some distinct spamsigns # present in mail headers. YMMV. # my $bad_headers = &HeaderRegex( # these don't belong in transit '^X-UIDL: ', ); my $spam_headers = &HeaderRegex( # known spamware '^X-(?:AD2000-Serial|Advertisement):', '^X-Mailer: (?:Mail Bomber|Accucast)', # older Pegasus does this, but *lots* of spamware does too '^Comments: Authenticated sender is', # the law says you must tag, and my sanity says I must block '^Subject: ADV ?:', )->set_message( 'NO UCE means NO SPAM (no kidding!)' ); my $disallowed_encodings = '(?:'.join('|', qw{ big5 koi8-r windows-125. }).')'; my $disallowed_encoding_headers = &HeaderRegex( '^Subject: =\?'.$disallowed_encodings.'\?', '^Content-Type:.*\scharset='.$disallowed_encodings, )->set_message( 'Your international character set is not understood here; re-send your message using standard ISO-8859 or UTF8 encoding' ); my $cloaked_encoding_headers = &HeaderRegex( '^(?:Subject|From|To): =\?(?:US-ASCII|ISO-8859-1)\?' )->set_message( 'Encoded US-ASCII or ISO-8859-1 headers are not allowed due to severe abuse; re-send your message without the encoding' ); ##### Dynamic pool rDNS, with exceptions. # # "Good" ISPs partition their dynamic pools into easy-to-identify # subdomains. But some don't, so here we go.... # my $dynamic_rdns = new Mail::Milter::Chain( # Grrr. I shouldn't have to do this. GET REAL rDNS, PEOPLE! &ConnectRegex( '\.(?:biz\.rr\.com|ipxserver\.de|knology\.net|netrox\.net|dq1sn\.easystreet\.com|(?:scrm01|snfc21)\.pacbell\.net)$', '^wsip-[\d-]+\..*\.cox\.net$', )->accept_match(1), &ConnectRegex( '^cablelink[\d-]+\.intercable\.net$', )->set_message( 'Dynamic pool: Connecting hostname %H is a dynamic address. If this mail has been rejected in error' ), &ConnectMatchesHostname->set_message( 'Dynamic pool: Connecting hostname %H contains IP address %A. If this mail has been rejected in error' ), )->accept_break(1); ##### Custom milter modules # # Don't ask and don't use. These are duh.org site-specific, and are likely # of zero usefulness to anyone else. # # (empty) ##### Per-country restrictions # # The following special hack has existed in the duh.org mail config in some # form for a very long time. It requires a proper /usr/share/misc/country # file (originally from *BSD) to map the two-letter country codes back to # their ISO numeric equivalents used in zz.countries.nerd.dk. # my @ccs = qw(AR BR CL CN CO JO KR MX MY NG PK SG TH TM TW); my %ccs = map { $_ => 1 } @ccs; my @zzccs; open(CC, ') { s/#.*$//; s/\s+$//; # also strips newlines my @entry = split(/\t/); next unless @entry; if ($ccs{$entry[1]}) { $entry[3] =~ s/^0+//; push(@zzccs, inet_ntoa(pack('N', 0x7f000000 + $entry[3]))); } } close(CC); ##### DNSBL checks # # There's quite a few used here, not all of which are appropriate for all # sites. My site is somewhere between "lenient" and "strict", but YMMV. # Use with caution. # # ordering rationale: in each set, zones queried in an earlier set are # queried first in subsequent sets so as to reuse named-cached values my $country_msg = 'Access denied to %A: Due to excessive spam, we do not normally accept mail from your country'; my @country_dnsbls = ( &ConnectDNSBL('zz.countries.nerd.dk', @zzccs)->set_message($country_msg), ); my $relay_msg = 'Access denied to %A: This address is vulnerable to open-relay/open-proxy attacks (listed in %L)'; my @relayinput_dnsbls = ( &ConnectDNSBL('combined.njabl.org', '127.0.0.2', '127.0.0.9')->set_message($relay_msg), &ConnectDNSBL('dnsbl.sorbs.net', (map "127.0.0.$_", (2,3,4,5,9)))->set_message($relay_msg), &ConnectDNSBL('list.dsbl.org')->set_message($relay_msg), &ConnectDNSBL('relays.visi.com')->set_message($relay_msg), ); my $dynamic_msg = 'Dynamic pool: Connecting address %A is a dynamic address (listed in %L). If this mail has been rejected in error'; my @dynamic_dnsbls = ( &ConnectDNSBL('combined.njabl.org', '127.0.0.3')->set_message($dynamic_msg), &ConnectDNSBL('dnsbl.sorbs.net', '127.0.0.10')->set_message($dynamic_msg), ); # ...and these use the default message. my @generic_dnsbls = ( &ConnectDNSBL('combined.njabl.org', '127.0.0.4'), &ConnectDNSBL('l1.spews.dnsbl.sorbs.net'), # &ConnectDNSBL('spews.blackholes.us'), # alternate for SPEWS &ConnectDNSBL('sbl-xbl.spamhaus.org'), ); my @rhsbls = ( &MailDomainDNSBL('nomail.rhsbl.sorbs.net'), &MailDomainDNSBL('rhsbl.ahbl.org'), &MailDomainDNSBL('bogusmx.rfc-ignorant.org'), ); ##### Inner chain: main collection of checks # # As well as the more complicated checks above, I've added some # simpler ones directly in-line below. # my $inner_chain = new Mail::Milter::Chain( &ConnectASNBL('asn.routeviews.org', 11969, # Thought to be Dynamic Pipe 14479, # Webfinity (Dynamic Pipe) 19961, # Dynamic Pipe ), $dynamic_rdns, @country_dnsbls, @relayinput_dnsbls, @dynamic_dnsbls, @generic_dnsbls, &HeloUnqualified, &HeloRawLiteral, &HeloRegex( '^humblenet\.com$', ), @rhsbls, &HeaderFromMissing, $bad_headers, $spam_headers, $disallowed_encoding_headers, $cloaked_encoding_headers, &VirusBounceSpew, # { # connect => sub { # my $ctx = shift; # my $host = shift; # if ($host =~ /^\[/) { # $ctx->setreply(451, '4.7.0', "Host $host has no reverse DNS -- Please email postmaster\@duh.org for assistance."); # return SMFIS_TEMPFAIL; # } # SMFIS_CONTINUE; # }, # }, { envfrom => sub { my $ctx = shift; if (shift ne '<>') { $ctx->setpriv(undef); return SMFIS_ACCEPT; } $ctx->setpriv(0); SMFIS_CONTINUE; }, envrcpt => sub { my $ctx = shift; my $nullcount = $ctx->getpriv; $ctx->setpriv(++$nullcount); if ($nullcount > 1) { $ctx->setreply(554, '5.7.0', 'Null sender <> mail should have only one recipient'); return SMFIS_REJECT; } SMFIS_CONTINUE; }, eoh => sub { my $ctx = shift; my $nullcount = $ctx->getpriv; if ($nullcount > 1) { $ctx->setreply(554, '5.7.0', 'Null sender <> mail should have only one recipient'); return SMFIS_REJECT; } SMFIS_ACCEPT; }, }, ); ##### Error message rewriter: point user to postmaster@duh.org # # Since postmaster@duh.org is exempted below, prompting the user # to send mail there is an in-band way to receive messages about # blocking errors from legit users. This is much more desirable # then redirecting to a URL. # my $rewritten_chain = &RejectMsgEditor($inner_chain, sub { s,$, -- Please e-mail postmaster\@duh.org for assistance.,; }); ##### Outer chain: "postmaster" recipients get everything; exempt hosts. # # This is accomplished by using a chain in "accept_break" mode, # where connect from particular hosts (like localhost) and envrcpt # on "postmaster@" returns SMFIS_ACCEPT and thus skips any other # return value pending. # # For the postmaster@ check to work, this requires funneling errors # through "DeferToRCPT" in order to ensure that the RCPT TO: phase # is reached. # # First fetch the /etc/mail/relay-domains list. # Note that I already put "localhost" in that file, so it's not # specified again in the call to ConnectRegex below. my @relay_domain_regexes; open(I, ') { chomp; s/#.*$//; s/^\s+//; s/\s+$//; next if /^$/; # Dots are escaped to make them valid in REs. s/\./\\\./g; if (/^[0-9\\\.]+$/) { # IP address; match a literal. s/$/\]/ unless /\\\.$/; # if not ending in a dot, match exactly push(@relay_domain_regexes, qr/^\[$_/i); } else { # Domain/host name; match string as-is. s/^/\^/ unless /^\\\./; # if not starting with a dot, match exactly push(@relay_domain_regexes, qr/$_$/i); } } close(I); my $outer_chain = new Mail::Milter::Chain( &ConnectRegex( @relay_domain_regexes, )->accept_match(1), { # add delays to certain parts of transactions to trip ratware # (this requires setting T=R:4m or so in sendmail.mc) connect => sub { my $ctx = shift; my $host = shift; $ctx->setpriv(1) if ($host =~ /^\[/); # flag no rDNS SMFIS_CONTINUE; }, envfrom => sub { my $ctx = shift; sleep 120 if $ctx->getpriv(); # no rDNS SMFIS_CONTINUE; }, envrcpt => sub { my $ctx = shift; sleep 30 if $ctx->getpriv(); # no rDNS SMFIS_CONTINUE; }, }, { envrcpt => sub { shift; # $ctx (shift =~ /^accept_break(1); ##### The milter itself. # # I personally use Sendmail::PMilter under the covers, but I'm # deliberately using the Sendmail::Milter API below to make this # example work outside my installation. # Sendmail::Milter::auto_setconn('pmilter'); Sendmail::Milter::register('pmilter', $outer_chain, SMFI_CURR_ACTS); Sendmail::Milter::main(25, 50); Mail-Milter-0.06/examples/duh.org/restart.sh010075500000520000011000000003521003063032000171160ustar tvwsrc#!/bin/sh # $Id: restart.sh,v 1.3 2004/03/25 18:59:15 tvierling Exp $ cd $(dirname $0) kill $(cat milter.pid) sleep 1 sh -c ' export PMILTER_DISPATCHER=prefork echo $$ >milter.pid exec nice -n +4 ./milter.pl >milter.log 2>&1 ' & Mail-Milter-0.06/Changes010064400000520000011000000040101015145042200132040ustar tvwsrc$Id: Changes,v 1.28 2004/11/25 21:39:30 tvierling Exp $ Revision history for Perl extension Mail::Milter. 0.06 Thu Nov 25 20:30:00 2004 UTC - fixed Mail::Milter::Chain where second and subsequent RCPTs were not being rejected properly - fixed Mail::Milter::Wrapper::DeferToRCPT where a reject at envfrom was propagated as-is to further envfroms on the same session (should be per-envfrom only) - added Mail::Milter::Module::ConnectASNBL - added Mail::Milter::Wrapper::DecodeSRS - fixed parsing of AS_SETs in the AS list returned from the DNSBL - added Mail::Milter::Module::MailDomainDotMX 0.05 Thu Apr 15 19:15:00 2004 UTC - fixed Mail::Milter::Module::*DNSBL to return a descriptive 451 error on a temporary DNSBL failure - fixed Mail::Milter::Module::MailDomainDNSBL not to break on <> sender (would cause a query beginning with a dot) 0.04 [withdrawn due to <> bug fixed in 0.05, above] - added modules Mail::Milter::Module::ConnectDNSBL Mail::Milter::Module::HeloRegex Mail::Milter::Module::MailDomainDNSBL Mail::Milter::Module::VirusBounceSpew - changed Mail::Milter::Wrapper::DeferToRCPT to intercept normally 554 SMTP response codes (not valid for RCPT per RFC2822), and replace them with 550 (which is valid, ibid.). 0.03 Mon Mar 29 17:30:00 2004 UTC - added module Mail::Milter::Module::ConnectMatchesHostname 0.02 Wed Feb 25 16:45:00 2004 UTC - added several Modules and Wrappers Mail::Milter::Module::ConnectRegex Mail::Milter::Module::HeaderRegex Mail::Milter::Module::HeloRawLiteral Mail::Milter::Wrapper::DeferToRCPT Mail::Milter::Wrapper::RejectMsgEditor - API CHANGE: changed Mail::Milter::Wrapper to pass reference to wrapper as first arg to wrapper subroutine 0.01 Tue Feb 24 02:20:00 2004 UTC - first version, including: Mail::Milter::Chain - chains multiple milters Mail::Milter::Object - reworks milter into an object model Mail::Milter::Wrapper - intercepts milter calls with a hook Mail::Milter::Module::HeaderFromMissing Mail::Milter::Module::HeloUnqualified Mail-Milter-0.06/MANIFEST010064400000520000011000000016231015145064000130530ustar tvwsrcChanges Makefile.PL MANIFEST README examples/duh.org/milter.pl examples/duh.org/restart.sh lib/Mail/Milter.pm lib/Mail/Milter/Chain.pm lib/Mail/Milter/ContextWrapper.pm lib/Mail/Milter/Module/ConnectDNSBL.pm lib/Mail/Milter/Module/ConnectMatchesHostname.pm lib/Mail/Milter/Module/ConnectRegex.pm lib/Mail/Milter/Module/HeaderRegex.pm lib/Mail/Milter/Module/HeaderFromMissing.pm lib/Mail/Milter/Module/HeloRawLiteral.pm lib/Mail/Milter/Module/HeloRegex.pm lib/Mail/Milter/Module/HeloUnqualified.pm lib/Mail/Milter/Module/MailDomainDNSBL.pm lib/Mail/Milter/Module/MailDomainDotMX.pm lib/Mail/Milter/Module/VirusBounceSpew.pm lib/Mail/Milter/Object.pm lib/Mail/Milter/Wrapper.pm lib/Mail/Milter/Wrapper/DecodeSRS.pm lib/Mail/Milter/Wrapper/DeferToRCPT.pm lib/Mail/Milter/Wrapper/RejectMsgEditor.pm t/00_milter.t t/01_chain.t t/02_object.t META.yml Module meta-data (added by MakeMaker) Mail-Milter-0.06/META.yml010064400000520000011000000005321015145064000131710ustar tvwsrc# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Mail-Milter version: 0.06 version_from: lib/Mail/Milter.pm installdirs: site requires: Sendmail::Milter: 0.18 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Mail-Milter-0.06/README010064400000520000011000000063541015145031400126060ustar tvwsrcMail::Milter version 0.06 ========================= $Id: README,v 1.11 2004/04/23 15:54:37 tvierling Exp $ Mail::Milter is a set of modules useful to mail filter writers who are using the Sendmail::Milter and/or Sendmail::PMilter APIs to interface directly to the SMTP transaction. Among those currently included are: Mail::Milter::Chain A milter container. This allows multiple milter instances to exist within a single milter server, and still play together nicely. With this, an almost rule-based meta-milter can be created. Mail::Milter::Object Allows a milter to exist as a blessed object, using method names rather than subroutine references to supply the callbacks. This adds modularity and makes milter objects easier to understand. Mail::Milter::Wrapper "Wraps" a milter with a user-supplied interception subroutine. This can be used to defer a failure return code, add a descriptive message, and many other things. Mail::Milter::Module::* Off-the-shelf milter modules that perform commonly used functions. Most useful in conjunction with Mail::Milter::Chain. Mail::Milter::Wrapper::* Off-the-shelf milter wrappers that can perform commonly desired editing operations on milter return codes. For a complete list of available modules, see "perldoc Mail::Milter". ===== INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Sendmail::Milter 0.18 or later (Alternatively, Sendmail::PMilter 0.90 or later) COPYRIGHT AND LICENCE Mail::Milter is part of the PMilter project: http://pmilter.sourceforge.net/ The PMilter packages are: # Copyright (c) 2002-2004 Todd Vierling # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # 3. Neither the name of the author nor the names of contributors may be used # to endorse or promote products derived from this software without specific # prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. Mail-Milter-0.06/Makefile.PL010064400000520000011000000005161001645371700137040ustar tvwsrc# $Id: Makefile.PL,v 1.1 2004/02/23 19:43:11 tvierling Exp $ use 5.006; use ExtUtils::MakeMaker; WriteMakefile( ABSTRACT_FROM => 'lib/Mail/Milter.pm', AUTHOR => 'Todd Vierling ', NAME => 'Mail::Milter', PREREQ_PM => { 'Sendmail::Milter' => '0.18', }, VERSION_FROM => 'lib/Mail/Milter.pm', );