#!/usr/bin/perl

use strict;
use Net::DNS;

use Sys::Syslog qw(:DEFAULT setlogsock);

my $version = "0.9";

#
# Usage: shadelist.pl [[-v], ...] [-np] [-nd] [-a restriction] 
#                     [[-b blacklist], ...] [[-w whitelist], ...]
#
# Simple delegated Postfix SMTPD policy server. This server implements
# DNS-based white- and blacklisting. Client IP's are looked up in one or 
# more lists. 
#
# You can specify any number of whitelists and any number of blacklists
# and you can combine those with greylisting to get any shade between
# black and white (which is why this program is called shadelist).
#
# Please note that DNS-based access restrictions have many controversial
# issues and the topic invariably brings up vehement debate on the Postfix
# users list. You'll have to decide for yourself if shadelist can help you.
# Every mail admin's situation is different, there is no one-size-fits-all
# solution. If this policy server is useful to you, use it. If not, don't.
#
# Basic operation
# ---------------
#
# This policy server can operate in two basic modes, whitelist mode and 
# blacklist mode.
#
# In "whitelist mode" (at least one whitelist specified and no blacklists)
# the policy server returns 'OK' if the client's IP is listed on any
# of the whitelists, 'DUNNO' otherwise. The 'OK' answer can be overridden 
# with the -a switch.
#
# In "blacklist mode" (at least one blacklist specified) the answer is
# 'REJECT' if the client is listed, 'DUNNO' otherwise. The 'REJECT' answer 
# can be overridden with the -a switch, more on that later.
#
#
# Pure blacklist mode (only blacklists, no whitelists, no -a switch)
# is not very useful by itself, as Postfix handles this much better
# with its built-in 'reject_rbl_client' restriction. However there are
# two variations of 'blacklist mode' that may be useful:
#
# In 'mitigated blacklist mode', one or more whitelists can be used to
# neutralize the 'reject' answer for a blacklisted IP. That is, the answer
# will only be 'reject' if the client is blacklisted but not whitelisted.
# If the client is both blacklisted and whitelisted, the answer is 'prepend'
# to add an X-Whitelist header to the mail message (unless the -np option
# is given). Otherwise, the answer is 'dunno'.
# 
# Mitigated blacklist mode can be useful if you want to apply the whitelist 
# only to selected blacklists and not to others. Otherwise it's better to 
# use pure 'whitelist mode' and specify the blacklists in your Postfix 
# main.cf as usual.
#
#
# Another variation of 'pure' blacklist mode is to override the 'reject' answer
# with the -a switch. This can be useful to apply greylisting to selected
# RBL's, i.e. greylist the 'black clients' instead of rejecting them 
# out of hand. An example is a blacklist that lists dial-up IP's. Mail from 
# these is often from virus-infected home users but there are also some
# legitimate mail servers that (have to) make do with a dynamic IP. Greylisting
# will (today) stop the viruses while (maybe) allowing the real mail in.
# 
#
# DNS error handling
# ------------------
#
# DNS is inherently unreliable, and using it for whitelisting can be
# dangerous. This policy server attempts to minimize the risk by returning
# "defer" actions in case of DNS failures, as follows:
#
#    DEFER_IF_REJECT if the error uccurs during whitelist lookup,
#    DEFER_IF_PERMIT if the error uccurs during blacklist lookup.
#
# This will (should) make the client retry later, with the hope that the
# DNS server will be back up by that time.
#
# If you want, you can disable this behaviour with the -nd (no defer) switch.
# If you do, the policy server will pretend that the lookup succeeded but 
# yielded a 'not listed' result. Blacklisted clients may get in and whitelisted
# clients may be rejected. You have been warned.
#
#
# Command line switches
# ---------------------
#
# -w whitelist	The name of a DNS-based whitelist. 
#		This option can be specified multiple times.
#
# -b blacklist 	The name of a DNS-based blacklist (RBL).
#		Probably only useful in combination with -w and/or -a.
#		This option can be specified multiple times.
#
# -a name	Answer with this name in case of a hit. The 'name' must
#		be the name of a valid Postfix restriction (man 5 access).
#		It replaces the standard answers 'ok' (in
#		whitelist mode) and 'reject' (in blacklist mode).
#		Useful to apply greylisting on blacklisted clients.
#
# -np 	   	Do not add an 'X-Whitelist' header to a mail message that
#		was allowed in because the blacklisting of the client was 
#		overridden by a whitelist. This is useful for diagnostic 
#		purposes, but it can be disabled with this "no prepend" switch.
#
# -nd		Do not defer messages in case of a DNS failure.
#		This is probably not a good idea.
#
# -v		Verbose.
#		This option can be specified multiple times to increase
#		verbosity. Useful if you want to impress your friends with 
#		the size of your log files.
#
# These options can be combined into many useful and many insane combinations.
# They can be given in any order.
#
# Some examples of use are given on the policy server's home page (address 
# given below).
#
#
# Implementation
# --------------
#
# 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.
#
#
# Prerequisites
# -------------
#
# You will need perl and the perl module Net::DNS. And postfix.
#
#
# Configuration
# -------------
#
# To run this from /etc/postfix/master.cf:
#
#    shadelist  unix  -       n       n       -       -       spawn
#      user=nobody argv=/usr/bin/perl /usr/libexec/postfix/shadelist.pl
#                       -b blacklist.example.com -w whitelist.example.com
#
# To use this from Postfix SMTPD, use in /etc/postfix/main.cf:
#
#    smtpd_recipient_restrictions =
#	...
#	reject_unauth_destination
#	check_policy_service unix:private/shadelist
#	...
#
# NOTE: specify check_policy_service AFTER reject_unauth_destination
# or else your system can become an open relay.
#
# You can have multiple instances of shadelist, each with its own service name
# and with different switches.
#
# To use the -a switch for greylisting, you may use the following in
# main.cf:
#
#   smtpd_restriction_classes = 
#	...
#	my_greylist,
#	...
#
#   my_greylist = check_policy_service inet:127.0.0.1:10028
#
# This is just an example, refer to your greylisting program's
# installation instructions for the actual contents of the 
# check_policy_service entry and the corresponding master.cf stuff, if any.
#
# Of course you'll also have to add "-a my_greylist" (without quotes) to 
# the "shadelist" master.cf entry given above.
# 
#
# Testing
# -------
#
# To test this script by hand, execute:
#
#    % perl shadelist.pl
#
# Each query is a bunch of attributes. Order does not matter.
# This policy server uses only a few of all the attributes that Postfix's
# policy server architecture defines, as follows:
#
#    request=smtpd_access_policy
#    client_address=1.2.3.4
#    [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]
#
# You can put one or more such queries in a text file and execute:
#
#    % cat queries.txt | perl shadelist.pl
#
# Remember that the output of -v goes to syslog, not to the console.
# In most cases, you'll have to look in /var/log/maillog to see what it's 
# saying.
#
# For testing purposes, most DNS-based black/whitelists do have one or more 
# IP's that always produce a 'listed' result. In many cases, one such IP is 
# 127.0.0.2. Consult the list's website for details.
# 
# 
# Copyright and License
# ---------------------
# (c) 2006, Luc Pardon, Skopos Consulting, Belgium (lucp@skopos.be).
#
# You are free to use this program (at your own risk) as is or to modify it.
#
# Yoy may also distribute it, provided that you do not make money out of the
# distribution and provided that this copyright and license notice remains 
# intact and effective.
#
# The offical home page of this program is as follows:
#
#    http://www.skopos.be/downloads/postfix/shadelist.html
#
# You are requested to not post this program on a public website as long as
# its official home page remains operational. This is purely to be able to 
# judge interest by the number of downloads.
#
# Feel free to contact the author if you want to discuss other terms of use.
#
# If you make any changes that may be useful to others, please inform the
# author so that they can be incorporated into a next release.
#
# 
# Changelog:
# ---------
# Version 0.9:	Initial release (07 Feb 2006)
#
# =========================================================================


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

#
# The DNS resolver and other variables
#
my $res = Net::DNS::Resolver->new;

my $verbose = 0;
my $defer = 1;
my $prepend = 1;
my $action_override;

my @whitelist;
my @blacklist;
my %attr;

#
# The DNS lookup routine.
# Returns the IP address listed in the DNSBL (e.g. 127.0.0.2) or
# nothing.
#
sub lookup
{
    my ($addr, @server) = @_;


    foreach ( @server ) {
    	my $fqdn = "$addr\.$_";
	my $ns_req = $res->send($fqdn, 'A');
    	if (not defined($ns_req))
    	{
	   my $msg = "error looking up $fqdn: $!";
    	   syslog $syslog_priority, "%s", $msg;
           return  $msg;
        }
        if ($ns_req->header->ancount <= 0)
        {
    	   syslog $syslog_priority, "%s not listed", $fqdn if $verbose > 0;
           next;
        }
    	syslog $syslog_priority, "%s is listed", $fqdn if $verbose > 0;
        my $name;
        foreach my $nsrr (grep { $_->type eq "A" } $ns_req->answer)
        {
            $name = $nsrr->name;
        }
	$ns_req = $res->send($fqdn, 'TXT');
        if ($ns_req and $ns_req->header->ancount > 0)
        {
           foreach my $nsrr (grep { $_->type eq "TXT" } $ns_req->answer)
           {
               return $nsrr->txtdata;
           }
        }
        return $name;
    }
}
#
# SMTPD access policy routine. The result is an action just like
# it would be specified on the right-hand side of a Postfix access
# table.  Request attributes are available via the %attr hash.
#
sub smtpd_access_policy 
{
    # The result can be any action that is allowed in a Postfix access(5) map.
    #
    # Since this is a whitelist, we return OK if the client is
    # listed, DUNNO if it is not listed in the RBL.
    # The OK response can be overridden with the -a option.
    #
    # In "mitigated blacklist" mode, we return REJECT if the client is
    # blacklisted but not whitelisted. If it is blacklisted AND whitelisted
    # we return a 'prepend' action (unless disabled with -np). In all other 
    # cases, return DUNNO. 
    # The REJECT response can be overridden with the -a option.
    #
    # In case of a DNS error, return a DEFER_ action: 
    #    DEFER_IF_REJECT if the error uccurs during whitelist lookup,
    #    DEFER_IF_PERMIT if the error uccurs during blacklist lookup.
    #

    my $ip = $attr{"client_address"};
    my ($p1, $p2, $p3, $p4) = split(/\./, $ip);

    my $good_reply = "ok";
    if ($action_override) {
	$good_reply = $action_override;
    }
    my $bad_reply = "dunno";
    my $raddr = "$p4\.$p3\.$p2\.$p1";
    if (@blacklist)
    {
	my $a = lookup($raddr, @blacklist);
        if ($a =~ /^error(.*)/ ) {
           if ($defer) {
	      return "defer_if_permit Blacklist service is unavailable: $a";
           } else {
	      return $good_reply;
           }
        }

        return "dunno" unless $a;

	$good_reply = "dunno";
        if ($prepend) {
	    $good_reply = "prepend X-Whitelist: $a";
        }
	$bad_reply = "reject $a";
        if ($action_override) {
	   $bad_reply = $action_override;
        }
    }
    my $a = lookup($raddr, @whitelist);
    if ($a =~ /^error(.*)/ ) {
        if ($defer) {
	   return "defer_if_reject Whitelist service is unavailable";
        } else {
           return $bad_reply;
        }
    }
    return $bad_reply unless $a;
    return $good_reply;
}

#
# You should not have to make changes below this point.
#
sub LOCK_SH { 1 };	# Shared lock (used for reading).
sub LOCK_EX { 2 };	# Exclusive lock (used for writing).
sub LOCK_NB { 4 };	# Don't block (for testing).
sub LOCK_UN { 8 };	# Release lock.

#
# Log an error and abort.
#
sub fatal_exit {
    my($first) = shift(@_);
    syslog "err", "fatal: $first", @_;
    exit 1;
}


#
# This process runs as a daemon, so it can't log to a terminal. Use
# syslog so that people can actually see our messages.
#
setlogsock $syslog_socktype;
openlog $0, $syslog_options, $syslog_facility;

#
# We don't need getopt() for now.
#
while (my $option = shift(@ARGV)) {
    if ($option eq "-v") {
	$verbose = $verbose + 1;
    } elsif ($option eq "-nd") {
	$defer = 0;
    } elsif ($option eq "-np") {
	$prepend = 0;
    } elsif ($option eq "-a") {
	$action_override = shift(@ARGV);
    } elsif ($option eq "-b") {
        push @blacklist, shift(@ARGV);
    } elsif ($option eq "-w") {
        push @whitelist, shift(@ARGV);
    } else {
	syslog $syslog_priority, "Invalid option: %s. Usage: %s [[-v], ...] [-np] [-nd] [-a restriction] [[-b blacklist], ...] [[-w whitelist], ...]",
		$option, $0;
	exit 1;
    }
}

syslog $syslog_priority, "%s version %s starting.", $0, $version if $verbose;
#
# Unbuffer standard output.
#
select((select(STDOUT), $| = 1)[0]);

#
# Receive a bunch of attributes, evaluate the policy, send the result.
#
while (<STDIN>) {
    if (/([^=]+)=(.*)\n/) {
	$attr{substr($1, 0, 512)} = substr($2, 0, 512);
    } elsif ($_ eq "\n") {
	if ($verbose > 1) {
	    for (keys %attr) {
		syslog $syslog_priority, "Attribute: %s=%s", $_, $attr{$_};
	    }
	}
	fatal_exit "unrecognized request type: '%s'", $attr{request}
	    unless $attr{"request"} eq "smtpd_access_policy";
	my $action = smtpd_access_policy();
	syslog $syslog_priority, "Action: %s", $action if $verbose > 0;
	print STDOUT "action=$action\n\n";
	%attr = ();
    } else {
	chop;
	syslog $syslog_priority, "warning: ignoring garbage: %.100s", $_;
    }
}

