# <@LICENSE>
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to you under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at:
# 
#     http://www.apache.org/licenses/LICENSE-2.0
# 
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# </@LICENSE>

=head1 NAME

Mail::SpamAssassin::Plugin::DKIMrep - perform DKIM reputation tests

=head1 SYNOPSIS

 loadplugin Mail::SpamAssassin::Plugin::DKIMrep [/path/to/DKIMrep.pm]

 full     DKIM_REPUT eval:check_dkim_reputation()
 tflags   DKIM_REPUT net
 score    DKIM_REPUT 0.1
 describe DKIM_REPUT Signing domain reputation according to dkim-reputation.org
 priority DKIM_REPUT 200
 dkimrep_maxspamscore 3
 dkimrep_maxhamscore -3

=head1 DESCRIPTION

=head1 TAGS

=cut

package Mail::SpamAssassin::Plugin::DKIMrep;

use Mail::SpamAssassin::Plugin;
use Mail::SpamAssassin::Logger;
use Mail::SpamAssassin::Timeout;
use Mail::SpamAssassin::DnsResolver;
use Mail::SpamAssassin::Plugin::effectiveTLDs;

use Digest::MD5 qw(md5_hex);
use Time::Local;

use strict;
use warnings;
use bytes;
use re 'taint';

use vars qw(@ISA);
@ISA = qw(Mail::SpamAssassin::Plugin);

# constructor: register the eval rule
sub new {
  my $class = shift;
  my $mailsaobject = shift;

  $class = ref($class) || $class;
  my $self = $class->SUPER::new($mailsaobject);
  bless ($self, $class);

  $self->register_eval_rule("check_dkim_reputation");

  $self->set_config($mailsaobject->{conf});

  return $self;
}

###########################################################################

sub set_config {
  my($self, $conf) = @_;
  my @cmds;

=head1 ADMINISTRATOR OPTIONS

=item dkimrep_zone string (default: al.dkim-reputation.org)

DNS zone with DKIM reputation data (see www.dkim-reputation.org)

=cut

  push(@cmds, {
    setting  => 'dkimrep_zone',
    is_admin => 1,
    default  => 'al.dkim-reputation.org',
    type     => $Mail::SpamAssassin::Conf::CONF_TYPE_STRING
  });

=item dkimrep_maxspamscore n (default: 15)

Maximum spam score. DKIM spam reputation is in a range from 1 to 1000.
E.g. reputation=100 results in score=1 if maxspamscore is 10. 

=cut

  push(@cmds, {
    setting  => 'dkimrep_maxspamscore',
    is_admin => 1,
    default  => 15,
    type     => $Mail::SpamAssassin::Conf::CONF_TYPE_NUMERIC
  });

=item dkimrep_maxhamscore n (default: -15)

Maximum ham score. DKIM ham reputation is in a range from -1 to -1000.
E.g. reputation=-100 results in score=-1 if maxhamscore is -10. 

=cut

  push(@cmds, {
    setting  => 'dkimrep_maxhamscore',
    is_admin => 1,
    default  => -15,
    type     => $Mail::SpamAssassin::Conf::CONF_TYPE_NUMERIC
  });

  $conf->{parser}->register_commands(\@cmds);
}

sub check_dkim_reputation {
  my($self, $pms) = @_;
  $self->_check_dkim_reputation($pms);
}

=item stripSubdomainsFromSigningDomain($signingdomain)

Remove subdomains from a signing domain to get the registered domain.

dkim-reputation.org blocks signing domains on the level of registered domains
to rate senders who use e.g. a.spamdomain.tld, b.spamdomain.tld, ... under
the most common identifier - the registered domain - finally.

=cut

sub stripSubdomainsFromSigningDomain {
  my($self, $signingDomain) = @_;

  my @signingDomainParts = split(/\./, $signingDomain);

  my $result = $self->findRegisteredDomain(
    $Mail::SpamAssassin::Plugin::effectiveTLDs::tldTree, \@signingDomainParts);

  if (!defined $result) {
    # this is an invalid domain name
    return;
  }

  # assure there is at least 1 TLD in the stripped signing domain
  if (index($result, '.') == -1) {
    my $cnt = @signingDomainParts;
    return if $cnt == 1;
    return $signingDomainParts[$cnt-2] . '.' . $signingDomainParts[$cnt-1];
  }
  else {
    return $result;
  }
}

# recursive helper method
sub findRegisteredDomain {
  my $self = $_[0];
  my $treeNode_ref = $_[1];         # &$treeNode
  my @remainingSigningDomainParts = @{ $_[2] };    # copy to new variable

  my $sub = delete $remainingSigningDomainParts[$#remainingSigningDomainParts];

  undef $sub if !$sub;

  my $result;

  if (exists $treeNode_ref->{'!'}) {
    return '#';
  }
  elsif (exists $treeNode_ref->{$sub}) {
    $result = $self->findRegisteredDomain($treeNode_ref->{$sub},
                                          \@remainingSigningDomainParts);
  }
  elsif (exists $treeNode_ref->{'*'}) {
    $result = $self->findRegisteredDomain($treeNode_ref->{'*'},
                                          \@remainingSigningDomainParts);
  }
  else {
    return $sub;
  }

  if ($result eq '#') {
    return $sub;
  }
  elsif (defined $result && $result ne '') {
    return $result . '.' . $sub;
  }
  return;
}

sub extractEmailaddressParts {
  my $s = $_[1];
  my @result;

  if (defined $s && $s ne '') {
    local $1;
    while ($s =~ /([\w._+-]+\@[\w._]+[\w_]+)/g) {  #***!!!
      my @addressParts = split(/\@/, lc($1));
      push(@result, \@addressParts);
    }
  }
  return @result;
}

# read identified signing domains

sub getDKIMIdentities {
  my($self, $pms) = @_;

  my %identities;

  # get signing domains
  my @signingDomains;
  if (defined $pms->get_tag('DKIMDOMAIN')) {
    @signingDomains = split(' ', lc( $pms->get_tag('DKIMDOMAIN') ));
  }
  return if !@signingDomains;

  # get from addresses
  my @fromAddresses = $self->extractEmailaddressParts($pms->get('From:raw'));
  return if !@fromAddresses;

  # get sender address
  my @senderAddress =
    $self->extractEmailaddressParts($pms->get('X-Sender:addr'));

  if (!@senderAddress) {
    @senderAddress = $self->extractEmailaddressParts($pms->get('Sender:addr'));
  }

  foreach my $signingDomain (@signingDomains) {

    # remove subdomains from signing domain
    my $registeredDomain =
      $self->stripSubdomainsFromSigningDomain($signingDomain);

    # seems to be an invalid domain --> you may have
    # to correct effectiveTLDs.inc.php
    next if !defined $registeredDomain;

    # Identity fields:
    # s = signing domain, e.g. e.voiceinacrowd.co.uk
    # r = registered domain, e.g. voiceinacrowd.co.uk
    # d = originator domain, e.g. e.voiceinacrowd.co.uk
    # u = user, e.g. info
    # f = is from user

    if (@senderAddress) {
      $identities{
        join('#', $senderAddress[0][0], $senderAddress[0][1], $signingDomain)}=
      { 's' => $signingDomain,
        'r' => $registeredDomain,
        'd' => $senderAddress[0][1],
        'u' => $senderAddress[0][0],
        'f' => 0,
      };
    }

    foreach my $fromAddress (@fromAddresses) {

      if (@senderAddress) {
        my $u = $senderAddress[0][0];
        $u .= '$' . $$fromAddress[0]  if $u ne $$fromAddress[0];

        my $d = $senderAddress[0][1];
        $d .= '$' . $$fromAddress[1]  if $d ne $$fromAddress[1];

        $identities{ join('#', $u, $d, $signingDomain) } =
        { 's' => $signingDomain,
          'r' => $registeredDomain,
          'd' => $d,
          'u' => $u,
          'f' => 1,
        };
      }
      else {
        $identities{
          join('#', $$fromAddress[0], $$fromAddress[1], $signingDomain) } =
        { 's' => $signingDomain,
          'r' => $registeredDomain,
          'd' => $$fromAddress[1],
          'u' => $$fromAddress[0],
          'f' => 1,
        };
      }
    }
  }
  
  return !%identities ? undef : \%identities;
}

sub isPositiveInt {
  return $_[1] =~ /^\d+$/;
}

sub isNegativeInt {
  return $_[1] =~ /^-\d+$/;
}

sub extractPositiveInt {
  my($self, $string, $offset, $length, $default) = @_;

  return $default if length($string) < $offset + $length;

  my $val = substr($string, $offset, $length);
  return $default if !$self->isPositiveInt($val);

  return $val;
}

# e.g. 20080819204515 to according unix timestamp (GMT)
sub convertTimeStamp {
  my ($self, $timestamp) = @_;
  my @now = gmtime();

  my $year   = $self->extractPositiveInt($timestamp, 0,  4, $now[5] + 1900)
                 - 1900;
  my $month  = $self->extractPositiveInt($timestamp, 4,  2, $now[4] + 1) - 1;
  my $day    = $self->extractPositiveInt($timestamp, 6,  2, $now[3]);
  my $hour   = $self->extractPositiveInt($timestamp, 8,  2, $now[2]);
  my $minute = $self->extractPositiveInt($timestamp, 10, 2, $now[1]);
  my $second = $self->extractPositiveInt($timestamp, 12, 2, $now[0]);

  return timegm($second, $minute, $hour, $day, $month, $year);
}

sub getAsyncDKIMReputation {
  my($self, $pms, $key, $query_label, $identity) = @_;

  dbg("dkimrep: request (src) %s", $key);
  dbg("dkimrep: request %s", $query_label);

  # async DNS query
  my $id = $self->{main}->{resolver}->bgsend(
    $query_label, 'TXT', undef, sub {
      my($pkt, $reply_id, $timestamp) = @_;
      $pms->{async}->set_response_packet($reply_id, $pkt, $key, $timestamp);
    }
  );
  my $ent = {
    key => $key, zone => $query_label, type => 'DKIMrep-TXT', id => $id,
    timeout_initial => 4, timeout_min => 4,
    completed_callback => sub {
      my $ent = shift;
      $self->processDKIMReputation($ent->{response_packet},
                                   $pms, $key, $identity);
    }
  };
  $pms->{async}->start_lookup($ent);
}

sub processDKIMReputation {
  my($self, $packet, $pms, $key, $identity) = @_;

  if (!defined $packet || !$packet->question) {
    dbg("dkimrep: processDKIMReputation - invalid DNS packet 1");
    return;
  }

  my $question = ($packet->question)[0];
  if (!defined $question) {
    dbg("dkimrep: processDKIMReputation - invalid DNS packet 2");
    return;
  }

  my $rcode = $packet->header->rcode;
  if ($rcode =~ /^(?:NXDOMAIN|SERVFAIL)$/) {
    dbg("dkimrep: DNS query failed: %s, key %s", $rcode, $key);
    $self->domReport($pms, $identity, undef, "none");
    return 1;
  }

  dbg("dkimrep: processDKIMReputation");

  # rep tests are here
  foreach my $answer ($packet->answer) {
    next if !defined $answer;
    next if $answer->type ne 'TXT';

    my $txtRecord = $answer->rdatastr;
    dbg("dkimrep: answer (key=%s): %s", $key, $txtRecord);

    # calculate reputation from TXT e.g. "rep=19;time=20080819204515;wppd=1"
    $txtRecord =~ s/^"//;  $txtRecord =~ s/"$//;

    my $rep = 0;
    my $repTime = 0;
    my $wppd = 0;
    my @rParts = split(';', $txtRecord);

    foreach my $rPart (@rParts) {
      my @nameValPair = split('=', $rPart);
      next if !@nameValPair;
      my($name,$val) = @nameValPair;

      if ($name eq 'rep') {
        $rep = $val;
        $rep = 0 if !$self->isPositiveInt($rep) && !$self->isNegativeInt($rep);
      }
      elsif ($name eq 'time') {
        $repTime = $self->convertTimeStamp($val);
      }
      elsif ($name eq 'wppd') {
        $wppd = $val;
        $wppd = 0 if !$self->isPositiveInt($wppd);
      }
    }

    if ($rep == 0) {
      $self->domReport($pms, $identity, 0, "neutral");
    }
    elsif ($rep < 0) {  # this is ham
      if ($rep < $pms->{maxDKIMHamScore}) { $pms->{maxDKIMHamScore} = $rep }
      $self->domReport($pms, $identity, $rep, "good");
    }
    else {  # this is spam
      my $forgivenDays = (time() - $repTime) / 86400;
      if ($forgivenDays < 0) { $forgivenDays = 0 }
      $rep = $rep - $wppd * $forgivenDays;
      if ($rep > $pms->{maxDKIMSpamScore} ) { $pms->{maxDKIMSpamScore} = $rep }
      if ($rep > 0) { $self->domReport($pms, $identity, $rep, "bad") }
      else          { $self->domReport($pms, $identity, 0,  "rehab") }
    }

  }
}

sub aggregateDKIMReputation {
  my($self, $pms) = @_;

  my $score = 0;
  my $maxspam = $pms->{maxDKIMSpamScore};
  my $maxham  = $pms->{maxDKIMHamScore};

  if (defined $maxspam && $maxspam > 0) {
    $score = $maxspam * $pms->{conf}->{dkimrep_maxspamscore} / 1000;
  }
  elsif (defined $maxham && $maxham < 0) {
    $score = - $maxham * $pms->{conf}->{dkimrep_maxhamscore} / 1000;
  }
  dbg("dkimrep: aggregate score: %s", $score);

  if ($score != 0) {
    my $scoreset = $pms->{conf}->{scoreset};
    my $descript = $pms->{conf}->{descriptions};
    my $rulename = 'DKIM_REPUT';
    $descript->{$rulename} = "Rated by " . $pms->{conf}->{dkimrep_zone};
    $scoreset->[$_]->{$rulename} = sprintf("%0.3f",$score)  for (0..3);
    $pms->got_hit($rulename, 'DKIMrep: ', score=>$score, ruletype=>'eval');
  }
}

sub _check_dkim_reputation {
  my($self, $pms) = @_;

  dbg("dkimrep: check_dkim_reputation");

  return if !$pms->is_dns_available();

  my $identities = $self->getDKIMIdentities($pms);
  return if !$identities;

  dbg("dkimrep: found some valid dkim identities"); 

  $pms->{maxDKIMSpamScore} = 0;
  $pms->{maxDKIMHamScore} = 0;

  while (my($key, $identity) = each(%$identities)) {
    # async DNS requests
    my($query_label_src, $query_label, $key);

    $query_label_src = join('.', map { "($_)" } @$identity{'u','d','r'},
                                                $pms->{conf}->{dkimrep_zone});
    $query_label =
        md5_hex( $identity->{'u'} ) . '.'
      . md5_hex( $identity->{'d'} ) . '.'
      . md5_hex( $identity->{'r'} ) . '.'
      . $pms->{conf}->{dkimrep_zone};
    $key = 'DKIMrep:TXT:' . $query_label_src;
    $self->getAsyncDKIMReputation($pms, $key, $query_label, $identity);

    $query_label_src = join('.', map { "($_)" } '*', $identity->{'s'},
                                                $pms->{conf}->{dkimrep_zone});
    $query_label = '*.' . md5_hex( $identity->{'s'} ) . '.'
                   . $pms->{conf}->{dkimrep_zone};
    $key = 'DKIMrep:TXT:' . $query_label_src;
    $self->getAsyncDKIMReputation($pms, $key, $query_label, $identity);
  }
}

sub domReport {
  my($self, $pms, $identity, $rep, $info) = @_;

  if ($identity->{'f'}) {
    $rep = !defined $rep ? 'undef' : sprintf("%.1f",$rep);
    info("dkimrep: id=%s, %s, %s rep=%s info=%s",
         $identity->{'u'}, $identity->{'d'}, $identity->{'r'}, $rep, $info);
  }
}

sub check_post_dnsbl {
  my($self, $opts) = @_;

  $self->aggregateDKIMReputation($opts->{permsgstatus});
}

1;
