#!perl -w
=head1 NAME

denysoft_greylist

=head1 DESCRIPTION

Plugin to implement the 'greylisting' algorithm proposed by Evan 
Harris in http://projects.puremagic.com/greylisting/. Greylisting is 
a form of denysoft filter, where unrecognised new connections are 
temporarily denied for some initial period, to foil spammers using 
fire-and-forget spamware, http_proxies, etc.

Greylisting adds two main features: it tracks incoming connections 
using a triplet of remote IP address, sender, and recipient, rather 
than just using the remote IP; and it uses a set of timeout periods 
(black/grey/white) to control whether connections are allowed, instead 
of using connection counts or rates.

This plugin allows connection tracking on any or all of IP address, 
sender, and recipient (but uses IP address only, by default), with 
configurable greylist timeout periods. A simple dbm database is used 
for tracking connections, and relayclients are always allowed 
through. The plugin supports whitelisting using the whitelist_soft
plugin (optional).


=head1 CONFIG

The following parameters can be passed to denysoft_greylist:

=over 4

=item remote_ip <bool>

Whether to include the remote ip address in tracking connections.
Default: 1.

=item sender <bool>

Whether to include the sender in tracking connections. Default: 0.

=item recipient <bool>

Whether to include the recipient in tracking connections. Default: 0.

=item deny_late <bool>

Whether to defer denials during the 'mail' hook until 'data_post'
e.g. to allow per-recipient logging. Default: 0.

=item black_timeout <timeout_seconds>

The initial period, in seconds, for which we issue DENYSOFTs for 
connections from an unknown (or timed out) IP address and/or sender
and/or recipient (a 'connection triplet'). Default: 50 minutes.

=item grey_timeout <timeout_seconds>

The subsequent 'grey' period, after the initial black blocking period,
when we will accept a delivery from a formerly-unknown connection
triplet. If a new connection is received during this time, we will 
record a successful delivery against this IP address, which whitelists 
it for future deliveries (see following). Default: 3 hours 20 minutes.

=item white_timeout <timeout_seconds>

The period after which a known connection triplet will be considered 
stale, and we will issue DENYSOFTs again. New deliveries reset the 
timestamp on the address and renew this timeout. Default: 36 days.

=item mode ( denysoft | testonly | off )

Operating mode. In 'denysoft' mode we log and track connections and 
issue DENYSOFTs for black connections; in 'testonly' mode we log and 
track connections as normal, but never actually issue DENYSOFTs 
(useful for seeding the database and testing without impacting 
deliveries); in 'off' mode we do nothing (useful for turning 
greylisting off globally if using per_recipient configs). 
Default: denysoft.

=item db_dir <path>

Path to a directory in which the greylisting DB will be stored.  This
directory must be writable by the qpsmtpd user.  By default, the first
usable directory from the following list will be used:

=over 4

=item /var/lib/qpsmtpd/greylisting

=item I<BINDIR>/var/db (where BINDIR is the location of the qpsmtpd binary)

=item I<BINDIR>/config

=back

=item per_recipient <bool>

Flag to indicate whether to use per-recipient configs. 

=item per_recipient_db <bool>

Flag to indicate whether to use per-recipient greylisting 
databases (default is to use a shared database).  Per-recipient configuration
directories, if determined, supercede I<db_dir>.

=item nfslock <bool>

Flag to indicate the database is stored on NFS.  Uses File::NFSLock
instead of flock.

=item p0f

Enable greylisting only when certain p0f criteria is met. The single
required argument is a comma delimited list of key/value pairs. The keys
are the following p0f TCP fingerprint elements: genre, detail, uptime,
link, and distance.

To greylist emails from computers whose remote OS is windows, you'd use
this syntax:

  p0f genre,windows

To greylist only windows computers on DSL links more than 3 network hops
away:

  p0f genre,windows,link,dsl,distance,3

=back

=head1 BUGS

=head1 AUTHOR

Written by Gavin Carr <gavin@openfusion.com.au>.

Added p0f section <msimerson@cpan.org> (2010-05-03)

nfslock feature added by JT Moree <jtmoree@kahalacorp.com> (2007-01-22)

=cut

BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
use AnyDBM_File;
use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
use strict;

my $VERSION = '0.09';

my $DENYMSG = "This mail is temporarily denied";
my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
my $DB = "denysoft_greylist.dbm";
my %PERMITTED_ARGS = map { $_ => 1 } qw(per_recipient remote_ip sender recipient 
  black_timeout grey_timeout white_timeout deny_late mode db_dir nfslock p0f );

my %DEFAULTS = (
    remote_ip => 1,
    sender => 0,
    recipient => 0,
    black_timeout => 50 * 60,
    grey_timeout =>  3 * 3600 + 20 * 60,
    white_timeout => 36 * 24 * 3600,
    mode => 'denysoft',
    nfslock => 0,
    p0f  => undef,
);

sub register {
  my ($self, $qp, %arg) = @_;
  my $config = { %DEFAULTS, 
    map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'), 
    %arg };
  if (my @bad = grep { ! exists $PERMITTED_ARGS{$_} } sort keys %$config) {
    $self->log(LOGALERT, "invalid parameter(s): " . join(',',@bad));
  }
  $self->{_greylist_config} = $config;
  unless ($config->{recipient} || $config->{per_recipient}) {
    $self->register_hook("mail", "mail_handler");
  } else {
    $self->register_hook("rcpt", "rcpt_handler");
  }
}

sub mail_handler {
  my ($self, $transaction, $sender) = @_;
  my ($status, $msg) = $self->denysoft_greylist($transaction, $sender, undef);
  if ($status == DENYSOFT) {
    my $config = $self->{_greylist_config};
    return DENYSOFT, $msg unless $config->{deny_late};
    $transaction->notes('denysoft_greylist', $msg) 
  }
  return DECLINED;
}

sub rcpt_handler {
  my ($self, $transaction, $rcpt) = @_;
  # Load per_recipient configs
  my $config = { %{$self->{_greylist_config}},
    map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist', { rcpt => $rcpt }) };
  # Check greylisting
  my $sender = $transaction->sender;
  my ($status, $msg) = $self->denysoft_greylist($transaction, $sender, $rcpt, $config);
  if ($status == DENYSOFT) {
    # Deny here (per-rcpt) unless this is a <> sender, for smtp probes
    return DENYSOFT, $msg if $sender->address;
    $transaction->notes('denysoft_greylist', $msg);
  }
  return DECLINED;
}

sub hook_data {
  my ($self, $transaction) = @_;
  my $note = $transaction->notes('denysoft_greylist');
  return DECLINED unless $note;
  # Decline if ALL recipients are whitelisted
  if (($transaction->notes('whitelistrcpt')||0) == scalar($transaction->recipients)) {
    $self->log(LOGWARN,"all recipients whitelisted - skipping");
    return DECLINED;
  }
  return DENYSOFT, $note;
}

sub denysoft_greylist {
  my ($self, $transaction, $sender, $rcpt, $config) = @_;
  my $nfslock;  #this will go out of scope and remove the lock
  $config ||= $self->{_greylist_config};
  $self->log(LOGDEBUG, "config: " . join(',',map { $_ . '=' . $config->{$_} } sort keys %$config));

  # Always allow relayclients and whitelisted hosts/senders
  return DECLINED if $self->qp->connection->relay_client();
  return DECLINED if $self->qp->connection->notes('whitelisthost');
  return DECLINED if $transaction->notes('whitelistsender');

  # do not greylist if p0f matching is selected and message does not match
  return DECLINED if $config->{'p0f'} && !$self->p0f_match( $config );

  if ($config->{db_dir} && $config->{db_dir} =~ m{^([-a-zA-Z0-9./_]+)$}) {
    $config->{db_dir} = $1; 
  }

  # Setup database location
  my $dbdir = $transaction->notes('per_rcpt_configdir') 
    if $config->{per_recipient_db};
  for my $d ($dbdir, $config->{db_dir}, "/var/lib/qpsmtpd/greylisting",
             "$QPHOME/var/db", "$QPHOME/config", '.' ) {
      last if $dbdir && -d $dbdir;
      next if ( ! $d || ! -d $d );
      $dbdir = $d;
  }
  my $db = "$dbdir/$DB";
  $self->log(LOGDEBUG,"using $db as greylisting database");

  my $remote_ip = $self->qp->connection->remote_ip;
  my $fmt = "%s:%d:%d:%d";

  if ($config->{nfslock}) {
    require File::NFSLock;
    ### set up a lock - lasts until object looses scope
    unless ($nfslock = new File::NFSLock {
      file      => "$db.lock",
      lock_type => LOCK_EX|LOCK_NB,
      blocking_timeout   => 10,      # 10 sec
      stale_lock_timeout => 30 * 60, # 30 min
    }) {
      $self->log(LOGCRIT, "nfs lockfile failed: $!");
      return DECLINED;
    }
    unless (open(LOCK, "+<$db.lock")) {
      $self->log(LOGCRIT, "opening nfs lockfile failed: $!");
      return DECLINED;
    }
  }
  else {
      # Check denysoft db
    unless (open LOCK, ">$db.lock") {
      $self->log(LOGCRIT, "opening lockfile failed: $!");
      return DECLINED;
    }
    unless (flock LOCK, LOCK_EX) {
      $self->log(LOGCRIT, "flock of lockfile failed: $!");
      close LOCK;
      return DECLINED;
    }
  }
  my %db = ();
  unless (tie %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) {
    $self->log(LOGCRIT, "tie to database $db failed: $!");
    close LOCK;
    return DECLINED;
  }
  my @key;
  push @key, $remote_ip             if $config->{remote_ip};
  push @key, $sender->address || '' if $config->{sender};
  push @key, $rcpt->address         if $rcpt && $config->{recipient};
  my $key = join ':', @key;
  my ($ts, $new, $black, $white) = (0,0,0,0);
  if ($db{$key}) {
    ($ts, $new, $black, $white) = split /:/, $db{$key};
    $self->log(LOGDEBUG, "ts: " . localtime($ts) . ", now: " . localtime);
    if (! $white) {
      # Black IP - deny, but don't update timestamp
      if (time - $ts < $config->{black_timeout}) {
        $db{$key} = sprintf $fmt, $ts, $new, ++$black, 0;
        $self->log(LOGWARN, "key $key black DENYSOFT - $black failed connections");
        untie %db;
        close LOCK;
        return $config->{mode} eq 'testonly' ? DECLINED : DENYSOFT, $DENYMSG;
      }
      # Grey IP - accept unless timed out
      elsif (time - $ts < $config->{grey_timeout}) {
        $db{$key} = sprintf $fmt, time, $new, $black, 1;
        $self->log(LOGWARN, "key $key updated grey->white");
        untie %db;
        close LOCK;
        return DECLINED;
      }
      else {
        $self->log(LOGWARN, "key $key has timed out (grey)");
      }
    }
    # White IP - accept unless timed out
    else {
      if (time - $ts < $config->{white_timeout}) {
        $db{$key} = sprintf $fmt, time, $new, $black, ++$white;
        $self->log(LOGWARN, "key $key is white, $white deliveries");
        untie %db;
        close LOCK;
        return DECLINED;
      }
      else {
        $self->log(LOGWARN, "key $key has timed out (white)");
      }
    }
  }

  # New ip or entry timed out - record new and return DENYSOFT
  $db{$key} = sprintf $fmt, time, ++$new, $black, 0;
  $self->log(LOGWARN, "key $key initial DENYSOFT, unknown");
  untie %db;
  close LOCK;
  return $config->{mode} eq 'testonly' ? DECLINED : DENYSOFT, $DENYMSG;
}

sub p0f_match {
    my $self = shift;
    my $config = shift;

    my $p0f = $self->connection->notes('p0f');
    return if !$p0f || !ref $p0f;     # p0f fingerprint info not found

    my %valid_matches = map { $_ => 1 } qw( genre detail uptime link distance );
    my %requested_matches = split(/\,/, $config->{'p0f'} );

    foreach my $key (keys %requested_matches) {
        next if !defined $valid_matches{$key}; # discard invalid match keys
        my $value = $requested_matches{$key};
        return 1 if $key eq 'distance' && $p0f->{$key} > $value;
        return 1 if $key eq 'genre'    && $p0f->{$key} =~ /$value/i;
        return 1 if $key eq 'uptime'   && $p0f->{$key} < $value;
        return 1 if $key eq 'link'     && $p0f->{$key} =~ /$value/i;
    }
    return;
}

# arch-tag: 6ef5919e-404b-4c87-bcfe-7e9f383f3901