#!/usr/bin/perl
#
# Copyright (c) 2005-2006 Robert Felber
# (Autohaus Erich Kuttendreier, Munich, http://www.kuttendreier.de)
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
#
# A copy of the GPL can be found at http://www.gnu.org/licenses/gpl.txt
#
# Parts of code based on postfix-policyd-spf by Meng Wen Wong, version 1.06,
# see http://spf.pobox.com/
#
# AUTHOR: r.felber@ek-muc.de
# DATE: Thu May 10 11:11:50 CEST 2007
# NAME: policyd-weight
# VERSION: 0.1.14 beta-5
# URL: http://www.policyd-weight.org/
# ----------------------------------------------------------
# minimal documentation
# ----------------------------------------------------------
#
# Weighted Postfix SMTPD policy server.
#
# This program assumes you have read Postfix'
# README_FILES/SMTPD_POLICY_README
# If not, head to:
# http://www.postfix.org/SMTPD_POLICY_README.html
#
#
#
# Logging is sent to syslogd.
#
# ----------------------------------------------------------------------
# To run this in init mode:
#
# % /path/to/policyd-weight start
#
# /etc/postfix/main.cf:
#
# smtpd_recipient_restrictions =
# ...
# reject_unauth_destination
# ...
# check_policy_service inet:127.0.0.1:12525
#
#
# NOTE: specify check_policy_service AFTER reject_unauth_destination
# or else your system can become an open relay.
# begin
use strict;
use Fcntl;
use Sys::Syslog qw(:DEFAULT setlogsock);
use Net::DNS;
use Net::DNS::Packet qw(dn_expand);
use IO::Socket::INET;
use IO::Socket::UNIX;
use IO::Select;
use Config;
use POSIX;
use vars qw($csock $s $tcp_socket $sock $new_sock $old_mtime);
our $VERSION = "0.1.14 beta-5";
our $CVERSION = 5; # cache interface version
our $CMD_DEBUG = 0; # -d switch
our $KILL; # -k switch
our $STATS; # -s switch
our $DAEMONIZE; # start action
our $RESTART; # restart action
our $RELOAD; # reload action
our $STOP; # stop action
my $run_action; # marker whether any action has been used
my $conf; # path to config file
my $arg_iter;
my $ignore;
for(@ARGV)
{
$arg_iter++;
next if ($_ eq $ignore);
$ignore = '';
if($_ eq "-d")
{
$^W = 1;
$CMD_DEBUG = 1;
}
elsif($_ eq '-f')
{
if( -f $ARGV[$arg_iter])
{
$conf = $ARGV[$arg_iter];
$ignore = $ARGV[$arg_iter];
next;
}
else
{
print "configfile ".$ARGV[$arg_iter]." doesn't exist\n";
exit "-1";
}
}
elsif($_ eq "-k")
{
$KILL = 1;
}
elsif($_ eq "-s")
{
$STATS = 1;
}
elsif($_ =~ /-[-]*h/)
{
usage();
}
elsif($_ =~ /-[-]*v/)
{
my $net_dns_ver = Net::DNS->version;
my $os = `uname -rs`;
print <<EOF;
policyd-weight version: $VERSION, CacheVer: $CVERSION
Perl version: $]
Net::DNS version: $net_dns_ver
OS: $os
EOF
exit;
}
elsif($_ eq "start")
{
usage() if ($run_action);
if(!($< == 0 || $CMD_DEBUG))
{
die "You must be root in order to use \"start\"!\n";
}
$DAEMONIZE = 1;
$run_action = 1;
}
elsif($_ eq "defaults")
{
my $del;
open(POLW, "<$0") || die "open: $0: $!\n";
print "# ----------------------------------------------------------------\n";
print "# policyd-weight configuration (defaults) Version $VERSION \n";
print "# ----------------------------------------------------------------\n";
while (<POLW>)
{
if (/^#--BEGIN_CONFDEF/)
{
$del = 1;
next;
}
if ($del)
{
if (/^#--END_CONFDEF/)
{
last;
}
else
{
$_ =~ s/^my / /;
print $_;
}
}
}
close(POLW);
exit;
}
elsif($_ eq "restart")
{
usage() if ($run_action);
if(!($< == 0 || $CMD_DEBUG))
{
die "You must be root in order to use \"restart\"!\n";
}
$STOP = 1;
$RESTART = 1;
$DAEMONIZE = 1;
$run_action = 1;
}
elsif($_ eq "stop")
{
usage() if ($run_action);
if(!($< == 0 || $CMD_DEBUG))
{
die "You must be root in order to use \"stop\"!\n";
}
$DAEMONIZE = 1;
$STOP = 1;
$run_action = 1;
}
elsif($_ eq "reload")
{
usage() if ($run_action);
if(!($< == 0 || $CMD_DEBUG))
{
die "You must be root in order to use \"reload\"!\n";
}
$RELOAD = 1;
}
else
{
print "policyd-weight: unknown option $_\n";
usage(1);
}
}
sub usage
{
my $ret = shift;
print <<EOF;
Usage: policyd-weight [-option -option2 <arg>] [stop|start|restart|defaults]
Args in [ ] are optional.
Options
-d Debug, don't daemonize, log to STDOUT
-f /path/to/file Specify a configuration file
-h This help
-k Kill cache instance
-s Show cache entries and exit. With -d show debug
cache entries
-v Show version and exit
Actions
stop Stops the policyd-weight daemon, add -k to also
Stop the cache. In addition with -d -k it stops
the debug cache.
start Starts the policyd-weight daemon. Add -d to start a
debug session in foregorund.
restart Restarts policyd-weight. Together with -d it
restarts a debug session in foreground.
reload Reload the configuration file
defaults Output default configuration
If no action is given it waits for data on STDIN.
WARNING: do NOT use options or actions in master.cf!
EOF
exit($ret);
}
if($CMD_DEBUG)
{
$^W = 1;
print "policyd-weight version: ".$VERSION.", CacheVer: $CVERSION\nSystem: ";
system("uname -a");
print "Perl version: ".$]."\n";
}
#
# store signal-name to number conversions for better accessibility
#
our %sig_list;
my $i;
foreach(split(' ', $Config{sig_name}))
{
$sig_list{$_} = $i++;
}
#
# Print Module Versions if -d requested
#
if($CMD_DEBUG)
{
print "Net::DNS version: " . Net::DNS->version . "\n";
}
# don't let warnings confuse the SMTP, feed die() lines to syslog
$SIG{__DIE__} = sub {
mylog(warning=>"err: @_");
};
# ----------------------------------------------------------
# configuration (defaults)
# ----------------------------------------------------------
# don't make changes here, instead use/create /etc/policyd-weight.conf
# NOTE: use perl syntax inclusive `;' in configuration files.
#
#--BEGIN_CONFDEF
my $DEBUG = 0; # 1 or 0 - don't comment
my $REJECTMSG = "550 Mail appeared to be SPAM or forged. Ask your Mail/DNS-Administrator to correct HELO and DNS MX settings or to get removed from DNSBLs";
my $REJECTLEVEL = 1; # Mails with scores which exceed this
# REJECTLEVEL will be rejected
my $DEFER_STRING = 'IN_SPAMCOP= BOGUS_MX=';
# A space separated case-sensitive list of
# strings on which if found in the $RET
# logging-string policyd-weight changes
# its action to $DEFER_ACTION in case
# of rejects.
# USE WITH CAUTION!
# DEFAULT: "IN_SPAMCOP= BOGUS_MX="
my $DEFER_ACTION = '450'; # Possible values: DEFER_IF_PERMIT,
# DEFER_IF_REJECT,
# 4xx response codes. See also access(5)
# DEFAULT: 450
my $DEFER_LEVEL = 5; # DEFER mail only up to this level
# scores greater than DEFER_LEVEL will be
# rejected
# DEFAULT: 5
my $DNSERRMSG = '450 No DNS entries for your MTA, HELO and Domain. Contact YOUR administrator';
my $dnsbl_checks_only = 0; # 1: ON, 0: OFF (default)
my $LOG_BAD_RBL_ONLY = 1; # 1: ON (default), 0: OFF
## DNSBL settings
my @dnsbl_score = (
# HOST, HIT SCORE, MISS SCORE, LOG NAME
'pbl.spamhaus.org', 3.25, 0, 'DYN_PBL_SPAMHAUS',
'sbl-xbl.spamhaus.org', 4.35, -1.5, 'SBL_XBL_SPAMHAUS',
'bl.spamcop.net', 3.75, -1.5, 'SPAMCOP',
'dnsbl.njabl.org', 4.25, -1.5, 'BL_NJABL',
'list.dsbl.org', 4.35, 0, 'DSBL_ORG',
'ix.dnsbl.manitu.net', 4.35, 0, 'IX_MANITU'
);
my $MAXDNSBLHITS = 2; # If Client IP is listed in MORE
# DNSBLS than this var, it gets
# REJECTed immediately
my $MAXDNSBLSCORE = 8; # alternatively, if the score of
# DNSBLs is ABOVE this
# level, reject immediately
my $MAXDNSBLMSG = '550 Your MTA is listed in too many DNSBLs';
## RHSBL settings
my @rhsbl_score = (
'multi.surbl.org', 4, 0, 'SURBL',
'rhsbl.ahbl.org', 4, 0, 'AHBL',
'dsn.rfc-ignorant.org', 3.5, 0, 'DSN_RFCI',
'postmaster.rfc-ignorant.org', 0.1, 0, 'PM_RFCI',
'abuse.rfc-ignorant.org', 0.1, 0, 'ABUSE_RFCI'
);
my $BL_ERROR_SKIP = 2; # skip a RBL if this RBL had this many continuous
# errors
my $BL_SKIP_RELEASE = 10; # skip a RBL for that many times
## cache stuff
my $LOCKPATH = '/tmp/.policyd-weight/'; # must be a directory (add
# trailing slash)
my $SPATH = $LOCKPATH.'/polw.sock'; # socket path for the cache
# daemon.
my $MAXIDLECACHE = 60; # how many seconds the cache may be idle
# before starting maintenance routines
# NOTE: standard maintenance jobs happen
# regardless of this setting.
my $MAINTENANCE_LEVEL = 5; # after this number of requests do following
# maintenance jobs:
# checking for config changes
# negative (i.e. SPAM) result cache settings ##################################
my $CACHESIZE = 2000; # set to 0 to disable caching for spam results.
# To this level the cache will be cleaned.
my $CACHEMAXSIZE = 4000; # at this number of entries cleanup takes place
my $CACHEREJECTMSG = '550 temporarily blocked because of previous errors';
my $NTTL = 1; # after NTTL retries the cache entry is deleted
my $NTIME = 30; # client MUST NOT retry within this seconds in order
# to decrease TTL counter
# positve (i.,e. HAM) result cache settings ###################################
my $POSCACHESIZE = 1000; # set to 0 to disable caching of HAM. To this number
# of entries the cache will be cleaned
my $POSCACHEMAXSIZE = 2000; # at this number of entries cleanup takes place
my $POSCACHEMSG = 'using cached result';
my $PTTL = 60; # after PTTL requests the HAM entry must
# succeed one time the RBL checks again
my $PTIME = '3h'; # after $PTIME in HAM Cache the client
# must pass one time the RBL checks again.
# Values must be nonfractal. Accepted
# time-units: s, m, h, d
my $TEMP_PTIME = '1d'; # The client must pass this time the RBL
# checks in order to be listed as hard-HAM
# After this time the client will pass
# immediately for PTTL within PTIME
## DNS settings
my $DNS_RETRIES = 2; # Retries for ONE DNS-Lookup
my $DNS_RETRY_IVAL = 2; # Retry-interval for ONE DNS-Lookup
my $MAXDNSERR = 3; # max error count for unresponded queries
# in a complete policy query
my $MAXDNSERRMSG = 'passed - too many local DNS-errors';
my $PUDP = 0; # persistent udp connection for DNS queries.
# broken in Net::DNS version 0.51. Works with
# Net::DNS 0.53; DEFAULT: off
my $USE_NET_DNS = 0; # Force the usage of Net::DNS for RBL lookups.
# Normally policyd-weight tries to use a faster
# RBL lookup routine instead of Net::DNS
my $IPC_TIMEOUT = 2; # timeout for receiving from cache instance
# scores for checks, WARNING: they may manipulate eachother
# or be factors for other scores.
# HIT score, MISS Score
my @client_ip_eq_helo_score = (1.5, -1.25 );
my @helo_score = (1.5, -2 );
my @helo_from_mx_eq_ip_score = (1.5, -3.1 );
my @helo_numeric_score = (1.5, 0 );
my @from_match_regex_verified_helo = (1, -2 );
my @from_match_regex_unverified_helo = (1.6, -1.5 );
my @from_match_regex_failed_helo = (2.5, 0 );
my @helo_seems_dialup = (1.5, 0 );
my @failed_helo_seems_dialup = (2, 0 );
my @helo_ip_in_client_subnet = (0, -1.2 );
my @helo_ip_in_cl16_subnet = (0, -0.41 );
my @client_seems_dialup_score = (3.75, 0 );
my @from_multiparted = (1.09, 0 );
my @from_anon = (1.17, 0 );
my @bogus_mx_score = (2.1, 0 );
my @random_sender_score = (0.25, 0 );
my @rhsbl_penalty_score = (3.1, 0 );
my @enforce_dyndns_score = (3, 0 );
my $VERBOSE = 0;
my $ADD_X_HEADER = 1; # Switch on or off an additional
# X-policyd-weight: header
# DEFAULT: on
my $DEFAULT_RESPONSE = 'DUNNO default'; # Fallback response in case
# the weighted check didn't
# return any response (should never
# appear).
#
# Syslogging options for verbose mode and for fatal errors.
# NOTE: comment out the $syslog_socktype line if syslogging does not
# work on your system.
#
my $syslog_socktype = 'unix'; # inet, unix, stream, console
my $syslog_facility = "mail";
my $syslog_options = "pid";
my $syslog_priority = "info";
my $syslog_ident = "postfix/policyd-weight";
#
# Process Options
#
my $USER = "polw"; # User must be a username, no UID
my $GROUP = ""; # specify GROUP if necessary
# DEFAULT: empty, will be initialized as
# $USER
my $MAX_PROC = 50; # Upper limit if child processes
my $MIN_PROC = 3; # keep that minimum processes alive
my $TCP_PORT = 12525; # The TCP port on which policyd-weight
# listens for policy requests from postfix
my $BIND_ADDRESS = '127.0.0.1'; # IP-Address on which policyd-weight will
# listen for requests.
# You may only list ONE IP here, if you want
# to listen on all IPs you need to say 'all'
# here. Default is '127.0.0.1'.
# You need to restart policyd-weight if you
# change this.
my $SOMAXCONN = 1024; # Maximum of client connections
# policyd-weight accepts
# Default: 1024
my $CHILDIDLE = 240; # how many seconds a child may be idle before
# it dies.
my $PIDFILE = "/var/run/policyd-weight.pid";
#--END_CONFDEF
$0 = "policyd-weight (master)";
my %cache;
my %poscache;
my $my_PTIME;
my $my_TEMP_PTIME;
if(!($conf))
{
if( -f "/etc/policyd-weight.conf")
{
$conf = "/etc/policyd-weight.conf";
}
elsif( -f "/etc/postfix/policyd-weight.cf")
{
$conf = "/etc/postfix/policyd-weight.cf";
}
elsif( -f "/usr/local/etc/policyd-weight.conf")
{
$conf = "/usr/local/etc/policyd-weight.conf";
}
elsif( -f "policyd-weight.conf")
{
$conf = "policyd-weight.conf";
}
}
my $conf_err;
my $conf_str;
our $old_mtime;
if($conf ne "")
{
if(sprintf("%04o",(stat($conf))[2]) !~ /(7|6|3|2)$/)
{
if(open(CONF, $conf))
{
read(CONF,$conf_str,-s CONF);
close(CONF);
#XXX taint $conf_str as $< enables taint mode
($conf_str) = $conf_str =~ m/(.*)/s;
eval $conf_str;
if($@)
{
$conf_err = "syntax error in file $conf: ".$@;
}
else
{
$old_mtime = (stat($conf))[9];
}
}
else
{
$conf_err = "could not open $conf: $!";
}
}
else
{
$conf_err = "$conf is world-writeable!";
}
}
else
{
$conf = "default settings"; # don't change! required by cache maintenance
}
our $STAYALIVE;
# set group to user if no group has been defined
$GROUP = $USER unless $GROUP;
if($CMD_DEBUG == 1)
{
$DEBUG = 1;
$conf_str =~ s/\#.*?(\n)/$1/gs;
$conf_str =~ s/\n+/\n/g;
print "config: $conf\n".$conf_str."\n";
$SPATH .= ".debug";
# chose /tmp for debug pidfiles only if user is not root
# if root would store debug pids also in /tmp we would be
# open to race attacks
if($< != 0)
{
$PIDFILE = "/tmp/policyd-weight.pid.debug";
}
else
{
$PIDFILE .= ".debug";
}
print "debug: using port ".++$TCP_PORT."\n";
print "debug: USER: $USER\n";
print "debug: GROUP: $GROUP\n";
print "debug: issuing user: ".getpwuid($<)."\n";
print "debug: issuing group: ".getpwuid($()."\n";
}
$conf_str = "";
# send HUP to kids if $RELOAD
if($RELOAD)
{
local $SIG{HUP} = 'IGNORE';
open(PF, $PIDFILE) or die "Couldn't open $PIDFILE: $!";
my $pid = <PF>;
close(PF);
if(!($pid > 0)) { die "pid $pid seems to be wrong" };
print "sending ".-$sig_list{HUP}." to $pid\n";
kill (-$sig_list{HUP}, $pid) or die "err: $!";
exit;
}
# ----------------------------------------------------------
# initialization
# ----------------------------------------------------------
#
# This process runs as a daemon, so it can't log to a terminal. Use
# syslog so that people can actually see our messages.
#
if($CMD_DEBUG != 1)
{
setlogsock($syslog_socktype) or die
"setlogsock: $syslog_socktype: $!. If you are on Solaris you might want to set \$syslog_socktype = 'stream';";
openlog($syslog_ident, $syslog_options, $syslog_facility) or die "openlog: $!. If you are on Solaris you might want to set \$syslog_socktype = 'stream';";
}
# re-arrange signal handlers
$SIG{__DIE__} = sub {
die @_ if index($_[0], 'ETIMEOUT') == 0;
mylog(warning=>"err: init: @_");
unlink $PIDFILE unless $STAYALIVE;
};
$SIG{'TERM'} = sub { unlink $PIDFILE unless $STAYALIVE; exit; };
$SIG{'QUIT'} = sub { unlink $PIDFILE unless $STAYALIVE; exit; };
$SIG{'HUP'} = 'IGNORE';
#
# Log an error and abort.
#
sub fatal_exit {
mylog(warning => "fatal_exit: @_");
die "fatal: @_";
}
#
# Unbuffer standard output.
#
select((select(STDOUT), $| = 1)[0]);
if($VERBOSE == 1)
{
mylog(debug=>"startup: using $conf");
}
my $RETANSW;
if($ADD_X_HEADER == 1)
{
$RETANSW = "PREPEND X-policyd-weight:";
}
else
{
$RETANSW = "DUNNO ";
}
if($conf_err)
{
mylog(warning=>"conf-err: ".$conf_err);
mylog(warning=>"conf-err: falling back to builtin defaults");
$RETANSW = $RETANSW." using builtin defaults due to config-error";
}
our $res=Net::DNS::Resolver->new;
$res->retrans($DNS_RETRY_IVAL) unless $DNS_RETRY_IVAL eq "";
$res->retry ($DNS_RETRIES) unless $DNS_RETRIES eq "";
$res->debug (1) if ($CMD_DEBUG == 1);
# watch the version string, I'm afraid that they change to x.x.x notation
if(Net::DNS->version() >= 0.50)
{
$res->force_v4(1); # force ipv4 usage, autodetection is broken till
# Net::DNS 0.53
}
else
{
$res->igntc(1); # ignore truncated packets if Net-DNS version is
# lower than 0.50
}
# keep udp socket open, don't waste time for socket creation.
# works with Net::DNS 0.53
$res->persistent_udp(1) if $PUDP == 1;
our %RTYPES = ( 'A' => 1, 'TXT' => 16 ); # see RFC 1035
our $s;
if($res)
{
my $ns = (($res->nameserver)[0]);
if(!($s = IO::Socket::INET->new(
PeerAddr => $ns,
PeerPort => '53',
Proto => 'udp'
)
))
{
mylog(warning=>"could not open RBL Lookup Socket to $ns: $@ $!");
$USE_NET_DNS = 1;
}
}
if($KILL)
{
if((-S $SPATH) && ($csock = IO::Socket::UNIX->new($SPATH)))
{
cache_query("kill");
$csock->close if ($csock && $csock->connected);
unlink $SPATH;
}
if(-S $SPATH)
{
mylog(warning=>"warning: -k action but $SPATH still exists, deleting it");
print STDERR "warning: -k action but $SPATH still exists, deleting it\n";
unlink $SPATH or die $!;
}
exit unless $STOP or $DAEMONIZE;
}
if($STATS)
{
print "*** querying cache for content stats:\n";
cache_query("stats");
exit;
}
# ----------------------------------------------------------
# main
# ----------------------------------------------------------
#
# Receive a bunch of attributes, evaluate the policy, send the result.
#
our $accepted = "UNDEF";
our $blocked = "UNDEF";
our $my_REJECTMSG = $REJECTMSG;
our %bl_err;
our $skip_rel;
my %attr;
if(!($DAEMONIZE))
{
while (<STDIN>)
{
my $string = $_;
my $action = parse_input($string);
if($action)
{
print STDOUT $action;
%attr = ();
}
}
}
else
{
##############################################################################
#
# DAEMON
#
##############################################################################
if($STOP && (!(-f $PIDFILE)))
{
print STDERR "No pidfile, expected it at $PIDFILE!\n";
exit 1;
}
if( -f $PIDFILE)
{
open(PF, $PIDFILE) || die $!;
my $oldpid = <PF>;
close(PF);
if($STOP && $oldpid)
{
if(my $ret = kill(-$sig_list{'TERM'}, $oldpid))
{
print "terminating ";
mylog(info=>"Daemon terminated.");
}
else
{
kill(-$sig_list{'KILL'}, $oldpid);
print "killed\n";
mylog(info=>"Abnormal exit. Daemon killed forcingly.");
}
unlink $PIDFILE;
exit if not $RESTART;
}
my $i;
while($oldpid && kill(0, $oldpid))
{
autoflush STDOUT 1;
print ".";
if($i++ > 5)
{
$STAYALIVE = 1;
mylog(warning=>"Couldn't remove $PIDFILE, a process with pid $oldpid exists! Use \"restart\" to force.\n");
die "Couldn't remove $PIDFILE, a process with pid $oldpid exists! Use \"restart\" to force.\n";
}
sleep 1;
}
}
create_lockpath("daemon");
if($BIND_ADDRESS && $BIND_ADDRESS !~ /^[ \t]*all[ \t]*$/i)
{
$tcp_socket = IO::Socket::INET->new( Proto => 'tcp',
LocalHost => $BIND_ADDRESS,
LocalPort => $TCP_PORT,
Listen => $SOMAXCONN,
Reuse => 1,
Blocking => 0) or
die "master: bind $TCP_PORT: $@ $!";
}
else
{
$tcp_socket = IO::Socket::INET->new( Proto => 'tcp',
LocalPort => $TCP_PORT,
Listen => $SOMAXCONN,
Reuse => 1,
Blocking => 0) or
die "master: bind $TCP_PORT: $@ $!";
}
# XXX: do we really need that? I used it for a chance of closing
# sockets when spawning caches and the like.
fcntl($tcp_socket, F_SETFD, FD_CLOEXEC);
open(PF, ">".$PIDFILE) or die $!;
# drop privileges
if(!($CMD_DEBUG))
{
my $uname = getpwnam($USER) or die "User $USER doesn't exist!";
my $gname = getgrnam($GROUP) or die "Group $GROUP doesn't exist!";
my $runame = getpwuid($<) or die $!;
my $rgname = getgrgid($() or die $!;
# XXX: You'll get nightmares if you change stuff here! *voodoospell*
$! = '';
# this first variant uses different approaches on plattforms.
# freebsd/linux uses setresgid + setgroups, other bsd, Mac OS X use
# obviously setregid + setgroups
($(,$)) = ($gname, "$gname $gname");
if($!)
{
$! = '';
# last try. Implementation variant not clear on all plattforms
$( = $gname;
die "($<)($>): set GID to $gname: $!" if $!;
$) = "$gname $gname";
die "($<)($>): set EGID to $gname: $!" if $!;
}
($<, $>) = ($uname, $uname);
if($!)
{
$! = '';
# this turns on taint mode, too. see man perlsec!
$< = $uname;
die "set UID to $uname: $!" if $!;
$> = $uname;
die "set EUID to $uname: $!" if $!;
}
chdir "/";
defined(my $pid = fork) or die "Can't fork: $!";
exit if $pid;
# daemonized
setsid or die "Can't start a new session: $!";
open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
open STDERR, '>/dev/null' or die "Can't write to /dev/null: $!";
open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
mylog(info=>"policyd-weight $VERSION started and daemonized. " .
"conf:$conf; " .
"GID:$( EGID:$) UID:$< EUID:$>; " .
"taint mode: " . ${^TAINT}
);
}
print PF $$ or die "err $!\n";
close PF or die "err $!\n";
my %childs; # maintenance hash for cleaning up children
my %avail; # hash to know which client is available
my %pipes; # hash to maintain pid -> pipe associations
cache_query("start"); # pre-launch cache
our $select_to;
my $readable_handles = new IO::Select();
my $new_tcp_readable;
$tcp_socket->autoflush(1);
$readable_handles->add($tcp_socket);
my $waitedpid;
my $parentpid = $$;
sub REAPER {
my $waitedpid;
while($waitedpid = waitpid(-1, WNOHANG))
{
last if $waitedpid == -1;
mylog(info=>"child $waitedpid exited");
delete($childs{$waitedpid});
delete($avail{$waitedpid});
delete($pipes{$waitedpid});
}
$SIG{CHLD} = \&REAPER;
}
$SIG{CHLD} = \&REAPER;
$SIG{'TERM'} = sub {
foreach(keys(%childs))
{
kill($sig_list{TERM}, $_);
}
unlink $PIDFILE;
exit 0;
};
use vars qw/$child/;
use vars qw/$parent/;
my $sigset;
my $old_sigset;
while(1)
{
# process SIGCHLD signals
if($old_sigset)
{
unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset))
{
mylog(warning=>"main: Could not unblock SIGCHLD");
}
}
# wait for data on all sockets
($new_tcp_readable) =
IO::Select->select($readable_handles, undef, undef, undef);
# block SIGCHLD signals, avoid raceconditions and coredumps
$sigset = POSIX::SigSet->new(SIGCHLD);
$old_sigset = POSIX::SigSet->new;
unless (defined sigprocmask(SIG_BLOCK, $sigset, $old_sigset))
{
mylog(warning=>"main: Could not block SIGCHLD");
}
my $max_proc_msg;
# process socket data
foreach my $sock (@$new_tcp_readable)
{
if($sock == $tcp_socket)
{
# let children handle it if they are available
if (keys(%avail) > 0)
{
$readable_handles->remove($tcp_socket);
next;
}
# don't spawn new children if MAX_PROC reached
if(keys %childs >= $MAX_PROC)
{
if( (!($max_proc_msg)) )
{
mylog(warning=>"main: MAX_PROC ($MAX_PROC) reached");
}
$max_proc_msg = 1;
$readable_handles->remove($tcp_socket);
next;
}
# open a socketpair for control communication with the
# soon to be spawned child
($child, $parent) =
IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC) or
mylog(warning=>"master: socketpair: $@ $!");
$child->autoflush(1);
$parent->autoflush(1);
# check for configuration changes before we spawn a new child
conf_check("master");
# attempt to fork a new child
defined(my $pid = fork) or die "cannot fork: $!";
# parent stuff
if ($pid)
{
$pipes{$pid} = $child;
$readable_handles->add($pipes{$pid});
$readable_handles->add($tcp_socket);
$parent->close;
$childs{$pid} = 1;
$avail{$pid} = 1;
next;
}
##############################################################################
#
# DAEMON CHILDS
#
##############################################################################
$0 = "policyd-weight (child)";
$SIG{'TERM'} = sub {
eval
{
local $SIG{ALRM} = sub { die "ETIMEOUT" };
alarm $IPC_TIMEOUT;
print $parent ("$$ 0\n");
$parent->recv(my $ans, 1024);
alarm 0;
};
exit(0);
};
$SIG{__DIE__} = sub {
die @_ if index($_[0], 'ETIMEOUT') == 0;
mylog(warning=>"child: err: @_" );
eval
{
local $SIG{ALRM} = sub { die "ETIMEOUT" };
alarm $IPC_TIMEOUT;
print $parent ("$$ 0\n");
$parent->recv(my $ans, 1024);
alarm 0;
};
};
$SIG{'HUP'} = sub {
conf_check('child');
};
mylog(info=>'child: spawned');
if($res)
{
if($s && $s->connected)
{
$s->close; # don't use inherited DNS sockets
}
my $ns = (($res->nameserver)[0]);
if(!($s = IO::Socket::INET->new(
PeerAddr => $ns,
PeerPort => '53',
Proto => 'udp'))
)
{
mylog(warning=>
"child: could not open RBL Lookup Socket to $ns: $@ $!");
$USE_NET_DNS = 1;
}
}
my $readable_handles = new IO::Select();
$readable_handles->add($parent);
$readable_handles->add($tcp_socket);
close $child;
my $tout = $CHILDIDLE;
my $maintenance = 0;
my $sig_set;
my $old_sigset;
while(1)
{
if($maintenance >= $MAINTENANCE_LEVEL)
{
$maintenance = 0;
conf_check("child");
}
if($old_sigset)
{
unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset))
{
mylog(warning=>'child: Could not unblock SIGHUP');
}
}
my $time_s = time;
($new_tcp_readable) =
IO::Select->select($readable_handles, undef, undef, $tout);
my $time_e = time;
# block SIGHUPs
$sigset = POSIX::SigSet->new(SIGCHLD);
$old_sigset = POSIX::SigSet->new;
unless (defined sigprocmask(SIG_BLOCK, $sigset, $old_sigset))
{
mylog(warning=>'child: Could not block SIGHUP');
}
$select_to = 1;
my $ans;
foreach my $sock (@$new_tcp_readable)
{
$select_to = 0;
my $ans; # define for the "for"-scope
if($sock == $tcp_socket)
{
my $new_sock = $tcp_socket->accept();
if(!($new_sock) || (!($new_sock->connected)))
{
$tout = $CHILDIDLE - ($time_e - $time_s);
if( ($tout <= 0) || ($tout > $CHILDIDLE))
{
$tout = $CHILDIDLE;
}
next;
}
else
{
print $parent ("$$ 0\n");
$parent->recv($ans, 1024);
$tout = $CHILDIDLE;
$new_sock->autoflush(1);
# set nonblocking IO, required by linux
# BSD did fine without
fcntl($new_sock, F_SETFD, O_NONBLOCK) || die $!;
$readable_handles->add($new_sock);
}
print $parent ("$$ 0\n");
$parent->recv($ans, 1024);
}
else
{
print $parent ("$$ 0\n");
$parent->recv($ans, 1024);
my $action;
my $buf;
my $ans;
my $busy;
$sock->timeout(1);
while(<$sock>)
{
$buf = $_;
if($buf)
{
$busy = 1;
$action = parse_input($buf);
}
if($action)
{
$sock->send($action);
%attr = ();
print $parent ("$$ 1\n");
$parent->recv($ans, 1024);
++$maintenance;
last;
}
}
next if ($buf && (!($action)));
if(!($buf))
{
$readable_handles->remove($sock);
$sock->shutdown(2);
close $sock;
print $parent ("$$ 1\n");
$parent->recv($ans, 1024);
}
}
}
if($select_to)
{
# child was idle too much, exit if no connection
# to a smtp
print $parent ("$$ 0\n");
$parent->recv($ans, 1024);
my $connected;
for($readable_handles->handles)
{
next if $_ == $tcp_socket or $_ == $parent;
$connected = 1;
}
if((!($connected)))
{
#ask dad if we can die
print $parent ("$$ d\n");
$parent->recv($ans, 1024);
if(($ans) && ($ans eq "y\n"))
{
mylog(info=>"child: exiting: idle for $CHILDIDLE sec.");
exit;
}
}
$readable_handles->add($tcp_socket);
print $parent ("$$ 1\n");
$parent->recv($ans, 1024);
$tout = $CHILDIDLE;
}
}
}
#######################################################################
#
# PARENT again
#
else
{
# piped control-communication with our children
my $buf = <$sock>;
if(!($buf))
{
$readable_handles->remove($sock);
$sock->close;
next
}
my ($cpid, $stat) = split(' ', $buf);
# a kid ask to go suicide
if($stat eq 'd')
{
if(keys (%childs) > $MIN_PROC)
{
# tell kid to commit suicide
print $sock ("y\n");
delete $childs{$cpid};
delete $avail{$cpid};
$readable_handles->add($tcp_socket);
}
else
{
print $sock ("n\n");
}
next;
}
# a kid tells us whether it's busy or free
if($stat == 1)
{
$avail{$cpid} = 1;
}
else
{
delete $avail{$cpid};
}
if(keys(%avail) > 0)
{
$readable_handles->remove($tcp_socket);
}
elsif(keys(%childs) < $MAX_PROC)
{
$readable_handles->add($tcp_socket);
}
print $sock ("1\n");
next;
}
}
}
}
sub parse_input
{
$_ = shift;
$_ =~ tr/\r\n//d;
if (/=/)
{
my ($k, $v) = split (/=/, lc($_), 2);
$attr{$k} = $v;
return;
}
elsif (length)
{
mylog(warning=>sprintf("warning: ignoring garbage: %.100s", $_));
return;
}
if ($VERBOSE == 1)
{
for (sort keys %attr)
{
mylog(debug=> "Attribute: $_=".$attr{$_});
}
}
fatal_exit ("unrecognized request type: '$attr{request}'") unless
$attr{request} eq 'smtpd_access_policy';
my $response;
my $action;
$action = $DEFAULT_RESPONSE;
no strict 'refs';
my $delay_time = time;
$response = weighted_check->(attr=>\%attr);
if ($response)
{
$action = $response;
}
else
{
mylog(warning=>'weighted_check returned a zero value!');
}
# return only a restriction class if the user requested it with
# specifying a response message with "rc:foo"
if(index($action, 'rc:') != -1)
{
$action =~ s/^[ \t]*rc:[ \t]*(.*?)[,; .]+.*/$1/i;
}
mylog(info=>"decided action=$action; delay: ".(time - $delay_time)."s");
return("action=$action\n\n");
}
sub address_stripped
{
# my $foo = localpart_lhs('foo+bar@baz.com'); # returns 'foo@baz.com'
my $string = shift;
for ($string)
{
s/[+-].*\@/\@/;
}
return $string;
}
###############################################################################
###############################################################################
## subroutines ################################################################
#------------------------------------------------------------------------------
# Plugin: weighted_check
#------------------------------------------------------------------------------
sub weighted_check
{
local %_ = @_;
my %attr = %{ $_{attr} };
my $ip = $attr{client_address};
my $cl_hostname = $attr{client_name};
my $cansw;
if(index($ip,":") != -1)
{
return ('DUNNO IPv6'); # we have no IPv6 support for now
}
my $client_name = $attr{client_name} || '';
my $helo = $attr{helo_name} || '';
my $from = address_stripped($attr{sender}) || '';
my $rcpt = $attr{recipient} || '';
my $instance = $attr{instance} . $ip . $from;
my $from_domain;
if($attr{sender} =~ /.*@(.*)/)
{
$from_domain = $1;
}
if($from eq '')
{
return('DUNNO NULL (<>) Sender');
}
my $orig_from = $from;
if($attr{recipient} && $attr{recipient} =~ /^(postmaster|abuse)\@/)
{
return('DUNNO mail for '.$attr{recipient});
}
if(($instance) && ($instance eq $accepted))
{
return ('DUNNO multirecipient-mail - already accepted by previous query');
}
elsif(($instance) && ($instance eq $blocked))
{
return ($my_REJECTMSG.' (multirecipient mail)');
}
## cache check
if( ($CACHESIZE > 0) || ($POSCACHESIZE > 0) )
{
$cansw = cache_query('ask', $ip, '0', $orig_from, $from_domain);
}
if($cansw && index($cansw, 'rate') != 0)
{
$blocked = $instance;
$my_REJECTMSG = $cansw;
return($my_REJECTMSG);
}
elsif($cansw && index($cansw, 'rate:hard:') == 0)
{
$accepted = $instance;
return("$RETANSW $POSCACHEMSG; $cansw");
}
## startup checks and preparing ###############################################
my ($ipp1, $ipp2, $ipp3, $ipp4) = split(/\./, $ip);
my $revip = $ipp4.'.'.$ipp3.'.'.$ipp2.'.'.$ipp1;
my $subip16 = $ipp1.'.'.$ipp2.'.';
my $subip = $subip16.$ipp3.'.';
my $rate = 0;
my $total_dnsbl_score; # this var holds only positive scores!
my $helo_ok = 0;
my $mx_ok = 0;
my $helo_untrusted_ok = 0;
my $RET = '';
my $dont_cache = 0;
my $do_client_from_check = 0;
my $client_seems_dialup = 0;
my $in_dyn_bl = 0;
my $helo_seems_dialup = 0;
my $rhsbl_penalty = 0;
my $bogus_mx_penalty = 0;
my $maxdnserr = $MAXDNSERR;
my $RELAYMSG = '';
my $found;
my $rtime = time; # timestamp of policy request
## DNSBL check ################################################################
my $i;
my $dnsbl_hits = 0;
$skip_rel = $BL_SKIP_RELEASE + $BL_ERROR_SKIP;
for($i=0;$i < @dnsbl_score; $i += 4)
{
$found = 0;
my $answ = 0;
if( (!($bl_err{$dnsbl_score[$i]})) ||
$bl_err{$dnsbl_score[$i]} <= $BL_ERROR_SKIP
)
{
$answ = rbl_lookup($revip.'.'.$dnsbl_score[$i]);
}
else
{
$RET .= ' '.$dnsbl_score[$i+3].'=SKIP('.$dnsbl_score[$i+2].')';
$rate += $dnsbl_score[$i+2];
if(++$bl_err{$dnsbl_score[$i]} >= $skip_rel)
{
$bl_err{$dnsbl_score[$i]} = 0;
}
next;
}
if(!($answ))
{
# increase err counter for that rbl
++$bl_err{$dnsbl_score[$i]};
if($maxdnserr-- <= 1)
{
$accepted = $instance;
return "$RETANSW $MAXDNSERRMSG in ".$dnsbl_score[$i].' lookups';
}
$RET .= ' '.$dnsbl_score[$i+3].'=ERR('.$dnsbl_score[$i+2].')';
$rate += $dnsbl_score[$i+2];
next;
}
$bl_err{$dnsbl_score[$i]} = 0;
if($answ > 0)
{
$RET .= ' IN_'.$dnsbl_score[$i+3].'=' .
$dnsbl_score[$i+1];
$found = 1;
$rate += $dnsbl_score[$i+1];
$total_dnsbl_score += $dnsbl_score[$i+1];
if(index(lc($dnsbl_score[$i+3]), 'dyn') != -1)
{
$client_seems_dialup = 1;
$in_dyn_bl = 1;
}
}
if($found == 0)
{
if($LOG_BAD_RBL_ONLY == 1)
{
if($dnsbl_score[$i+2] != 0) # if an RBL entry manipulates
# the overall score, log it though.
{
$RET .= ' NOT_IN_'.$dnsbl_score[$i+3].'=' .
$dnsbl_score[$i+2];
}
}
else
{
$RET .= ' NOT_IN_'.$dnsbl_score[$i+3].'='.$dnsbl_score[$i+2];
}
$rate += $dnsbl_score[$i+2];
}
else
{
# increase DNSBL hitcounter only if the DNSBL is a RBL and no
# DNS whitelist
if($dnsbl_score[$i+1] > 0)
{
++$dnsbl_hits;
}
else
{
next;
}
# check for DNSBL Hit/Score limit exceeding
if(
($dnsbl_hits > $MAXDNSBLHITS ) ||
($total_dnsbl_score > $MAXDNSBLSCORE)
)
{
if($CACHESIZE > 0)
{
cache_query('nadd', $ip, $total_dnsbl_score);
}
$blocked = $instance;
mylog(info=>"weighted check: $RET, rate: $rate");
return($MAXDNSBLMSG.'; check http://rbls.org/?q='.$ip);
}
}
}
if($dnsbl_checks_only == 1)
{
return("DUNNO only DNSBL check requested");
}
## postive cache check
if($cansw && ($POSCACHESIZE > 0) && ($dnsbl_hits < 1))
{
$accepted = $instance;
return("$RETANSW $POSCACHEMSG; $cansw");
}
## HELO check #################################################################
$found = 0;
my $is_mx = 0;
my $addresses = '';
my $mx_names = '';
my $recs_found = 0;
my $MATCH_TYPE;
my $from_addresses = '';
my $dnserr = 0;
my $bogus_mx = 0;
my $bad_mx = 0;
my $bad_mx_scored = 0;
my $do_reverse_check = 0;
my @helo_parts = split(/\./,$helo);
$from =~ /.*@(.*)/;
my $tmp_from = $1;
my @parts_check = ($tmp_from, $helo); # don't change order
for(my $tmpcnt=0; $tmpcnt < @parts_check; $tmpcnt++)
{
if($tmpcnt == 1)
{
$MATCH_TYPE = 'HELO';
}
else
{
$MATCH_TYPE = 'FROM';
}
my @parts = split(/\./,$parts_check[$tmpcnt]);
for(;@parts >=2;shift(@parts))
{
my $testhelo = join('.',@parts);
my $query = $res->send($testhelo, 'MX');
if(dns_error(\$query, \$res))
{
if($maxdnserr-- <= 1)
{
$accepted = $instance;
return("$RETANSW $MAXDNSERRMSG in $MATCH_TYPE MX lookups for $testhelo");
}
next;
}
# removed "if($query && $query->answer)" (which was introduced in
# 0.1.14.4 due to dns_error() implementation) in 0.1.14.5 because
# A lookups were not performed if MX returned NXDOMAIN
# XXX: this is to be reviewed and sanitized
if($query)
{
$recs_found = 1; # means, we've got some dns response
foreach my $rr ($query->answer)
{
if($rr->type eq 'MX')
{
my $mxres = $res->send($rr->exchange);
if(dns_error(\$mxres, \$res))
{
if($maxdnserr-- <= 1)
{
$accepted = $instance;
return("$RETANSW $MAXDNSERRMSG in $MATCH_TYPE MX -> A lookups");
}
next;
}
foreach my $mxvar ($mxres->answer)
{
next if $mxvar->type ne 'A';
# store sender MX hostname entries for comparission
# with HELO argument
if ($MATCH_TYPE eq 'FROM')
{
$mx_names .= '.'.$rr->exchange . " ";
}
if($tmpcnt == 0)
{
$from_addresses .= ' '.$mxvar->address;
}
$addresses .= ' '.$mxvar->address;
if ($ip eq $mxvar->address)
{
$RET .= ' CL_IP_EQ_'.$MATCH_TYPE.'_MX=' .
$helo_from_mx_eq_ip_score[1];
$found = 1;
$is_mx = 1 if $MATCH_TYPE eq 'FROM';
$helo_ok = 1;
$mx_ok = 1;
$rate += $helo_from_mx_eq_ip_score[1];
last;
}
}
}
last if $found;
}
# penalize dnsbl-weighted for empty/bogus MX records
# XXX: probably need to separate hostnames from domainnames
if( $MATCH_TYPE eq 'FROM' &&
(!($bad_mx)) &&
(
$from_addresses !~ /\d+/ ||
$from_addresses =~
/( 127\.| 192\.168\.| 10\.| 172\.(?:1[6-9]|2\d|3[01])\.)/
)
)
{
$bad_mx = 1;
}
if(!($found))
{
my $query = $res->send($testhelo, 'A');
if(dns_error(\$query, \$res))
{
if($maxdnserr-- <= 1)
{
$accepted = $instance;
return("$RETANSW $MAXDNSERRMSG in $MATCH_TYPE A lookup for $testhelo");
}
next;
}
foreach my $addr ($query->answer)
{
if($addr->type eq 'PTR')
{
if($helo == $ip)
{
$RET .= ' CL_IP_EQ_HELO_NUMERIC='.
$helo_score[1];
$rate += $helo_score[1];
$found = 1;
$helo_untrusted_ok = 1;
}
}
if(($addr->type ne 'A')){ next; }
if($tmpcnt == 0)
{
$from_addresses .= ' '.$addr->address;
}
$addresses .= ' '.$addr->address;
if ($ip eq $addr->address)
{
$found = 1;
$helo_ok = 1;
$RET .= ' CL_IP_EQ_'.$MATCH_TYPE.'_IP=' .
$helo_score[1];
$rate += $helo_score[1];
$bad_mx = 0;
last;
}
}
}
if($bad_mx && (!($bad_mx_scored)))
{
my $score = $bogus_mx_score[0] * $total_dnsbl_score;
if($score)
{
$RET .= ' BAD_MX='.$score;
$rate += $score;
$bad_mx_scored = 1;
}
}
# check if sender domain has bogus or empty
# A/MX records.
if( ($MATCH_TYPE eq 'FROM') &&
(!($bogus_mx)) &&
(
$from_addresses !~ /\d+/ ||
$from_addresses =~
/( 127\.| 192\.168\.| 10\.| 172\.(?:1[6-9]|2\d|3[01])\.)/
)
)
{
my $score = $bogus_mx_score[0] + $total_dnsbl_score;
$RET .= ' BOGUS_MX='.$score;
$rate += $score;
$bogus_mx = 1;
$bogus_mx_penalty = $score;
}
last if $found;
}
last if $found;
}
last if $found;
}
if((!($found)) && $recs_found) # helo seems forged
{
if(index($addresses,' '.$subip) != -1)
{
$RET .= ' HELO_IP_IN_CL_SUBNET='.$helo_ip_in_client_subnet[1];
$rate += $helo_ip_in_client_subnet[1];
$helo_ok = 1;
$found = 1;
}
elsif(index($addresses,' '.$subip16) != -1)
{
$RET .= ' HELO_IP_IN_CL16_SUBNET=' .
$helo_ip_in_cl16_subnet[1];
$rate += $helo_ip_in_cl16_subnet[1];
$helo_untrusted_ok = 1;
$do_reverse_check = 1;
$found = 1;
}
if($found != 1 && $helo_ok != 1)
{
my $score = $helo_score[0] + $total_dnsbl_score;
$RET .= ' CL_IP_NE_HELO='.$score;
$helo_ok = 2;
$rate += $score;
}
}
elsif($found != 1) # probably DNS error
{
my $score = ($helo_score[0]-0.1);
$RET .= ' NO_MX_A_RECS_FOUND='.$score;
$rate += $score;
$helo_ok = 2;
}
## Reverse IP == dynhost check ###############################################
my $ip_res = $res->send("$ip");
my @reverse_ips;
if($ip_res && $ip_res->answer)
{
foreach my $tmprr ($ip_res->answer)
{
if($tmprr->type eq 'PTR')
{
my $tmpptr = $tmprr->ptrdname;
$tmpptr =~ s/\.$//;
push(@reverse_ips, lc($tmpptr));
}
}
}
if((!($client_seems_dialup)) && ($mx_ok != 1))
{
foreach my $revhost (@reverse_ips)
{
if( $revhost =~ /(mx|smtp|mail|[^n]stat).*?\..*?\./i )
{ last }
if (
$revhost =~
/(\.dip|cable|ppp|dial|dsl|dyn|client|rev.*?(ip|home)).*?\..*?\./i
||
$helo =~
/[a-z\.\-\_]+\d{1,3}[-._]\d{1,3}[-._]\d{1,3}[-._]\d{1,3}/i
)
{
$client_seems_dialup = 1;
$total_dnsbl_score += $client_seems_dialup_score[0];
$rate += $client_seems_dialup_score[0];
$RET .= ' CL_SEEMS_DIALUP=' .
$client_seems_dialup_score[0];
last;
}
}
}
## Reverse IP == HELO check ###################################################
$found = 0;
my $rev_processed = 0;
if(($helo_ok != 1 && $helo_untrusted_ok != 1) || $do_reverse_check)
{
foreach my $revhost (@reverse_ips)
{
$rev_processed = 1;
$revhost =~ s/\.*$//;
if ( $revhost eq $helo )
{
$found = 1;
$RET .= ' REV_IP_EQ_HELO='.$client_ip_eq_helo_score[1];
$rate += $client_ip_eq_helo_score[1];
last;
}
my $partsfound = 0;
my $tmprevhost = reverse($revhost);
my $tmphelo = reverse($helo);
$tmphelo =~ s/.*?\.([^.]+).*/$1/;
if( ($tmprevhost =~ /\.\Q$tmphelo\E$/i ) ||
($tmprevhost =~ /\.\Q$tmphelo\E\./i)
)
{
$partsfound = 1;
}
if( $partsfound != 1 )
{
my $tmphelo = reverse($helo);
$tmprevhost =~ s/.*?\.([^.]+).*/$1/;
if( ($tmphelo =~ /\.\Q$tmprevhost\E$/i ) ||
($tmphelo =~ /\.\Q$tmprevhost\E\./i)
)
{
$partsfound = 1;
}
}
if($partsfound == 1)
{
$found = 1;
$RET .= ' REV_IP_EQ_HELO_DOMAIN='.$client_ip_eq_helo_score[1];
$rate += $client_ip_eq_helo_score[1];
last;
}
}
if($rev_processed != 1 && $recs_found != 1)
{
$RET .= ' NO_DNS_RECORDS=0.5';
$rate += 0.5;
$dnserr = 1;
}
if($found != 1)
{
$RET .= ' RESOLVED_IP_IS_NOT_HELO='.$client_ip_eq_helo_score[0];
$rate += $client_ip_eq_helo_score[0];
}
else
{
if( ! ($cl_hostname && $cl_hostname ne "unknown") )
{
$helo_untrusted_ok = 1;
}
else
{
$helo_untrusted_ok = 0;
}
}
}
## HELO numeric check #########################################################
if($helo =~ /\d$/)
{
$RET .= ' HELO_NUMERIC='.$helo_numeric_score[0];
$rate += $helo_numeric_score[0];
}
## HELO dialup check ##########################################################
my $DYN_DNS_MSG = '';
if(
( ($enforce_dyndns_score[0] != 0) ||
($client_seems_dialup != 1)
)
&&
(!($mx_ok))
&&
(
(
$helo =~
/(\.dip|cable|ppp|dial|dsl|dyn|client|rev.*?(ip|home)).*?\..*?\./i
) ||
(
$helo =~ /[a-z\.\-\_]+\d{1,3}[-._]\d{1,3}[-._]\d{1,3}[-._]\d{1,3}/i
# that's an ugly regex! watch this!
)
)
)
{
$helo_seems_dialup = 1;
$DYN_DNS_MSG = "; Please use DynDNS";
if($helo_ok == 1)
{
my $score = $helo_seems_dialup[0] + $enforce_dyndns_score[0];
$RET .= ' HELO_SEEMS_DIALUP='.$score;
$rate += $score;
}
else
{
my $score = $failed_helo_seems_dialup[0] + $enforce_dyndns_score[0];
$RET .= ' NOK_HELO_SEEMS_DIALUP='.$score;
$rate += $score;
}
}
## From has nobody/anonymous user #############################################
my $anon= 0;
if($orig_from =~ /(nobody|anonymous)\@/)
{
my $score = $from_anon[0] + $total_dnsbl_score;
$RET .= ' FROM_NBDY_ANON='.$score;
$rate += $score;
$anon = 1;
}
## FROM Domain vs HELO regex check ############################################
if(!($is_mx))
{
$from =~ s/.*@//; # delete localpart
my $tmphelo = $helo;
my $tmp_helo_domain;
# handle sender "(host.)sub.domain.co.uk"
# keep: "domain"
if ($from =~ s/\.[a-z]{2}\.[a-z]{2}$//i)
{ $from =~ s/.*\.// }
# handle sender "(host.)sub.domain1.com.br"
# keep: "domain"
elsif($from =~ s/\.(com|org|net)\.[a-z]{2}$//i)
{ $from =~ s/.*\.// }
# handle sender "(host.)sub.domain.com"
# handle "(host.)sub.domain.de"
# keep: "domain"
elsif($from =~ s/\.[a-z]{2,5}$//i)
{ $from =~ s/.*\.// }
# handle helo "(host.)sub.domain.co.uk"
if ($tmphelo =~ s/\.[a-z]{2}\.[a-z]{2}$//i)
{ }
# handle helo "(host.)sub.domain1.com.br"
elsif($tmphelo =~ s/\.(com|org|net)\.[a-z]{2}$//i)
{ }
# handle helo "(host.)sub.domain.com"
# handle helo "(host.)sub.domain.de"
# keep: "domain"
elsif($tmphelo =~ s/\.[a-z]{2,5}$//i)
{ }
# get helo domain for checking against sender MX entries
$tmp_helo_domain = $tmphelo;
$tmp_helo_domain =~ s/.*\.//;
# set "." (dot) delimiter for comparisions
$from = '.' . $from .'.';
$tmphelo = '.' . $tmphelo .'.';
$tmp_helo_domain = '.' . $tmp_helo_domain .'.';
$RET .= ' (check from: ' . $from
. ' - helo: ' . $tmphelo
. ' - helo-domain: ' . $tmp_helo_domain .') ';
# check trusted helos
if($helo_ok == 1)
{
if(
(index($tmphelo,$from) != -1) ||
(index($from,$tmphelo) != -1) ||
(index($mx_names,$tmp_helo_domain) != -1)
)
{
$RET .= ' FROM/MX_MATCHES_HELO(DOMAIN)=' .
$from_match_regex_verified_helo[1];
$rate += $from_match_regex_verified_helo[1];
}
else
{
my $score = myrnd(
( $from_match_regex_verified_helo[0]
+ ($total_dnsbl_score/4)
+ ($bogus_mx_penalty * $bogus_mx_penalty)
)
);
$RET .= ' FROM/MX_MATCHES_NOT_HELO(DOMAIN)='.$score;
$rate += $score;
$do_client_from_check = 1;
}
}
elsif($helo_untrusted_ok == 1)
{
# check untrusted helos
if( (index($tmphelo,$from) != -1) ||
(index($from,$tmphelo) != -1) ||
(index($mx_names,$tmp_helo_domain) != -1)
)
{
$RET .= ' FROM/MX_MATCHES_UNVR_HELO(DOMAIN)=' .
$from_match_regex_unverified_helo[1];
$rate += $from_match_regex_unverified_helo[1];
}
else
{
my $score = ( $from_match_regex_unverified_helo[0]
+ $total_dnsbl_score
+ ($bogus_mx_penalty * $bogus_mx_penalty)
);
$RET .= ' FROM/MX_MATCHES_NOT_UNVR_HELO(DOMAIN)='.$score;
$rate += $score;
$do_client_from_check = 1;
}
}
# check totaly failed helos
elsif(index($tmphelo,$from) != -1 || index($from,$tmphelo) != -1)
{
$RET .= ' MAIL_SEEMS_FORGED='.$from_match_regex_failed_helo[0];
$rate += $from_match_regex_failed_helo[0];
}
elsif(index($tmphelo,$from) == -1 || index($from,$tmphelo) == -1)
{
my $score = ( $from_match_regex_failed_helo[0]
+ 0.5
+ $total_dnsbl_score
);
$RET .= ' FROM_NOT_FAILED_HELO(DOMAIN)='.$score;
$rate += $score;
}
}
## client == MX/A FROM domain #################################################
if(
($mx_ok != 1) &&
(
($do_client_from_check) &&
($dnsbl_hits > 0)
)
)
{
if( index($from_addresses, $ip) == -1 )
{
my $score = $helo_from_mx_eq_ip_score[0] + $total_dnsbl_score;
$RELAYMSG = '; please relay via your ISP ('.$from_domain.')';
$RET .= ' CLIENT_NOT_MX/A_FROM_DOMAIN='.$score;
$rate += $score;
if( index($from_addresses, $subip) == -1 )
{
$RET .= ' CLIENT/24_NOT_MX/A_FROM_DOMAIN='.$score;
$rate += $score;
}
}
}
## From domain multiparted check ##############################################
if(
(!($helo_ok || $mx_ok)) &&
($rate < $REJECTLEVEL) &&
($orig_from =~ /\@.*?\..*?\./)
)
{
my $score = $from_multiparted[0] + $total_dnsbl_score;
$RET .= ' FROM_MULTIPARTED='.$score;
$rate += $score;
}
## Random sender check ########################################################
if(
($rate < $REJECTLEVEL) &&
(
($orig_from =~ /[bcdfgjklmnpqrtvwxz]{5,}.*\@/i) ||
($orig_from =~ /[aeiou]{4,}.*\@/i)
)
)
{
my $score = ( $total_dnsbl_score
+ ($total_dnsbl_score * $random_sender_score[0])
+ $random_sender_score[0]
);
$RET .= ' RANDOM_SENDER=' . $score;
$rate += $score;
$rhsbl_penalty = $rhsbl_penalty_score[0] * $random_sender_score[0];
}
## rhsbl check ################################################################
my $in_rhsbl;
my $RHSBLMSG = '';
if($rate < $REJECTLEVEL)
{
$orig_from =~ /@(.*)/;
my $query = $1;
if( ($do_client_from_check == 1) ||
($helo_untrusted_ok == 1) ||
($bogus_mx == 1)
)
{
$rhsbl_penalty += $rhsbl_penalty_score[0];
}
for($i=0;$i < @rhsbl_score; $i += 4)
{
my $answer = rbl_lookup($query.'.'.$rhsbl_score[$i], 'A');
if(!($answer))
{
if($maxdnserr-- <= 1)
{
$accepted = $instance;
return ("$RETANSW $MAXDNSERRMSG in " .
$rhsbl_score[$i].' lookups');
}
next;
}
if($answer > 0)
{
my $score = myrnd(
($rhsbl_score[$i+1] + $rhsbl_penalty ) +
($total_dnsbl_score/2)
);
$RET .= ' IN_'.$rhsbl_score[$i+3].'=' . $score;
$rate = myrnd($rate + $score);
$RHSBLMSG .= '; in '.$rhsbl_score[$i];
}
}
}
###############################################################################
# parse and store results, do some cleanup, return results
# sanitize rate, perl gives inaccurate results in computings like
# -4.6 + 4.3
$rate = myrnd($rate);
$RET .= " <client=$ip> <helo=$helo> <from=$orig_from> <to=$rcpt>";
if(($DEBUG) || ($CMD_DEBUG == 1))
{
$addresses =~ s/ $//;
$RET .= ' <helo_ips: '.$addresses.'>';
}
mylog(info=>"weighted check: $RET, rate: $rate");
if(($dnserr == 1) && ($dnsbl_hits < 2)) # applies if not too
{ # much dnsbl listed
my $my_DNSERRMSG = $DNSERRMSG . ' Your HELO: '.$helo.', IP: '.$ip;
return($my_DNSERRMSG);
}
if($rate >= $REJECTLEVEL)
{
$blocked = $instance;
$my_REJECTMSG = $REJECTMSG;
$dont_cache = 0;
if($rate < $DEFER_LEVEL)
{
my @defer_arr = split(' ', $DEFER_STRING);
foreach(@defer_arr)
{
if(index($RET, ' '.$_) != -1)
{
$dont_cache = 1;
$my_REJECTMSG =~ s/\d+/$DEFER_ACTION /;
last;
}
}
}
if(($CACHESIZE > 0) && ($maxdnserr > 0) && (!($dont_cache)))
{
# add only the IP to SPAM cache if the client is dnsbl listed,
# a dynamic client or has no ok helo
# This should help in case of some dictionary attacks
if(($dnsbl_hits >= 1 || $client_seems_dialup || $helo_ok != 1))
{
cache_query('nadd', $ip, $rate);
}
else
{
cache_query('nadd', $ip, $rate, $orig_from, $from_domain);
}
}
if(($helo_ok != 1) && ($helo_untrusted_ok != 1))
{
my $EREJECTMSG = $my_REJECTMSG .
'; MTA helo: '.$helo.', MTA hostname: ' .
$client_name.'['.$ip.'] (helo/hostname mismatch)';
return($EREJECTMSG.$RHSBLMSG.$RELAYMSG.$DYN_DNS_MSG);
}
return($my_REJECTMSG.$RHSBLMSG.$RELAYMSG.$DYN_DNS_MSG);
}
else
{
if(($POSCACHESIZE > 0) && ($dnsbl_hits < 1))
{
cache_query('padd', $ip, $rate, $orig_from, $from_domain);
}
$accepted = $instance;
return("$RETANSW $RET, rate: $rate");
}
}
#
# cache_query (QUERY, IP, SENDER, [RATE], DOMAIN)
#
# Function for querying the cache daemon
#
# QUERY : "nadd" - negative (SPAM) add
# : "padd" - positive (HAM) add
# : "ask" - is cached as SPAM or HAM?
# : "kill" - terminated cache
# : "start" - pre-start cache
# IP : Client IP
# SENDER : Sender Address
# RATE : store rate in "Xadd" queries
# DOMAIN : Sender domain
#
# Returns: CACHEREJECTMSG when SPAM listed
# : "rate: $rate" when HAM listed
# : undef in all other cases
sub cache_query
{
my $query = shift(@_) || '';
my $ip = shift(@_) || '';
my $rate = shift(@_) || '';
my $sender = shift(@_) || '';
my $domain = shift(@_) || '';
if( (!($csock)) || ($csock && (!($csock->connected))) )
{
$csock = IO::Socket::UNIX->new($SPATH);
if( (!($csock = IO::Socket::UNIX->new($SPATH))) )
{
spawn_cache();
return(undef);
}
if( $query eq 'start')
{
$csock->close(); # dont inherit this socket;
return(undef);
}
}
if($csock && ($csock->connected))
{
my $buf;
my $alrm = 0;
$SIG{'ALRM'} = sub {
# ignore alarms;
$alrm = 1;
};
$csock->autoflush(1);
mylog(info=>"cache_query: $query $ip $rate $sender $domain") if $DEBUG;
print $csock "$CVERSION $query $ip $rate $sender $domain\n";
my $sline;
my $match = $query.$ip.$sender.' ';
$csock->timeout($IPC_TIMEOUT);
while($csock->connected)
{
eval
{
local $SIG{'ALRM'} = sub {
mylog(warning=>'cache_query: timeout');
die "ETIMEOUT";
};
alarm $IPC_TIMEOUT;
$csock->recv($buf, 4069);
alarm 0;
};
if($@ || (!($buf))) { return(undef) };
if($STATS)
{
$buf =~ s/^.*?(blocked|pass)/$1/;
print $buf;
return(undef) if $buf =~ /\nEOF\n/;
next;
}
if($buf !~ /\n$/)
{
$sline .= $buf;
next;
}
else
{
$sline .= $buf;
}
$sline =~ tr/\r\n//d;
mylog(info=>"cache_query: \"$sline\" vs \"$match\"") if $DEBUG;
if(index($sline, 'unknown cache request') >= 0)
{
print $csock "kill\n";
close($csock);
$csock = "";
return(undef);
}
# return a proper line in case we had query timeouts
# works like "next if not $sline =~ s/.*\Q$match\E//;" but faster
my $index = rindex($sline, $match);
next if $index < 0;
return(substr($sline, $index + length($match)));
}
return(undef); # just in case ...
}
else
{
mylog(info=>'could not connect to cache (maybe just starting up)');
return(undef);
}
}
#############################################################################
#
# CACHE PROCESS
#
#############################################################################
sub spawn_cache
{
my $rname = getpwuid($<);
if(($rname ne $USER) && (!($CMD_DEBUG)))
{
mylog(warning=>"warning: cache: running as wrong user: ".$rname."; please edit master.cf, set user=$USER and/or add $USER to your user and group accounts; cache not spawned.");
return(undef);
}
if(!( $< = getpwnam($USER)))
{
mylog(warning=>"warning: cache: couldn't change UID to user $USER: $!");
die $!;
}
if(!( $( = getpwnam($USER) ))
{
mylog(warning=>"warning: cache: couldn't change GID to user $GROUP: $!");
}
create_lockpath('cache');
# grey magic to avoid races at startups
mkdir $LOCKPATH.'/cache_lock' or return undef;
# check if a cache-socket file exist, and
# whether we can connect to it.
if( -f $SPATH)
{
my $test_sock = IO::Socket::UNIX->new($SPATH);
return undef if ($test_sock && $test_sock->connected);
close($test_sock);
}
# no cache seems to exist, go create one
unlink $SPATH;
use POSIX qw(setsid);
defined(my $pid = fork) or die "cache: fork: $!";
if($pid)
{
return(undef);
}
setsid or die "cache: setsid: $!";
mylog(info=>'cache spawned');
$0 = 'policyd-weight (cache)';
if($CMD_DEBUG != 1)
{
close(STDIN);
close(STDOUT);
close(STDERR);
open (STDIN, '/dev/null');
open (STDOUT, '>/dev/null');
open (STDERR, '>/dev/null');
}
$s = '' if $s; # close socks, we don't need them anymore.
$res = '' if $res;
$sock->close if $sock;
$new_sock->close if $new_sock;
$tcp_socket->close if $tcp_socket;
$SIG{__DIE__} = sub {
die @_ if index($_[0], 'ETIMEOUT') == 0;
mylog(warning=>"cache: err: @_");
unlink $SPATH;
rmdir $LOCKPATH.'/cache_lock';
};
$SIG{'TERM'} = sub {
unlink $SPATH;
rmdir $LOCKPATH.'/cache_lock';
mylog(info=>'cache: terminating');
exit 0;
};
$SIG{'QUIT'} = sub {
unlink $SPATH;
rmdir $LOCKPATH.'/cache_lock';
mylog(info=>'cache: terminating');
exit 0;
};
use strict;
my $readable_handles = new IO::Select();
umask(0007); # alow only owner and group to read/write from/to socket
our $lsock = IO::Socket::UNIX->new( Listen => $SOMAXCONN,
Local => $SPATH) or
die "warning: cache: $@ $!";
rmdir $LOCKPATH.'/cache_lock';
chown($<, $(, $SPATH); # set correct socket owner and group
$readable_handles->add($lsock);
$| = 1;
my $new_readable;
my $i;
my $KILL;
our $poscache_cnt = 0;
our $cache_cnt = 0;
our $maintenance = 0;
our $FORCE_MAINT;
my $old_mtime;
if($conf ne 'default settings')
{
$old_mtime = (stat($conf))[9];
}
ptime_conv();
while(1)
{
autoflush $lsock 1;
$FORCE_MAINT = 1;
($new_readable) =
IO::Select->select($readable_handles, undef, undef, $MAXIDLECACHE);
foreach my $sock (@$new_readable)
{
$FORCE_MAINT = 0;
if($sock == $lsock)
{
my $new_sock = $sock->accept();
$new_sock->autoflush(1);
$readable_handles->add($new_sock);
}
else
{
$sock->autoflush(1);
my $buf = <$sock>;
if(($buf) && ($buf =~ /\n.*?\n/))
{ mylog(info=>'cache: multiline request. Doh!'); }
$buf =~ tr/\r\n//d if $buf;
if($buf)
{
my $time = time;
my $ret = '0'; # this var will hold the returned
# result for the client if not told
# within the routines
my($cv, $query, $ip, $rate, $sender, $domain) =
split(/ /, lc($buf));
if($CVERSION != $cv && (!($KILL)))
{
mylog(info=>'cache: new cache version, terminating ASAP') if (!($KILL));
$KILL = 1;
$query = '';
}
if($query eq 'ask')
{
# check whether IP or IP-Sender are in SPAM cache
foreach my $ckey ($ip, $ip.'-'.$sender)
{
if($cache{$ckey})
{
my $tdiff = $time - $cache{$ckey}[2];
if( ($cache{$ckey}[1] <= 0) &&
($tdiff > $NTIME)
)
{
# NTTL reached and client retried it
# after NTIME seconds
$ret = '0';
delete($cache{$ckey});
--$cache_cnt;
}
else
{
if($tdiff > $NTIME)
{
$cache{$ckey}[1] -= 1;
}
$ret = $CACHEREJECTMSG.
' - retrying too fast. penalty: '.
$NTIME.' seconds x '.
$cache{$ckey}[1].' retries.';
$cache{$ckey}[2] = $time;
last;
}
}
}
if(!($ret))
{
# ask the HAM cache
my $ckey = $ip.'-'.$domain;
if($poscache{$ckey})
{
$ret = "rate: ";
# check entry time
if($time - $poscache{$ckey}[3] >
$my_TEMP_PTIME)
{
if( ($poscache{$ckey}[1] > 0) &&
($time - $poscache{$ckey}[4] <
$my_PTIME)
)
{
$ret = "rate:hard: ";
$poscache{$ckey}[1] -= 1;
}
else
{
$poscache{$ckey}[1] = $PTTL;
$poscache{$ckey}[4] = $time;
}
}
$ret .= $poscache{$ckey}[0];
$poscache{$ckey}[2] = $time;
}
}
}
elsif($query eq 'padd')
{
my $ckey = $ip.'-'.$domain;
++$poscache_cnt unless $poscache{$ckey};
$poscache{$ckey}[0] = $rate;
$poscache{$ckey}[1] = $PTTL;
$poscache{$ckey}[2] = $time; # last seen
$poscache{$ckey}[3] = $time; # TEMP_PTIME
$poscache{$ckey}[4] = $time; # PTIME
++$maintenance;
}
elsif($query eq 'nadd')
{
my $ckey = $ip;
if($domain)
{
$ckey = $ip.'-'.$sender;
}
++$cache_cnt unless $cache{$ckey};
$cache{$ckey}[0] = $rate;
$cache{$ckey}[1] = $NTTL;
$cache{$ckey}[2] = $time;
++$maintenance;
}
elsif($query =~ /^stat/)
{
while ( my ($key, $val) = each(%cache) )
{
$ret .= "blocked: $key ".join(" ",@$val)."\n";
}
while ( my ($key, $val) = each(%poscache) )
{
$ret .= "pass: $key ".join(" ",@$val)."\n";
}
$ret .= "EOF";
}
elsif($query eq 'reload')
{
$FORCE_MAINT = 1;
}
elsif($query eq 'kill')
{
$KILL = 1;
}
else
{
$ret = "unknown cache request: $buf\nEOF";
}
print $sock $query.$ip.$sender.' '.$ret."\n";
}
else
{
$readable_handles->remove($sock);
close ($sock);
}
}
}
## kill the cache
if(($KILL) || (($FORCE_MAINT) && ($CMD_DEBUG)))
{
my $dbmsg = '';
$dbmsg = 'debug ' if $CMD_DEBUG;
unlink ($SPATH);
if($lsock) { close ($lsock) };
mylog (info=>$dbmsg.'cache killed');
exit(0);
}
if( ($maintenance >= $MAINTENANCE_LEVEL) || ($FORCE_MAINT == 1) )
{
$maintenance = 0;
conf_check('cache');
}
## clean up cache
if($poscache_cnt > $POSCACHEMAXSIZE)
{
my $purgecnt = 0;
my $startt = time;
for(sort { $poscache{$a}[2] <=> $poscache{$b}[2] } keys %poscache)
{
if($poscache_cnt > $POSCACHESIZE)
{
delete($poscache{$_});
++$purgecnt;
--$poscache_cnt;
}
else
{
last;
}
}
if($purgecnt > 0)
{
mylog(info=>"cache: purged $purgecnt from HAM cache, time: ".(time - $startt).'s');
}
}
if($cache_cnt > $CACHEMAXSIZE)
{
my $purgecnt = 0;
my $startt = time;
for(sort { $cache{$a}[2] <=> $cache{$b}[2] } keys %cache)
{
if($cache_cnt > $CACHESIZE)
{
delete($cache{$_});
++$purgecnt;
--$cache_cnt;
}
else
{
last;
}
}
if($purgecnt > 0)
{
mylog(info=>"cache: purged $purgecnt from SPAM cache, time: ".(time - $startt).'s');
}
}
}
}
#
# mylog(FACILITY, STRING)
#
# prints FACILITY, STRING on STDOUT when in command-line debug (-d) mode
# otherwise passes it to syslog()
#
sub mylog
{
my $fac = shift(@_);
my $string = join(' ', @_);
if($CMD_DEBUG)
{
my $now = scalar(localtime);
$now =~ /(\d\d:\d\d:\d\d)/;
print("$1 $fac: $string");
print "\n";
}
else
{
syslog($fac, "%s", $string);
}
}
# rbl_lookup RBL_QUERY [TYPE]
# returns: 1: found, -1: not found, 0: error, -2: sock err
# remember to give IP octets in reversed order.
# EG: IP: 121.122.123.124, Host: mail.example.com, Rbl: bl.rbl.com
# RBL_QUERY : "124.123.122.121.bl.rbl.com"
# RHSBL_QUERY: "mail.example.com.bl.rbl.com"
# TYPE : additonal and usually not needed, default is TXT
# In case of weird errors it tries to use Net::DNS
# You may force the permanent usage of Net::DNS by global setting USE_NET_DNS
sub rbl_lookup
{
my @bu = @_;
if($bu[0] =~ /[^.]{64}/) { return (1) }; # see RFC 1035 sect. 2.3.4
while(length($bu[0]) > 255) # see RFC 1035 sect. 3.1
{
$bu[0] =~ s/.*?\.//;
}
if(($USE_NET_DNS == 1) || ($] < 5.008000))
{
my $answ = $res->send(@bu);
if (!($answ)) { return (0) } # dns error
elsif(($answ->answer) > 0 ) { return (1) } # found
else { return (-1) } # not found
}
my $query = shift(@bu);
my $rtype = shift(@bu);
my $oid = 1 + int(rand(65536));
$rtype = 'A' unless ($rtype && $RTYPES{$rtype});
# ID RD QDCOUNT
my $p = pack ("n*", $oid, 0x100, 1, 0, 0, 0) .
# concatenate the query and pack it into length preceded labels
pack ('(C/A*)*', split /\./, $query ).
pack ('@ (n*)*', $RTYPES{$rtype}, 1);
# ^QTYPE ^QCLASS see: RFC 1035
$SIG{ALRM} = sub {
mylog(warning=>"warning: rbl_lookup: SIGALRM trapped?! Report.");
return
};
my $buf;
my $errcnt = 0;
my $dropped = 0;
while($s)
{
alarm 0; # reset all eventually alarms
if($dropped==0)
{
mylog(info=>"rbl_lookup: sending: $query, $oid") if $DEBUG;
eval
{
local $SIG{ALRM} = sub { die "ETIMEOUT" };
alarm $DNS_RETRY_IVAL;
if($s->send($p) < length($p))
{
mylog(warning=>"rbl_lookup: sent bytes != packet size");
++$errcnt; # timeout or error on sending
}
alarm 0;
};
if($@)
{
++$errcnt;
mylog(warning=>"warning: rbl_lookup: timeout sending: $query") if $DEBUG;
next;
}
}
$dropped = 0;
my $buf;
eval
{
local $SIG{ALRM} = sub { die "ETIMEOUT" };
alarm $DNS_RETRY_IVAL;
$s->recv($buf, 2048);
alarm 0;
};
if((!($buf)) && ($errcnt < $DNS_RETRIES))
{
++$errcnt;
next;
}
elsif((!($buf)) && ($errcnt >= $DNS_RETRIES))
{
return(0); # too many timeouts or errors
}
my ($id, $bf, $qc, $anc, $nsc, $arc, $qb) =
unpack('n n n n n n a*', $buf);
my ($dn, $offset) = dn_expand(\$qb, 0);
if(($id && $anc) && ($id == $oid) && ($query eq $dn))
{
mylog(info=>"rbl_lookup: $query vs $dn, $oid vs $id, anc == $anc") if $DEBUG;
return(1); # found
}
elsif($id && (!($anc)) && ($id == $oid) && ($query eq $dn))
{
mylog(info=>"rbl_lookup: $query vs $dn, $oid vs $id, anc == 0") if $DEBUG;
return(-1); # not found
}
elsif(($id && $dn) && (($query ne $dn) || ($id != $oid)))
{
mylog(info=>"rbl_lookup: dropped: out:$query vs in:$dn, out:$oid vs in:$id") if $DEBUG;
$dropped = 1;
return(0) if $errcnt >= $DNS_RETRIES;
next; # wrong packet received, drop
}
mylog(warning=>"rbl_lookup: unknown error: out:$query, in:$dn, out-id:$oid, in-id:$id");
return(0) if $errcnt >= $DNS_RETRIES;
++$errcnt; # unknown error
}
mylog(warning=>'RBL Socket died, using Net-DNS now.');
$USE_NET_DNS = 1;
return(rbl_lookup(@bu)); # return Net::DNS result
}
sub conf_check
{
my $who = shift;
if($conf ne 'default settings')
{
my @conf_stat = stat($conf);
if( $conf_stat[9] != $old_mtime )
{
if(sprintf("%04o",$conf_stat[2]) !~ /(7|6|3|2)$/)
{
my $conf_str;
if(open(CONF, $conf))
{
read(CONF,$conf_str,-s CONF);
close(CONF);
#XXX taint $conf_str as $< enables taint mode
($conf_str) = $conf_str =~ m/(.*)/s;
eval $conf_str;
if($@)
{
mylog(warning=>"warning: $who: syntax error in file $conf: ".$@);
}
else
{
$old_mtime = $conf_stat[9];
ptime_conv();
mylog(info=>"$who: $conf reloaded");
}
}
else
{
mylog(warning=>"warning: $who: could not open $conf: $!");
}
}
else
{
mylog(warning=>"warning: $who: conf-err: $conf is world-writeable! Config not reloaded!");
}
}
}
}
sub create_lockpath
{
my $who = shift(@_);
if(!( -d $LOCKPATH))
{
mkdir $LOCKPATH or die "$who: error while creating $LOCKPATH: $!";
}
my $tuid = $USER;
if($USER =~ /[^0-9]/)
{
if( !(defined( $tuid = getpwnam($USER) ) ) )
{
mylog(warning=>"User $USER doesn't exist, create it, or set \$USER");
}
}
if( !(chown ($tuid, -1, $LOCKPATH)) )
{
mylog(warning=>
"$who: Couldn't chown $LOCKPATH to $USER ($tuid): $! - UID/EUID: $</$>");
}
if( !(chmod (0700, $LOCKPATH)) )
{
mylog(warning=>
"$who: Couldn't set permissions on $LOCKPATH for $USER ($tuid): $! - UID/EUID: $</$>");
}
}
# function for sanitizing floating point output
sub myrnd
{
my $n = index($_[0], ".");
if($n > 0)
{
$n-- if index($_[0], "-") >= 0;
return(sprintf("%.".($n+3)."g", $_[0]));
}
return($_[0]);
}
sub ptime_conv
{
# convert PTIME and TEMP_PTIME to seconds
my %time_conv;
$time_conv{'s'} = 1;
$time_conv{'m'} = 60;
$time_conv{'h'} = 3600;
$time_conv{'d'} = 86400;
my $time_unit;
if($PTIME =~ /.*?(\d+)([smhd]{0,1}).*/)
{
if(!($2)) { $time_unit = 's' }
else { $time_unit = $2 }
$my_PTIME = $1 * $time_conv{$time_unit};
}
else
{
mylog(warning=>"cache: warning: \$PTIME in wrong format. Using default.");
$my_PTIME = 10800; # 3 hours
}
if($TEMP_PTIME =~ /.*?(\d+)([smhd]{0,1}).*/)
{
if(!($2)) { $time_unit = 's' }
else { $time_unit = $2 }
$my_TEMP_PTIME = $1 * $time_conv{$time_unit};
}
else
{
mylog(warning=>"cache: warning: \$TEMP_PTIME in wrong format. Using default.");
$my_TEMP_PTIME = 259200; # 3 days
}
mylog(info=>"cache: PTIME: $my_PTIME, TEMP_PTIME: $my_TEMP_PTIME") if $DEBUG or $VERBOSE;
}
#
# Usage: dns_error(\$query_object, \$res_object)
#
# Returns undef in case of NOERROR or NXDOMAIN
# Returns 1 in all other cases
#
# This function expects references to objects of Net::DNS as arguments
sub dns_error
{
my ($myquery, $myres) = @_;
return 1 if not $$myquery;
return 1 if not $$myres;
return undef if $$myres->errorstring eq 'NOERROR' or
$$myres->errorstring eq 'NXDOMAIN';
mylog(debug=>"dns_error: errorstring: ".$$myres->errorstring) if $CMD_DEBUG;
return 1;
}
syntax highlighted by Code2HTML, v. 0.9.1