Mail-Milter-0.07004075500000520000000000000000001041027110700117665ustar tvwheelMail-Milter-0.07/lib004075500000520000000000000000001041027110700125345ustar tvwheelMail-Milter-0.07/lib/Mail004075500000520000000000000000001041027110700134165ustar tvwheelMail-Milter-0.07/lib/Mail/Milter004075500000520000000000000000001041027110700146525ustar tvwheelMail-Milter-0.07/lib/Mail/Milter/Wrapper.pm010064400000520000000000000100141014025637200167070ustar tvwheel# $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.07/lib/Mail/Milter/Module004075500000520000000000000000001041027110700160775ustar tvwheelMail-Milter-0.07/lib/Mail/Milter/Module/MailBogusNull.pm010064400000520000000000000076621041027070700212460ustar tvwheel# $Id: MailBogusNull.pm,v 1.2 2006/03/22 15:48:23 tvierling Exp $ # # Copyright (c) 2006 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::MailBogusNull; 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::MailBogusNull - milter to reject null-sender mail to multiple recipients =head1 SYNOPSIS use Mail::Milter::Module::MailBogusNull; my $milter = new Mail::Milter::Module::MailBogusNull; my $milter2 = &MailBogusNull; # convenience $milter2->set_message('Null sender mail should go to only one recipient'); =head1 DESCRIPTION This milter module rejects any mail from a C (empty CE> address) which attempts to deliver to multiple recipients. Normal delivery status notifications are intended for a single message, and thus should only ever be addressed to a single recipient. =head1 METHODS =over 4 =cut our @EXPORT = qw(&MailBogusNull); sub MailBogusNull { new Mail::Milter::Module::MailBogusNull(@_); } =pod =item new() Creates a MailBogusNull 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} = 'Sender <> delivery status notifications cannot be addressed to more than one recipient'; $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 envfrom_callback { my $this = shift; my $ctx = shift; if (shift ne '<>') { $ctx->setpriv(undef); return SMFIS_ACCEPT; } $ctx->setpriv(0); SMFIS_CONTINUE; } sub envrcpt_callback { my $this = shift; my $ctx = shift; my $nullcount = $ctx->getpriv; $ctx->setpriv(++$nullcount); if ($nullcount > 1) { $ctx->setreply(554, '5.7.0', $this->{_message}); return SMFIS_REJECT; } SMFIS_CONTINUE; } sub eoh_callback { my $this = shift; my $ctx = shift; if ($ctx->getpriv() > 1) { $ctx->setreply(554, '5.7.0', $this->{_message}); return SMFIS_REJECT; } SMFIS_ACCEPT; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.07/lib/Mail/Milter/Module/HeaderFromMissing.pm010064400000520000000000000057641001744466600221120ustar tvwheel# $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.07/lib/Mail/Milter/Module/HeaderRegex.pm010064400000520000000000000072141003652276500207150ustar tvwheel# $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.07/lib/Mail/Milter/Module/ConnectMatchesHostname.pm010064400000520000000000000140431003653250400231150ustar tvwheel# $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.07/lib/Mail/Milter/Module/ConnectRegex.pm010064400000520000000000000130061001744466600211140ustar tvwheel# $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.07/lib/Mail/Milter/Module/VirusBounceSpew.pm010064400000520000000000000123371012456362100216310ustar tvwheel# $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.07/lib/Mail/Milter/Module/HeloUnqualified.pm010064400000520000000000000062731001744466600216160ustar tvwheel# $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.07/lib/Mail/Milter/Module/HeaderValidateMIME.pm010064400000520000000000000062741041006065500220400ustar tvwheel# $Id: HeaderValidateMIME.pm,v 1.1 2006/03/21 20:27:25 tvierling Exp $ # # Copyright (c) 2006 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::HeaderValidateMIME; 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.01'; =pod =head1 NAME Mail::Milter::Module::HeaderValidateMIME - enforce MIME header conformance =head1 SYNOPSIS use Mail::Milter::Module::HeaderValidateMIME; my $milter = new Mail::Milter::Module::HeaderValidateMIME(); my $milter2 = &HeaderValidateMIME; # convenience =head1 DESCRIPTION This milter module rejects any message at the DATA stage that has one of the Content-Type: or MIME-Version: headers, but not the other. In the future, this module may enforce stricter MIME checks. =cut our @EXPORT = qw(&HeaderValidateMIME); sub HeaderValidateMIME { new Mail::Milter::Module::HeaderValidateMIME(@_); } sub envfrom_callback { shift; # $this my $ctx = shift; $ctx->setpriv({}); SMFIS_CONTINUE; } sub header_callback { shift; # $this my $ctx = shift; my $hname = lc(shift); my $priv = $ctx->getpriv(); if ($hname eq 'content-type' || $hname eq 'mime-version') { $priv->{$hname} = 1; } SMFIS_CONTINUE; } sub eoh_callback { shift; # $this my $ctx = shift; my $priv = $ctx->getpriv(); if (defined($priv->{'content-type'}) xor defined($priv->{'mime-version'})) { $ctx->setreply("554", "5.6.0", "Message is corrupt -- RFC2047: MIME-Version and Content-Type must be used together, or not at all"); 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.07/lib/Mail/Milter/Module/SPF.pm010064400000520000000000000246311041027070700171540ustar tvwheel# $Id: SPF.pm,v 1.3 2006/03/22 15:48:23 tvierling Exp $ # # Copyright (c) 2002-2006 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::SPF; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Mail::SPF::Query 1.996; use Sendmail::Milter 0.18; # get needed constants use Socket; use UNIVERSAL; our $VERSION = '0.01'; =pod =head1 NAME Mail::Milter::Module::SPF - milter to use Sender Policy Framework for accept/reject =head1 SYNOPSIS use Mail::Milter::Module::SPF; my $milter = new Mail::Milter::Module::SPF; my $milter2 = &SPF; # convenience =head1 WARNING This module is known to have major problems. It should NOT be used in a production environment at this time. =head1 DESCRIPTION This milter module rejects any mail from a sender (in the MAIL FROM part of the SMTP transaction, not in the From: header) if that sender's domain publishes a Sender Policy Framework (SPF) record denying access to the connection host. The pass/fail result from SPF is configurable as to whether mail will be accepted or rejected immediately. By default, this module will reject a sender whose SPF lookup returns "fail", and allow others to pass, setting a Received-SPF: header with the SPF lookup result. See the methods below for knobs tunable for different situations. This module requires the Mail::SPF::Query module (version 1.996 or later) to be installed in order to fetch the SPF record. Be sure to read BUGS at the bottom of this documentation for a list of currently unsupported features. =head1 METHODS =over 4 =cut our @EXPORT = qw(&SPF); sub SPF { new Mail::Milter::Module::SPF(@_); } =pod =item new() Creates a SPF object. There are no arguments to configure this module from the constructor; see the methods below for changeable options. =cut sub new ($) { my $this = Mail::Milter::Object::new(shift); $this->{_addheader} = 'Received-SPF'; $this->{_ignoresoftfail} = 1; $this->{_ignoretempfail} = 0; $this->{_message} = 'Mail from %M failed SPF check: %E'; $this->{_spfopts} = {}; $this->{_whitelistpass} = 0; $this; } =pod =item add_header(HEADERNAME) Tell this module to append a header on messages which are not rejected, indicating the SPF result value and a comment explaining the result. By default, this is enabled with the standard header name C. Note that this header is not appended if C is in effect, and a sender is whitelisted by a SPF "pass" result. This is because whitelisting skips all other mail processing, so this module cannot add headers at the end of processing. If HEADERNAME is undef, the header is disabled and will not be appended to any message. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub add_header ($$) { my $this = shift; my $headername = shift; $this->{_addheader} = $headername; $this; } =pod =item ignore_softfail(FLAG) If FLAG is 0, a SPF record resulting in "softfail" will be rejected as if the result were "fail". If FLAG is 1 (the default), a "softfail" is ignored, treated as if it returned "neutral". This method returns a reference to the object itself, allowing this method call to be chained. =cut sub ignore_softfail ($$) { my $this = shift; my $flag = shift; croak 'ignore_softfail: flag argument is undef' unless defined($flag); $this->{_ignoresoftfail} = $flag; $this; } =pod =item ignore_tempfail(FLAG) If FLAG is 0 (the default), a DNS lookup which fails the underlying DNS query (a SPF "error" result) 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 (and thus a SPF "none" result). 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 local_rules(RULETEXT) Add one or more SPF rules to try before a "-all" or "?all" record is encountered, in an attempt to validate the mail. This is useful for enumerating secondary MX servers or non-SRS-compliant forwarding systems which send mail to this host. The rules must be contained in a single string, separated by spaces. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub local_rules ($$) { my $this = shift; my $locals = shift; if (defined($this->{_spfopts}{local})) { $this->{_spfopts}{local} .= " $locals"; } else { $this->{_spfopts}{local} = $locals; } $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, and/or C<%E>, which will be replaced by the SPF explanatory URL and text. 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; } =pod =item whitelist_pass(FLAG) If FLAG is 0 (the default), a SPF "pass" result will be treated like any other non-failure result, allowing the message to pass through without other special handling. If FLAG is 1, a SPF "pass" result will cause this module to return SMFIS_ACCEPT, a value that is used by the accept_break(1) behavior of Mail::Milter::Chain, to ignore the results of other modules in the chain. Note that because SPF does not accept or reject until the MAIL FROM: stage, it may be necessary to embed a DeferToRCPT wrapper into the whitelisting chain. For example, use Mail::Milter::Chain; use Mail::Milter::Module::SPF; use Mail::Milter::Wrapper::DeferToRCPT; my $spf_whitelisted_chain = new Mail::Milter::Chain( &SPF->whitelist_pass(1), &DeferToRCPT(new Mail::Milter::Chain( $milter1, ... )) )->accept_break(1); This method returns a reference to the object itself, allowing this method call to be chained. =cut sub whitelist_pass ($$) { my $this = shift; my $flag = shift; croak 'whitelist_pass: flag argument is undef' unless defined($flag); $this->{_whitelistpass} = $flag; $this; } sub connect_callback { my $this = shift; my $ctx = shift; shift; # $hostname my $pack = shift; # XXX should handle IPv6 via getsymval parsing my $addr = eval { my @unpack = unpack_sockaddr_in($pack); $unpack[1]; }; return SMFIS_CONTINUE unless defined($addr); my $spfopts = {}; $ctx->setpriv({ _spfopts => $spfopts }); $spfopts->{helo} = 'UNKNOWN'; # in case MTA allows skipping HELO step $spfopts->{ip} = join('.', unpack('C4', $addr)); $spfopts->{myhostname} = $ctx->getsymval('j'); SMFIS_CONTINUE; } sub helo_callback { my $this = shift; my $ctx = shift; my $helo = shift; my $spfopts = $ctx->getpriv()->{_spfopts}; $spfopts->{helo} = $helo; SMFIS_CONTINUE; } sub envfrom_callback { my $this = shift; my $ctx = shift; my $from = shift; $from =~ s/^$//; return SMFIS_CONTINUE if ($from eq ''); # null <> sender my $data = $ctx->getpriv(); my $query = new Mail::SPF::Query( %{$this->{_spfopts}}, %{$data->{_spfopts}}, sender => $from ); if (defined($@) && $@ ne '') { warn "SPF query problem: $@"; return SMFIS_TEMPFAIL; } my ($result, $smtp_comment, $header_comment) = $query->result(); $data->{result} = $result; $data->{header_comment} = $header_comment; if ($result eq 'fail' || ($result eq 'softfail' && !$this->{_ignoresoftfail})) { my $msg = $this->{_message}; $msg =~ s/%M/$from/g; $msg =~ s/%E/$smtp_comment/g; $ctx->setreply('554', '5.7.1', $msg); return SMFIS_REJECT; } elsif ($result eq 'error' && !$this->{_ignoretempfail}) { my $domain = $from; $domain =~ s/^.*\@([^\@]+)$/$1/; $ctx->setreply('451', '4.7.0', "Temporary DNS error encountered while fetching SPF record for $domain"); return SMFIS_TEMPFAIL; } elsif ($result eq 'pass' && $this->{_whitelistpass}) { return SMFIS_ACCEPT; } SMFIS_CONTINUE; # don't whitelist a fallthrough } sub eom_callback { my $this = shift; my $ctx = shift; my $data = $ctx->getpriv(); $ctx->addheader($this->{_addheader}, ($data->{result}).' ('.($data->{header_comment}).')') if defined($this->{_addheader}); SMFIS_CONTINUE; } 1; __END__ =back =head1 BUGS Currently this module only handles IPv4 connecting hosts. IPv6 hosts pass through without any SPF handling. This module does not currently support the C form of the SPF query for special secondary-MX handling. Currently C must be used to set up SPF exceptions for those secondary MX hosts. The C and C special lookups are not yet supported. =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L, L the Sender Policy Framework Web site, http://spf.pobox.com/ =cut Mail-Milter-0.07/lib/Mail/Milter/Module/HeloRawLiteral.pm010064400000520000000000000055251001744466600214150ustar tvwheel# $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.07/lib/Mail/Milter/Module/MailDomainDNSBL.pm010064400000520000000000000207601041027070700213200ustar tvwheel# $Id: MailDomainDNSBL.pm,v 1.9 2006/03/22 15:48:23 tvierling Exp $ # # Copyright (c) 2002-2006 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.04'; =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. (This is known as a "RHSBL" check in some anti-spam lingo.) 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->{_checksupers} = 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 check_superdomains(NUM) If no match is returned by checking the domain name verbatim, recurse one level upward at a time and attempt the check again. If NUM is positive, the recursion will stop after NUM recursions; if negative, the recursion will stop when abs(NUM) domain levels have been reached. The default is 0, meaning that no recursion will be done. For example, when checking the domain name FOO.BAR.BAZ.COM, NUM=1 will also check BAR.BAZ.COM; NUM=-1 will check BAR.BAZ.COM, BAZ.COM, and COM. This method returns a reference to the object itself, allowing this method call to be chained. =cut sub check_superdomains ($$) { my $this = shift; my $flag = shift; $this->{_checksupers} = $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 $dnsbl = $this->{_dnsbl}; my $fdomain = $from; $fdomain =~ s/^[^\@]+\@//; my @domainparts = split(/\./, $fdomain); my $startmax = $this->{_checksupers}; $startmax += scalar(@domainparts) if ($startmax < 0); $startmax = 0 if ($startmax < 0); for (my $i = 0; $i <= $#domainparts && $i <= $startmax; ++$i) { my $fromdomain = join('.', @domainparts[$i..$#domainparts]); 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 next 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.07/lib/Mail/Milter/Module/MailDomainDotMX.pm010064400000520000000000000122271016013267700214550ustar tvwheel# $Id: MailDomainDotMX.pm,v 1.2 2004/12/15 22:07:59 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 Net::DNS; 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.07/lib/Mail/Milter/Module/AccessDB.pm010064400000520000000000000252441017502530000201270ustar tvwheel# $Id: AccessDB.pm,v 1.3 2004/12/29 04:39:35 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::AccessDB; use 5.006; use base Exporter; use base Mail::Milter::Object; use strict; use warnings; use Carp; use Net::DNS; # XXX should be optional (needed for MX: tagged check) use Sendmail::Milter 0.18; # get needed constants use Socket; use UNIVERSAL; our $VERSION = '0.01'; our $DEBUGLEVEL = 0; =pod =head1 NAME Mail::Milter::Module::AccessDB - emulator for Sendmail "access_db" in a milter =head1 SYNOPSIS use Mail::Milter::Module::AccessDB; my $milter = new Mail::Milter::Module::AccessDB(\%hashref); my $milter2 = &AccessDB(\%hashref); # convenience =head1 DESCRIPTION Sendmail's "access_db" is a powerful access restriction database tool, but it is limited only to data explicitly available through the SMTP session. This milter module allows rewriting to take place (such as through Mail::Milter::Wrapper::DecodeSRS) before applying the access rules. Not all access_db functionality is duplicated here; some is unimplemented, while some is Sendmail-internal only. See DATABASE FORMAT, below, for a list of supported tags and result codes in this module. NOTE: As of this version, this module might not be thread-safe. A future version of this module will share the hashref between threads and lock it properly. ESPECIALLY NOTE: This module is highly experimental, does not support all accessdb data types yet, and is not guaranteed to work at all. Feel free to try it out and to send comments to the author, but it is not yet recommended to use this module in a production setup. =head1 DATABASE FORMAT [XXX: TBD] =head1 METHODS =over 4 =cut our @EXPORT = qw(&AccessDB); sub AccessDB { new Mail::Milter::Module::AccessDB(@_); } =pod =item new(HASHREF) Create this milter using a provided hash reference. This may be a tied hash, such as to an already opened Sendmail-style database. Currently there is no support for automatically reopening databases, hence this one-shot constructor. (Sendmail does not support automatic reopening either, for that matter.) =cut sub new ($$) { my $this = Mail::Milter::Object::new(shift); my $hashref = shift; $this->{_ignoretempfail} = 0; $this->{_message} = '[%0] Access denied'; croak 'new AccessDB: no hashref supplied' unless UNIVERSAL::isa($hashref, 'HASH'); $this->{_db} = $hashref; $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<%0>, which will be replaced by the matching lookup key (not including type tag). 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 LookUpAddress ($$$) { my $this = shift; my $key = shift; my $tag = shift; my $db = $this->{_db}; my $rv; print STDERR "$$: LookUpAddress: $tag:$key\n" if ($DEBUGLEVEL > 1); # lookup with tag $rv = $db->{"$tag:$key"}; # lookup without tag $rv = $db->{$key} unless defined($rv); # found SKIP: return return undef if (defined($rv) && $rv eq 'SKIP'); # no match: remove last part $rv = $this->LookUpAddress($1, $tag) if (!defined($rv) && ($key =~ /^(.+)[:\.]+[^:\.]+$/)); # match: return result $rv; } sub LookUpDomain ($$$) { my $this = shift; my $key = shift; my $tag = shift; my $db = $this->{_db}; my $rv; print STDERR "$$: LookUpDomain: $tag:$key\n" if ($DEBUGLEVEL > 1); # lookup with tag (in front, no delimiter here) $rv = $db->{"$tag:$key"}; # lookup without tag? $rv = $db->{$key} unless defined($rv); # LOOKUPDOTDOMAIN # XXX apply this also to IP addresses? # currently it works the wrong way round for [1.2.3.4] if (!defined($rv) && ($key =~ /^[^\.]+(\..+)$/)) { $rv = $db->{"$tag:$1"}; $rv = $db->{$1} unless defined($rv); } # found SKIP: return return undef if (defined($rv) && $rv eq 'SKIP'); # not found: net return $this->LookUpDomain("[$1]", $tag) if (!defined($rv) && ($key =~ /^\[(.+)[:\.]+[^:\.]+\]$/)); # not found, but subdomain: try again return $this->LookUpDomain($1, $tag) if (!defined($rv) && ($key =~ /^[^\.]+\.(.+)$/)); # return $rv; } sub LookUpExact ($$$) { my $this = shift; my $key = shift; my $tag = shift; my $db = $this->{_db}; my $rv; print STDERR "$$: LookUpExact: $tag:$key\n" if ($DEBUGLEVEL > 1); $rv = $db->{"$tag:$key"}; $rv = $db->{$key} unless defined($rv); $rv; } sub LookUpFull ($$$) { my $this = shift; my $key = shift; my $tag = shift; my $db = $this->{_db}; my $rv; print STDERR "$$: LookUpFull: $tag:$key\n" if ($DEBUGLEVEL > 1); $rv = $db->{"$tag:$key"}; $rv = $db->{$key} unless defined($rv); if (!defined($rv) && ($key =~ /^(.+)\+[^\+]*\@(.+)$/)) { $rv = $db->{"$tag:$1+*\@$2"}; $rv = $db->{"$1+*\@$2"} unless defined($rv); $rv = $db->{"$tag:$1\@$2"} unless defined($rv); $rv = $db->{"$1\@$2"} unless defined($rv); } $rv; } sub LookUpUser ($$$) { my $this = shift; my $key = shift; # must end in @ just like in sendmail ruleset my $tag = shift; my $db = $this->{_db}; my $rv; print STDERR "$$: LookUpUser: $tag:$key\n" if ($DEBUGLEVEL > 1); $rv = $db->{"$tag:$key"}; $rv = $db->{$key} unless defined($rv); if (!defined($rv) && ($key =~ /^(.+)\+[^\+]*\@$/)) { $rv = $db->{"$tag:$1+*\@"}; $rv = $db->{"$1+*\@"} unless defined($rv); $rv = $db->{"$tag:$1\@"} unless defined($rv); $rv = $db->{"$1\@"} unless defined($rv); } $rv; } sub TranslateValue ($$$$) { my $this = shift; my $ctx = shift; my $key = shift; my $value = shift; $value = "ERROR:\"554 $this->{_message}\"" if ($value =~ /^REJECT\s*$/); $value =~ s/\s+$//; $value =~ s/\%0/$key/g; print STDERR "accessdb: $key: $value\n" if ($DEBUGLEVEL > 0); if ($value eq 'OK' || $value eq 'RELAY') { return SMFIS_CONTINUE; } elsif ($value =~ /^QUARANTINE:/) { # XXX not yet supported return SMFIS_CONTINUE; } elsif ($value =~ /^ERROR:([45]\.\d\.\d):"(([45])\d\d) (.*)"$/) { $ctx->setreply($2, $1, $4); return ($3 eq '5' ? SMFIS_REJECT : SMFIS_TEMPFAIL); } elsif ($value =~ /^(?:ERROR:)?"(([45])\d\d) (.*)"$/) { $ctx->setreply($1, substr($1, 0, 1).'.7.0', $3); return ($2 eq '5' ? SMFIS_REJECT : SMFIS_TEMPFAIL); } else { print STDERR "AccessDB: $key: unparseable result: $value\n"; } SMFIS_TEMPFAIL; } sub connect_callback { my $this = shift; my $ctx = shift; my $hostname = lc(shift); my $pack = shift; my $value; return $this->TranslateValue($ctx, $hostname, $value) if defined($value = $this->LookUpDomain($hostname, 'connect')); # First try IPv4 unpacking. my $addr = eval { my @unpack = unpack_sockaddr_in($pack); inet_ntoa($unpack[1]); }; $addr = eval { require Socket6; my @unpack = Socket6::unpack_sockaddr_in6($pack); Socket6::inet_ntop(&Socket6::AF_INET6, $unpack[1]); } unless defined($addr); if (defined($addr)) { return $this->TranslateValue($ctx, $addr, $value) if defined($value = $this->LookUpAddress($addr, 'connect')); } SMFIS_CONTINUE; } sub helo_callback { # XXX need something here SMFIS_CONTINUE; } sub envfrom_callback { my $this = shift; my $ctx = shift; my $from = lc(shift); my $value; print STDERR "$$: envfrom: $from\n" if ($DEBUGLEVEL > 1); $from =~ s/^<(.*)>$/$1/; # remove angle brackets return $this->TranslateValue($ctx, $from, $value) if defined($value = $this->LookUpFull($from, 'from')); $from =~ /^([^\@]+)(?:|\@([^\@]+))$/; my $user = $1; my $domain = $2; return $this->TranslateValue($ctx, $from, $value) if defined($value = $this->LookUpUser("$user\@", 'from')); return $this->TranslateValue($ctx, $from, $value) if (defined($domain) && defined($value = $this->LookUpDomain($domain, 'from'))); # OK, no direct match. Get the MX record(s) for the domain and try those. if (defined($domain)) { my $res = new Net::DNS::Resolver; my $query = $res->query($domain, 'MX'); if (defined($query)) { foreach my $rr (grep { $_->type eq 'MX' } $query->answer) { my $mx = $rr->exchange; next if ($mx eq ''); # want to reject? Use MailDomainDotMX. print STDERR "$$: envfrom: MX:$mx\n" if ($DEBUGLEVEL > 2); return $this->TranslateValue($ctx, $from, $value) if (defined($domain) && defined($value = $this->LookUpDomain($mx, 'mx'))); } } elsif (!$this->{_ignoretempfail}) { $ctx->setreply('451', '4.7.1', "Temporary failure in DNS lookup for $domain"); return SMFIS_TEMPFAIL; } } SMFIS_CONTINUE; } sub envrcpt_callback { # XXX need something here SMFIS_CONTINUE; } 1; __END__ =back =head1 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.07/lib/Mail/Milter/Module/ConnectDNSBL.pm010064400000520000000000000172221003755320400206770ustar tvwheel# $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.07/lib/Mail/Milter/Module/HeloRegex.pm010064400000520000000000000074071003652321000204020ustar tvwheel# $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.07/lib/Mail/Milter/ContextWrapper.pm010064400000520000000000000125411001744466600202730ustar tvwheel# $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.07/lib/Mail/Milter/Object.pm010064400000520000000000000076141001744466600165210ustar tvwheel# $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.07/lib/Mail/Milter/Wrapper004075500000520000000000000000001041027110700162725ustar tvwheelMail-Milter-0.07/lib/Mail/Milter/Wrapper/RejectMsgEditor.pm010064400000520000000000000074161001744466600217650ustar tvwheel# $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.07/lib/Mail/Milter/Wrapper/DeferToRCPT.pm010064400000520000000000000127411016035423100207340ustar tvwheel# $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.07/lib/Mail/Milter/Wrapper/DecodeSRS.pm010064400000520000000000000104201016007423300204570ustar tvwheel# $Id: DecodeSRS.pm,v 1.2 2004/12/15 17:47:07 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.02'; =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') { my $addr = $_[1]; # Mail::SRS::Guarded SRS1: strip to Mail::SRS::Guarded SRS0 $addr =~ s/^tv@duh.orgE Etv@pobox.comE =head1 SEE ALSO L =cut Mail-Milter-0.07/lib/Mail/Milter/Chain.pm010064400000520000000000000173741004223561300163250ustar tvwheel# $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.07/lib/Mail/Milter.pm010064400000520000000000000052541041027070700152770ustar tvwheel# $Id: Milter.pm,v 1.29 2006/03/22 15:48:23 tvierling Exp $ # # Copyright (c) 2002-2006 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.07'; # 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: * AccessDB * ConnectASNBL * ConnectDNSBL * ConnectMatchesHostname * ConnectRegex * HeaderFromMissing * HeaderRegex * HeaderValidateMIME * HeloRawLiteral * HeloRegex * HeloUnqualified * MailBogusNull * MailDomainDNSBL * MailDomainDotMX * SPF * VirusBounceSpew the Mail::Milter::Wrapper::* manpages -- these include: * DecodeSRS * DeferToRCPT * RejectMsgEditor =cut Mail-Milter-0.07/examples004075500000520000000000000000001041027110700136045ustar tvwheelMail-Milter-0.07/examples/duh.org004075500000520000000000000000001041027110700151525ustar tvwheelMail-Milter-0.07/examples/duh.org/milter.pl010075500000520000000000000303311041027014300170610ustar tvwheel#!/usr/local/bin/perl -w -I../../lib -I/SRC/sf/pmilter/pmilter/lib # $Id: milter.pl,v 1.30 2006/03/22 15:42:27 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 DB_File; use Fcntl; use Carp qw{verbose}; use Mail::Milter::Chain; use Mail::Milter::Module::AccessDB; 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::HeaderValidateMIME; use Mail::Milter::Module::HeloRawLiteral; use Mail::Milter::Module::HeloRegex; use Mail::Milter::Module::HeloUnqualified; use Mail::Milter::Module::MailBogusNull; use Mail::Milter::Module::MailDomainDNSBL 0.04; use Mail::Milter::Module::MailDomainDotMX; use Mail::Milter::Module::SPF; use Mail::Milter::Module::VirusBounceSpew; use Mail::Milter::Wrapper::DecodeSRS; use Mail::Milter::Wrapper::DeferToRCPT; use Mail::Milter::Wrapper::RejectMsgEditor; use Sendmail::Milter 0.18; use Socket; # temporary flag to turn on 6to4-to-IPv4 translation use Sendmail::PMilter::Context; $Sendmail::PMilter::Context::Map6to4 = 1; # # 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. # ##### External data # # So let's try pretending we know how to do access_db here. # Unfortunately there isn't yet auto-reopen logic, so my script # used to regenerate access.db also restarts this milter (for now). # $Mail::Milter::Module::AccessDB::DEBUGLEVEL = 0; my %access; tie(%access, 'DB_File', '/etc/mail/access_milter.db', O_RDONLY, 0644, $DB_BTREE) || die "can't open accessdb: $!"; my $access_db_full = &AccessDB(\%access)->ignore_tempfail(1); # here's an instance to wrap in DecodeSRS, so remove "connect" and "helo" my $access_db_noconnect = &AccessDB(\%access)->ignore_tempfail(1); delete $access_db_noconnect->{connect}; delete $access_db_noconnect->{helo}; ##### 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 $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|SEXUALLY-EXPLICIT) ?:', # current bad eggs '^Subject:\s+YUKOS OIL\s*$', # Suresh Ramasubramanian claimed this is OK '^Received:.*\.mr\.outblaze\.com', )->set_message( 'NO UCE means NO SPAM (no kidding!)' ); ##### 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$', '^UNKNOWN-[\d-]+\.yahoo\.com$', '64.201.182.287', # hpeyerl@netbsd.org (20051005) )->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. # # on parole: CO JO MY PK TH TW my @ccs = qw(AR BR CL CN KR MX NG SG TM); 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), ); 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('pdl.spamhosts.duh.org', '127.0.0.3')->set_message($dynamic_msg), &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('sbl-xbl.spamhaus.org'), &ConnectDNSBL('combined.njabl.org', '127.0.0.4'), &ConnectDNSBL('l1.spews.dnsbl.sorbs.net'), # &ConnectDNSBL('spews.blackholes.us'), # alternate for SPEWS ); my @rhsbls = ( &MailDomainDNSBL('multi.surbl.org', sub { if (inet_ntoa(shift) =~ /^127\.0\.0\.(\d+)$/) { # ws + ob + ab + jp.surbl.org return ($1 & (4|16|32|64)); } undef; })->check_superdomains(-2), &MailDomainDNSBL('multi.uribl.com', '127.0.0.2')->check_superdomains(-2), &MailDomainDNSBL('rhsbl.ahbl.org'), ); ##### Sender Policy Framework (http://spf.pobox.com/) # # This looks a little strange at first, but what it's actually doing # is providing a chain of checks, sarting with SPF, but which will # discard the results of all other checks if the SPF "pass"es. # my $spf_whitelisted_chain = new Mail::Milter::Chain( # &SPF ->local_rules('ip4:216.240.140.0/26 mx:hostofhosts.com') # ->local_rules('include:sourceforge.net') # ->set_message('SPF check for %M failed') # ->whitelist_pass(1), &DeferToRCPT(new Mail::Milter::Chain( $dynamic_rdns, @dynamic_dnsbls, @country_dnsbls, # require('greylist.pl'), )) )->accept_break(1); ##### Inner chain: main collection of checks # # As well as the more complicated checks above, I've added some # simpler ones directly in-line below. # # This chain is needed both normally and after SRS decoding: my $envfrom_checks = new Mail::Milter::Chain( &MailDomainDotMX->ignore_tempfail(1), @rhsbls, ); my $inner_chain = new Mail::Milter::Chain( $access_db_full, $spf_whitelisted_chain, @relayinput_dnsbls, @generic_dnsbls, &HeloUnqualified, &HeloRawLiteral, &DecodeSRS($access_db_noconnect), &DecodeSRS($envfrom_checks), $envfrom_checks, &HeaderFromMissing, &HeaderValidateMIME, $spam_headers, &MailBogusNull, &VirusBounceSpew, { connect => sub { my $ctx = shift; my $host = shift; $ctx->set_key(host => $host); # temporarily forgive IPv6 rDNS failures if ($host =~ /^\[/ && $host !~ /:/) { $ctx->setreply(451, '4.7.0', "Cannot find the reverse DNS for $host; see http://postmaster.info.aol.com/info/rdns.html for more information, or e-mail postmaster\@duh.org for assistance."); return SMFIS_TEMPFAIL; } SMFIS_CONTINUE; }, helo => sub { my $ctx = shift; my $helo = shift; # current zombieware issue: 8 hex digits if ($helo =~ /^\x{8}$/) { $ctx->setreply(554, '5.7.0', "Bad HELO value '" + $helo + "'"); return SMFIS_REJECT; } SMFIS_CONTINUE; }, envfrom => sub { my $ctx = shift; my $envfrom = shift; my $fromattrs = +{ map { split(/=/, lc) } @_ }; $ctx->set_key(envfrom => $envfrom); $ctx->set_key(fromattrs => $fromattrs); SMFIS_CONTINUE; }, envrcpt => sub { my $ctx = shift; my $envrcpt = shift; my $envfrom = $ctx->get_key('envfrom'); my $fromattrs = $ctx->get_key('fromattrs'); my $host = $ctx->get_key('host'); if ($host !~ /\.rollernet\.us/ && $envrcpt =~ /\@(duh\.org|smargon\.net)/) { # for domains we know to have a secondary MX, # kick back to the secondary for known high-bw mail: if (defined($fromattrs->{size}) && $fromattrs->{size} > 150000) { $ctx->setreply(452, '4.3.0', "Bandwidth load is currently too high for this message; please try my secondary MXs"); return SMFIS_TEMPFAIL; } } SMFIS_CONTINUE; }, }, ); ##### 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 = ( 'kasserver\.com$', '216.168.47.180' ); 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; # }, # }, # always allow anything to abuse/postmaster { 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.07/examples/duh.org/restart.sh010075500000520000000000000003521010347471400172610ustar tvwheel#!/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.07/Changes010064400000520000000000000051311041027022300133330ustar tvwheel$Id: Changes,v 1.34 2006/03/22 15:43:15 tvierling Exp $ Revision history for Perl extension Mail::Milter. 0.07 Wed Mar 22 15:45:00 2006 UTC - added Mail::Milter::Module::AccessDB - Mail::Milter::Module::MailDomainDotMX needed a "use Net::DNS" - improved Mail::Milter::Wrapper::DecodeSRS parsing to understand Mail::SRS::Guarded munging where the original localpart already contained an equals (=) character - added Mail::Milter::Module::SPF - added Mail::Milter::Module::MailFakeNull - added Mail::Milter::Module::HeaderValidateMIME - added method check_superdomains() to Mail::Milter::Module::MailDomainDNSBL, allowing use of e.g. surbl.org blacklist with MAIL FROM:<> addresses 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.07/MANIFEST010064400000520000000000000020511041027025300131720ustar tvwheelChanges 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/AccessDB.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/HeaderValidateMIME.pm lib/Mail/Milter/Module/HeloRawLiteral.pm lib/Mail/Milter/Module/HeloRegex.pm lib/Mail/Milter/Module/HeloUnqualified.pm lib/Mail/Milter/Module/MailBogusNull.pm lib/Mail/Milter/Module/MailDomainDNSBL.pm lib/Mail/Milter/Module/MailDomainDotMX.pm lib/Mail/Milter/Module/SPF.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.07/META.yml010064400000520000000000000005321041027110600133120ustar tvwheel# 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.07 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.07/t004075500000520000000000000000001041027110700122315ustar tvwheelMail-Milter-0.07/t/01_chain.t010064400000520000000000000023431002711050500140540ustar tvwheel# $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.07/t/00_milter.t010064400000520000000000000011141001735377500143010ustar tvwheel# $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.07/t/02_object.t010064400000520000000000000052501001735377500142620ustar tvwheel# $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.07/Makefile.PL010064400000520000000000000005161001645371700140310ustar tvwheel# $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', ); Mail-Milter-0.07/README010064400000520000000000000063541041027073400127370ustar tvwheelMail::Milter version 0.07 ========================= $Id: README,v 1.13 2006/03/22 15:48:44 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-2006 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.