#!/usr/bin/perl

# Copyright 2005 Robert Felber (Autohaus Erich Kuttendreier, Munich)

# 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 Dec 22 15:35:59 CET 2005
# NAME:    policyd-weight
# VERSION: 0.1.12 beta-4
# URL:     http://www.policyd-weight.org/


use strict;

our $VERSION = "0.1.12 beta-4";

our $CMD_DEBUG = 0;
for(@ARGV)
{
    if($_ eq "-d")
    {
        $^W = 1;
        $CMD_DEBUG = 1;
        print "policyd-weight version: ".$VERSION."\nSystem: ";
        system("uname -a");
        print "Perl version: ".$]."\n";
    }
}


use Fcntl;
use Sys::Syslog qw(:DEFAULT setlogsock);
use Net::DNS;
use IO::Socket::UNIX;
use IO::Select;

if($CMD_DEBUG)
{
    print "Net::DNS version: ".Net::DNS->version."\n";
}
# don't let warnings confuse the SMTP, feed die() lines to syslog
#close(STDERR);
$SIG{__DIE__} = sub {
    mylog(warning=>sprintf("err: ".join(' ',@_)));
};

# ----------------------------------------------------------
#                configuration (defaults)
# ----------------------------------------------------------


# set defaults
# don't make changes here, instead use/create /etc/policyd-weight.conf
# NOTE: use perl syntax inclusive `;' in configuration files.

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 score above/equal
                     # REJECTLEVEL will be rejected

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

## score settings / configuration ##############################################
# I advice to don't use sorbs since they "make money" with
# spam. They want a fee of 50$ to unlist a listed host.
# And I also heard, that they list peoples which they don't like.


## DNSBL settings
my @dnsbl_score = (
#    HOST,                    BAD SCORE,  GOOD SCORE,   LOG NAME
    "dynablock.njabl.org",    3.25,          0,        "DYN_NJABL",
    "dnsbl.njabl.org",        4.25,       -1.5,        "BL_NJABL",
    "bl.spamcop.net",         2.75,       -1.5,        "SPAMCOP",
    "sbl-xbl.spamhaus.org",   4.35,       -1.5,        "SBL_XBL_SPAMHAUS",
    "list.dsbl.org",          4.35,          0,        "DSBL_ORG",
    "ix.dnsbl.manitu.net",    4.35,          0,        "IX_MANITU",
    "relays.ordb.org",        3.25,          0,        "ORDB_ORG"
);

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 = (
    "rhsbl.ahbl.org",              1.8,      0,        "AHBL",
    "dsn.rfc-ignorant.org",        2.8,      0,        "DSN_RFCI",
    "postmaster.rfc-ignorant.org", 1 ,       0,        "PM_RFCI",
    "abuse.rfc-ignorant.org",      1,        0,        "ABUSE_RFCI"
);




## cache stuff
my $SPATH = "/tmp/polw.sock";

my $MAXIDLECACHE = 60;      # how many seconds the cache may be idle
                            # before starting maintenance routines
                            # NOTE: standard maintenance jobs happen
                            # regardless of that setting.

my $MAINTENANCE_LEVEL = 5; # after this number of request do following
                            # maintenance jobs:
                            # checking for config changes

# negative (i.e. SPAM) result cache settings ##################################
my $CACHESIZE=120;      # set to 0 to disable caching for spam results. On this
                        # level the cache gets shrunked on cleanups

my $CACHEMAXSIZE=160;   # at this number of entries cleanup takes place

my $CACHEREJECTMSG="550 temporarily blocked because of previous errors";
my %cache;

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=120;       # set to 0 to disable caching of HAM. On this level
                            # the cache gets shrunked on cleanups

my $POSCACHEMAXSIZE=160;    # at this number of entries cleanup takes place

my $POSCACHEMSG="using cached result";
my %poscache;

my $PTTL = 20;  # after PTTL request the HAM entry is deletet from cache
                # and it must been reverified



## DNS settings
my $DNS_RETRIES    = 2;
my $DNS_RETRY_IVAL = 1;
my $MAXDNSERR      = 3; # max error count for unresponded queries
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


# scores for checks, WARNING: they may manipulate eachother
# or be factors for other scores.
#                                       Bad score, Good 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    );
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,          0    );
my @failed_helo_seems_dialup         = (2,          0    );
my @helo_ip_in_client_subnet         = (0,         -0.6  );
my @helo_ip_in_cl16_subnet           = (0,         -0.41 );
my @client_seems_dialup_score        = (3.75,       0    );
my @from_multiparted                 = (2.09,       0    );
my @from_anon                        = (3.21,       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";

#
# 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";

my $USER = "polw";

my $conf;
if( -f "/etc/policyd-weight.conf")
{
    $conf = "/etc/policyd-weight.conf";
}
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;
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);
            eval $conf_str;
            if($@)
            {
                $conf_err = "syntax error in file $conf: ".$@;
            }
        }
        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
}

use vars qw/$csock/;

if($CMD_DEBUG == 1)
{
    $conf_str =~ s/\#.*?(\n)/$1/gs;
    $conf_str =~ s/\n+/\n/g;
    print "config: $conf\n".$conf_str."\n"; 
    $SPATH .= ".debug";
}

$conf_str = "";

# ----------------------------------------------------------
#           minimal documentation
# ----------------------------------------------------------

#
# Usage: policyd-weight [-v]
#
# Demo delegated Postfix SMTPD policy server.
# This server implements the plugins: weighted_check.
# Another server implements greylisting.
# Postfix has a pluggable policy server architecture.
# You can call one or both from Postfix.
#
# This documentation assumes you have read Postfix's README_FILES/SMTPD_POLICY_README
#
# Logging is sent to syslogd.
#
# How it works: each time a Postfix SMTP server process is started
# it connects to the policy service socket, and Postfix runs one
# instance of this PERL script.  By default, a Postfix SMTP server
# process terminates after 100 seconds of idle time, or after serving
# 100 clients. Thus, the cost of starting this PERL script is smoothed
# out over time.
#
# To run this from /etc/postfix/master.cf:
#
#    policy  unix  -       n       n       -       -       spawn
#      user=nobody argv=/usr/bin/perl /usr/libexec/postfix/policyd-weight
#
# To use this from Postfix SMTPD, use in /etc/postfix/main.cf:
#
#    smtpd_recipient_restrictions =
#    ...
#    reject_unauth_destination
#    check_policy_service unix:private/policy
#    ...
#
# NOTE: specify check_policy_service AFTER reject_unauth_destination
# or else your system can become an open relay.
#
# To test this script by hand, execute:
#
#    % perl policyd-weight
#
# Each query is a bunch of attributes. Order does not matter, and
# the demo script uses only a few of all the attributes shown below:
#
#    request=smtpd_access_policy
#    protocol_state=RCPT
#    protocol_name=SMTP
#    helo_name=some.domain.tld
#    queue_id=8045F2AB23
#    sender=foo@bar.tld
#    recipient=bar@foo.tld
#    client_address=1.2.3.4
#    client_name=another.domain.tld
#    [empty line]
#
# The policy server script will answer in the same style, with an
# attribute list followed by a empty line:
#
#    action=dunno
#    [empty line]
#

# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: client_address=208.210.125.227
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: client_name=newbabe.mengwong.com
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: helo_name=newbabe.mengwong.com
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: protocol_name=ESMTP
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: protocol_state=RCPT
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: queue_id=
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: recipient=mengwong@dumbo.pobox.com
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: request=smtpd_access_policy
# Jul 23 18:43:29 dumbo/dumbo policyd[21171]: Attribute: sender=mengwong@newbabe.mengwong.com

# ----------------------------------------------------------
#                initialization
# ----------------------------------------------------------

#
# Log an error and abort.
#
sub fatal_exit {
  mylog(err  => "fatal_exit: @_");
  mylog(warning => "fatal_exit: @_");
  mylog(info => "fatal_exit: @_");
  die "fatal: @_";
}

#
# Unbuffer standard output.
#
select((select(STDOUT), $| = 1)[0]);

#
# 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;
    openlog $syslog_ident, $syslog_options, $syslog_facility;
}


if($VERBOSE == 1)
{
    mylog(debug=>sprintf("startup: using $conf"));
}

my $RETANSW;
if($ADD_X_HEADER == 1)
{
    $RETANSW = "PREPEND X-policyd-weight:";
}
else
{
    $RETANSW = "DUNNO ";
}
if($conf_err)
{
    mylog(warning=>sprintf("warning: conf-err: ".$conf_err));
    mylog(warning=>sprintf("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;


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

#
# Receive a bunch of attributes, evaluate the policy, send the result.
#

our $accepted = "UNDEF";
my %attr;
while (<STDIN>)
{
    chomp;
    if (/=/) { my ($k, $v) = split (/=/, $_, 2); $attr{$k} = $v; next }
    elsif (length)
    {
        mylog(warning=>sprintf("warning: ignoring garbage: %.100s", $_));
        next;
    }

    if ($VERBOSE == 1)
    {
        for (sort keys %attr)
        {
            mylog(debug=> "Attribute: %s=%s", $_, $attr{$_});
        }
    }

    fatal_exit ("unrecognized request type: '$attr{request}'") unless $attr{request} eq "smtpd_access_policy";

    my $action;
    my $response;

    $action = $DEFAULT_RESPONSE;

    no strict 'refs';
    $response = weighted_check->(attr=>\%attr);
    if ($response) {
      #syslog(info=> "handler %s: %s is decisive.", $handler, $response);
      $action = $response;
    }
    else
    {
        mylog(warning=>"weighted_check returned a zero value!");
    }
    mylog(info=>"decided action=%s", $action);

    print STDOUT "action=$action\n\n";
    %attr = ();
}

sub address_stripped {
  # my $foo = localpart_lhs('foo+bar@baz.com'); # returns 'foo@baz.com'
  my $string = shift;
  for ($string) {
    s/[+-].*\@/\@/;
  }
  return $string;
}


#------------------------------------------------------------------------------
#        Plugin: weighted_check
#------------------------------------------------------------------------------
sub weighted_check
{
    local %_ = @_;
    my %attr = %{ $_{attr} };

    my $ip          = $attr{client_address};
    my $instance    = $attr{instance};


    if(index($ip,":") != -1)
    { return ("DUNNO IPv6"); } # we have no IPv6 support
                               # for now
    my $client_name = $attr{client_name};
    my $helo        = lc($attr{helo_name});
    my $from        = lc(address_stripped($attr{sender}));
    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(($attr{instance}) && ($attr{instance} eq $accepted))
    {
        return ("DUNNO multirecipient-mail - already accepted by previous query");
    }
## negative cache check
    if(($CACHESIZE > 0) && (my $ret = cache_query("nask", $ip, $orig_from)))
    {
        return("$ret");
    }

## 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;
    my $mx_ok = 0;
    my $helo_untrusted_ok;
    my $RET;
    my $do_client_from_check;
    my $client_seems_dialup;
    my $in_dyn_bl;
    my $helo_seems_dialup;

    my $maxdnserr = $MAXDNSERR;

    my $RELAYMSG = "";

## DNSBL check ################################################################
    my $i;
    my $found;
    my $dnsbl_hits = 0;

    for($i=0;$i < @dnsbl_score; $i += 4)
    {
        $found = 0;
        my $answ = $res->send($revip.".".$dnsbl_score[$i], 'TXT');
        if(!($answ))
        {
            if($maxdnserr-- <= 1)
            {
                $accepted = $instance;
                return "$RETANSW $MAXDNSERRMSG in ".$dnsbl_score[$i]." lookups";
            }
            next;
        }
        foreach ($answ->answer)
        {
            $RET .= " IN_".$dnsbl_score[$i+3]."=".$dnsbl_score[$i+1];
            $found = 1;
            $rate = $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;
            }
            last;
        }

        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 = $rate + $dnsbl_score[$i+2];
        }
        else
        {
            if((++$dnsbl_hits > $MAXDNSBLHITS) ||
                ($total_dnsbl_score > $MAXDNSBLSCORE))
            {
                if($CACHESIZE > 0)
                {
                    cache_query("nadd", $ip, $orig_from);
                }
                return($MAXDNSBLMSG."; check http://rbls.org/?q=".$ip);
            }
        }
    }

    if($dnsbl_checks_only == 1)
    {
        return("DUNNO only DNSBL check requested");
    }

## postive cache check
    if(($POSCACHESIZE > 0) && ($dnsbl_hits < 1))
    {
        my $cansw = cache_query("pask", $ip, $from_domain);
        if($cansw)
        {
            $accepted = $instance;
            return("$RETANSW $POSCACHEMSG; $cansw");
        }
    }


## HELO check #################################################################
    my $found;
    my $is_mx;
    my @helo_parts = split(/\./,$helo);
    my $recs_found;
    my $addresses;
    my $from_addresses;
    my $dnserr = 0;
    my $MATCH_TYPE;

    $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(!($query))
            {
                if($maxdnserr-- <= 1)
                {
                    $accepted = $instance;
                    return("$RETANSW $MAXDNSERRMSG in $MATCH_TYPE MX lookups for $testhelo");
                }
                next;

            }
            if($query)
            {
                $recs_found = 1;
                foreach my $rr ($query->answer)
                {
                    if($rr->type eq "MX")
                    {
                        my $mxres = $res->send($rr->exchange);
                        if(!($mxres))
                        {
                            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";
                            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 = $rate + $helo_from_mx_eq_ip_score[1];
                                last;
                            }
                        }
                    }
                    last if $found;
                }

                if(!($found))
                {
                    my $query = $res->send($testhelo, 'A');
                    if(!($query))
                    {
                        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];
                            last;
                        }
                    }
                }
                last if $found;
            }
            last if $found;
        }
        last if $found;
    }
    if($found != 1 && $recs_found == 1) # 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;
            $found = 1;
        }
        if($found != 1 && $helo_ok != 1)
        {
            $RET .= " CL_IP_NE_HELO=".$helo_score[0];
            $helo_ok = 2;
            $rate += $helo_score[0];
        }
    }
    elsif($found != 1) # probably DNS error
    {
        $RET .= " NO_MX_A_RECS_FOUND=".($helo_score[0]-0.1);
        $rate += ($helo_score[0]-0.1);
        $helo_ok = 2;
    }

## Reverse IP == dynhost check ###############################################

    my $ip_res = $res->send("$ip");
    my @reverse_ips;
    if($ip_res)
    {
        foreach my $tmprr ($ip_res->answer)
        {
            if($tmprr->type eq "PTR")
            {
                my $tmpptr = $tmprr->ptrdname;
                $tmpptr =~ s/\.$//;
                push(@reverse_ips, $tmpptr);
            }
        }
    }

    if((!($client_seems_dialup)) && ($mx_ok != 1))
    {
        foreach my $revhost (@reverse_ips)
        {
            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;
                $dnsbl_hits++;
                $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 ###################################################
    my $found;
    my $rev_processed;

    if($helo_ok != 1 && $helo_untrusted_ok != 1)
    {
        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 = $rate + $client_ip_eq_helo_score[1];
                last;
            }
            my $partsfound;
            my $tmprevhost = reverse($revhost);
            my $tmphelo = reverse($helo);
            $tmphelo =~ s/.*?\.([^.]+).*/$1/;
            if(    ($tmprevhost =~ /\.$tmphelo$/i ) ||
                ($tmprevhost =~ /\.$tmphelo\./i)
              )
            {
                $partsfound = 1;
            }
            if($partsfound != 1)
            {
                my $tmphelo = reverse($helo);
                $tmprevhost =~ s/.*?\.([^.]+).*/$1/;
                if(    ($tmphelo =~ /\.$tmprevhost$/i ) ||
                    ($tmphelo =~ /\.$tmprevhost\./i)
                  )
                {
                    $partsfound = 1;
                }
            }

            if($partsfound == 1)
            {
                $found = 1;
                $RET .= " REV_IP_EQ_HELO_DOMAIN=".$client_ip_eq_helo_score[1];
                $rate = $rate + $client_ip_eq_helo_score[1];
                last;
            }
        }

        if($rev_processed != 1 && $recs_found != 1)
        {
            $RET .= " NO_DNS_RECORDS=0.5";
            $rate = $rate + 0.5;
            $dnserr = 1;
        }

        if($found != 1)
        {
            $RET .= " RESOLVED_IP_IS_NOT_HELO=".$client_ip_eq_helo_score[0];
            $rate = $rate + $client_ip_eq_helo_score[0];
        }
        else
        {
            $helo_untrusted_ok = 1;
        }
    }

## HELO numeric check #########################################################
    if($helo =~ /\d$/)
    {
        $RET .= " HELO_NUMERIC=".$helo_numeric_score[0];
        $rate = $rate + $helo_numeric_score[0];
    }


## HELO dialup check ##########################################################

    if( (($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!
        ) &&
        ($client_seems_dialup != 1)
      )
    {
        $helo_seems_dialup = 1;
        if($helo_ok == 1)
        {
            $RET .= " HELO_SEEMS_DIALUP=".$helo_seems_dialup[0];
            $rate = $rate + $helo_seems_dialup[0];
            $dnsbl_hits++;
            $total_dnsbl_score++;
        }
        else
        {
            $RET .= " NOK_HELO_SEEMS_DIALUP=".$failed_helo_seems_dialup[0];
            $rate = $rate + $failed_helo_seems_dialup[0];
            $dnsbl_hits = $dnsbl_hits + 2;
            $total_dnsbl_score = $dnsbl_hits + 2;
        }
    }


## From has nobody/anonymous user #############################################
    my $anon;
    if($orig_from =~ /(nobody|anonymous)\@/)
    {
        $RET .= " FROM_NBDY_ANON=".($from_anon[0] + $total_dnsbl_score);
        $rate += ($from_anon[0] + $total_dnsbl_score);
        $total_dnsbl_score += $from_anon[0];
        $anon = 1;
    }

## FROM Domain vs HELO regex check ############################################
    if(!($is_mx))
    {
        $from =~ s/.*@//;
        $from =~ s/\.[^.]{2,5}$//;
        $from =~ s/.*?\.(.*?\.+)/$1/;
        my $tmphelo = $helo;
        $tmphelo =~ s/\.[^.]{2,5}$//;
        $tmphelo =~ s/.*?\.(.*?\.+)/$1/;

        $from    = ".".$from.".";       # delimit comparisions, this
        $tmphelo = ".".$tmphelo.".";    # all needs further reviews
        
        $RET .= " (check from: $from - helo: $tmphelo) ";
        # check trusted helos
        if(( (index($tmphelo,$from) != -1)  || 
             (index($from,$tmphelo) != -1)) && 
           ($helo_ok == 1))
        {
            $RET .= " FROM_MATCHES_HELO=".$from_match_regex_verified_helo[1];
            $rate = $rate + $from_match_regex_verified_helo[1];
        }
        elsif(( (index($tmphelo,$from) == -1)  || 
                (index($from,$tmphelo) == -1)) && 
              ($helo_ok == 1))
        {
            $RET .= " FROM_MATCHES_NOT_HELO=".
             ($from_match_regex_verified_helo[0] + $total_dnsbl_score);
            $rate = $rate + $from_match_regex_verified_helo[0] + ($total_dnsbl_score/2);
            $do_client_from_check = 1;
        }



        # check untrusted helos
        elsif(( (index($tmphelo,$from) != -1)  || 
                (index($from,$tmphelo) != -1)) && 
              ($helo_untrusted_ok == 1))
        {
            $RET .= " FROM_MATCHES_UNVR_HELO=".$from_match_regex_unverified_helo[1];
            $rate += $from_match_regex_unverified_helo[1];
        }

        elsif(( (index($tmphelo,$from) == -1)  || 
                (index($from,$tmphelo) == -1)) && 
              ($helo_untrusted_ok == 1))
        {
            $RET .= " FROM_MATCHES_NOT_UNVR_HELO=".
                ($from_match_regex_unverified_helo[0] + $total_dnsbl_score);
            $rate += $from_match_regex_unverified_helo[0] + $total_dnsbl_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 = $rate + $from_match_regex_failed_helo[0];
        }

        elsif(index($tmphelo,$from) == -1 || index($from,$tmphelo) == -1)
        {
            $RET .= " FROM_NOT_FAILED_HELO=".
                ($from_match_regex_failed_helo[0] + 0.5 + $total_dnsbl_score);
            $rate += ($from_match_regex_failed_helo[0] + 0.5 + $total_dnsbl_score);
        }
    }

## client == MX/A FROM domain #################################################

    if( ($do_client_from_check) && 
        ($helo_seems_dialup || $in_dyn_bl) && 
        ($mx_ok != 1)
      )
    {
        if( index($from_addresses, $ip) == -1 )
        {
            $RELAYMSG = "; please relay via your ISP ($from_domain)";
            $RET .= " CLIENT_NOT_MX/A_FROM_DOMAIN=".
                ($helo_from_mx_eq_ip_score[0] + $total_dnsbl_score);
            $rate += ($helo_from_mx_eq_ip_score[0] + $total_dnsbl_score);

            if( index($from_addresses, $subip) == -1 )
            {
                $RET .= " CLIENT/24_NOT_MX/A_FROM_DOMAIN=".
                    ($helo_from_mx_eq_ip_score[0] + $total_dnsbl_score);
                $rate += ($helo_from_mx_eq_ip_score[0] + $total_dnsbl_score);
            }
        }
    }

## From domain multiparted check ##############################################
    if(($orig_from =~ /\@.*?\..*?\./) && (!($is_mx)))
    {
        $RET .= " FROM_MULTIPARTED=".($from_multiparted[0] + $total_dnsbl_score);
        $rate += ($from_multiparted[0] + $total_dnsbl_score);
    }

## rhsbl check ################################################################
    my $in_rhsbl;
    my $RHSBLMSG = "";

    if($rate < $REJECTLEVEL)
    {
        $orig_from =~ /@(.*)/;
        my $query = $1;

        for($i=0;$i < @rhsbl_score; $i += 4)
        {
            my $answer = $res->send($query.".".$rhsbl_score[$i]);
            if(!($answer))
            {
                if($maxdnserr-- <= 1)
                {
                    $accepted = $instance;
                    return ("$RETANSW $MAXDNSERRMSG in ".$rhsbl_score[$i]." lookups");
                }
                next;
            }
            foreach my $answ ($answer->answer)
            {
                if(($do_client_from_check == 1) || ($helo_untrusted_ok == 1))
                { $total_dnsbl_score += 3.3 }
                $RET .= " IN_".$rhsbl_score[$i+3]."=".
                        ($rhsbl_score[$i+1] + $total_dnsbl_score);
                $rate += ($rhsbl_score[$i+1] + $total_dnsbl_score);
                $in_rhsbl = 1;
                $RHSBLMSG = "; listed in ".$rhsbl_score[$i];
                last;
            }
            last if $in_rhsbl;
        }
    }

###############################################################################
    $RET .= " <client=$ip> <helo=$helo> <from=$orig_from>";
    if(($DEBUG) || ($CMD_DEBUG == 1))
    {
        $addresses =~ s/ $//;
        $RET .= " <helo_ips: $addresses>";
    }

    mylog(info=>"weighted check: %s, rate: %s",$RET, $rate);

    if(($dnserr == 1) && ($dnsbl_hits < 2))         # applies if not too
    {                                               # much dnsbl listed
        $DNSERRMSG .= " Your HELO: $helo, IP: $ip";
        return($DNSERRMSG);
    }
    if($rate >= $REJECTLEVEL)
    {
        if(($CACHESIZE > 0) && ($MAXDNSERR == $maxdnserr))
        {
            cache_query("nadd", $ip, $orig_from, $rate);
        }
        if(($helo_ok != 1) && ($helo_untrusted_ok != 1))
        {
            my $EREJECTMSG = $REJECTMSG .
                    "; MTA helo: $helo, MTA hostname: " .
                    $client_name."[".$ip."] (helo/hostname mismatch)";
            return($EREJECTMSG.$RHSBLMSG.$RELAYMSG);
        }
        return($REJECTMSG.$RHSBLMSG.$RELAYMSG);
    }
    else
    {
        if(($POSCACHESIZE > 0) && ($dnsbl_hits < 1))
        {
            cache_query("padd", $ip, $from_domain, $rate);
        }
        $accepted = $instance;
        return("$RETANSW $RET, rate: $rate");
    }
}

###############################################################################
## subroutines ################################################################


### cache stuff ###############################################################

sub cache_query
{
    if($csock)
    {
        if(!($csock->connected))
        {
            $csock = IO::Socket::UNIX->new($SPATH) || spawn_cache() ;
        }
    }
    else
    {
         $csock = IO::Socket::UNIX->new($SPATH) || spawn_cache() ;
    }
    if($csock)
    {
        my $query = shift(@_);
        my $ip = shift(@_);
        my $sender = shift(@_);
        my $rate = shift(@_);
        if(!($rate)) { $rate = "" }
        my $buf;
        autoflush $csock 1;
        print $csock "$query $ip $sender $rate\n";
        $buf = <$csock>;
        $buf =~ s/(\r|\n)//g;
        if($buf ne "0")
        {
            return($buf);
        }
        return(undef);
    }
    mylog(info=>"could not connect to cache");
    return(undef);
}

sub spawn_cache
{
    my $rname = getpwuid($<);
    if($rname  ne $USER)
    {
        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);
    }
    unlink $SPATH;
    use POSIX qw(setsid);

    defined(my $pid = fork) or die "cache: fork: $!";
    return(undef) if $pid;

    setsid                  or die "cache: setsid: $!";

    mylog(info=>"cache spawned");
    our $old_prg_name = $0;
    $0 = "policyd-weight (cache)";

    if($CMD_DEBUG != 1)
    {
        close(STDIN);
        close(STDOUT);
        close(STDERR);
        open (STDIN, "/dev/null");
        open (SDTOUT, ">/dev/null");
        open (STDERR, ">/dev/null");
    }
    $SIG{__DIE__} = sub {
        mylog(warning=>sprintf("cache: err: ".join(' ',@_)));
        unlink $SPATH;
    };
    $SIG{'TERM'} = sub {
        unlink $SPATH;
        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) || die $!;

    chown($<, $(, $SPATH); # set correct socket owner and group
    
    $readable_handles->add($lsock);

    my $new_readable;
    my $i;
    my $KILL;
    $| = 1;
    our $poscache_cnt = 0;
    our $cache_cnt = 0;
    my $old_mtime;
    if($conf ne "default settings")
    {
        $old_mtime = (stat($conf))[9];
    }
    our $old_prg_mtime = (stat($old_prg_name))[9];
    our $maintenance = 0;
    our $FORCE_MAINT;

    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();
                autoflush $new_sock 1;
                $readable_handles->add($new_sock);
            }
            else
            {
                    autoflush $sock 1;
                    my $buf = <$sock>;
                    $buf =~ s/(\r|\n)//g if $buf;
                    if($buf)
                    {
                        my $time = time;
                        my $ret = "" ;  # this var will hold the returned
                                        # result for the client if not told
                                        # within the routines
                        my($query, $ip, $sender, $rate) = split(/ /, lc($buf));
                        my $ckey = $ip."-".$sender;
                        if($query eq "pask")
                        {
                            if($poscache{$ckey})
                            {
                                if($poscache{$ckey}[1] <= 0)
                                { # PTTL reached, delete entry, give answer
                                    $ret = "0";
                                    --$poscache_cnt;
                                    delete($poscache{$ckey});
                                    mylog(info=>"cache: deleted $ckey from HAM cache");
                                }
                                else
                                { # refresh timestamp and decrease PTTL counter
                                    $ret = "rate: ".$poscache{$ckey}[0];
                                    $poscache{$ckey}[2] = $time;
                                    $poscache{$ckey}[1] -= 1;
                                 }
                            }
                            else
                            {
                                $ret = "0";
                            }
                        }
                        elsif($query eq "nask")
                        {
                            if($cache{$ckey})
                            {
                                my $tdiff = $time - $cache{$ckey}[2];
                                if( ($cache{$ckey}[1] <= 0) &&
                                    ($tdiff > $NTIME)
                                  )
                                {
                                    $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;
                                }
                            }
                            else
                            {
                                $ret = "0";
                            }
                        }
                        elsif($query eq "padd")
                        {
                            ++$poscache_cnt unless $poscache{$ckey};
                            $poscache{$ckey}[0] = $rate;
                            $poscache{$ckey}[1] = $PTTL;
                            $poscache{$ckey}[2] = $time;
                            ++$maintenance;
                        }
                        elsif($query eq "nadd")
                        {
                            ++$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 .= "\nEOF";
                        }
                        elsif($query eq "reload")
                        {
                            $FORCE_MAINT = 1;
                        }
                        elsif($query eq "kill")
                        {
                            $KILL = 1;
                        }
                        else
                        {
                            $ret = "unknown cache request: $buf\nEOF";
                        }
                        print $sock $ret."\n";
                    }
                    else
                    {
                        $readable_handles->remove($sock);
                        close($sock);
                    }
            }
        }

        ## kill the cache
        if(($KILL) || (($FORCE_MAINT) && ($CMD_DEBUG)))
        {
            mylog(info=>"cache killed");
            close($lsock);
            unlink $SPATH;
            exit(0);
        }

        if( ($maintenance >= $MAINTENANCE_LEVEL) || ($FORCE_MAINT == 1) )
        {
            $maintenance = 0;

            if( (stat($old_prg_name))[9] != $old_prg_mtime)
            {
                mylog(info=>"cache: new version detected, restarting cache");
                close($lsock);
                unlink($SPATH);
                exit(0);
            }
            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);
                            eval $conf_str;
                            if($@)
                            {
                                mylog(warning=>"warning: cache: syntax error in file $conf: ".$@);
                            }
                            else
                            {
                                $old_mtime = $conf_stat[9];
                                mylog(info=>"cache: $conf reloaded");
                            }
                            my $conf_str; # set to zero, don't waste mem
                        }
                        else
                        {
                            mylog(warning=>"warning: cache: could not open $conf: $!");
                        }
                    }
                    else
                    {
                        mylog(warning=>"warning: cache: conf-err: $conf is world-writeable! Config not reloaded!");
                    }
                }
            }
        }
        ## clean up cache
        if($poscache_cnt > $POSCACHEMAXSIZE) 
        {
            my $purgecnt = 0;
            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 %s from HAM cache", $purgecnt);
            }
        }
        if($cache_cnt > $CACHEMAXSIZE)
        {
            my $purgecnt = 0;
            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 %s from SPAM cache", $purgecnt);
            }
        }
    }
}

sub mylog
{
    if($CMD_DEBUG)
    {
        my $fac = shift(@_);
        my $string = shift(@_);
        printf("$fac: $string", @_);
        print "\n";
    }
    else
    {
        syslog(@_);
    }
}
