[Mimedefang] DMARC reject/quarantine policy - Latest version of the code

Wed Jun 4 10:56:31 EDT 2014

Here's the latest version of the stub for an MD filter to handle the 
DMARC issues.  Thanks to DFS and Roaring Penguin for the utf8 code.

regards,
KAM
-------------- next part --------------
sub filter_initialize {
  ...

  use Net::DNS;
  use IO::File;
  ...
}

sub filter_end ($) {
  ...

    #DMARC MAILING LIST RESOLUTION
    foreach my $recip (@Recipients) {
      # BLOCK IF FROM YAHOO (AND OTHERS) BECAUSE THEY SET DMARC TOO STRICTLY
      # http://www.pcworld.com/article/2141120/yahoo-email-antispoofing-policy-breaks-mailing-lists.html
      # REWRITE THE FROM HEADER AND OTHER FIELDS PER RECOMMENDATION HERE: http://dmarc.org/faq.html#s_3

      # If Sender is set to DMARC reject and recipient is a mailing list - NOTE Yahoo.com and AOL.com reject as of 4/23
      if (([[[Logic to identify your mailing lists]]] $recip =~ m/\@mailman\./i or

          and

         # exclude the admnistrivia addresses like admin confirm, join, leave, etc.
         ($recip !~ /\-(admin|bounces|confirm|join|leave|owner|request|subscribe|unsubscribe)(\+.*)?\@/i)

         ) {
        my ($container, $parser, $original, $report2, $dmarc_reject_notice, $sender, $dmarc_result, $sender_domain, $modification_subject);

        # Automatically check DMARC DNS entry
        $sender_domain = &get_domain_from_email($Sender);
        # DNS test for DMARC entry with timeout of 5 seconds
        $dmarc_result = &check_dmarc(domain=>$sender_domain, timeout=>5);

        if ($dmarc_result =~ /p=(reject|quarantine)/i) {

          # NOTIFY SENDER AND REWRITE THE SENDER TO A DO-NOT-REPLY ADDRESS
          md_syslog('warning', "Modifying message to mailing list due to DMARC - $recip - $Sender - $Subject");
          $dmarc_reject_notice = "Your email to $recip was modified due to a change your email provider implemented which causes your email on mailing lists to be flagged incorrectly as a forgery.

In order to permit your email through to the mailing list, we have rewritten the From address to a do-not-reply address.  Depending on the list configuration, you may not receive replies and will need to monitor the list.  Additionally, this may delay your email as it will require manual intervention by the list moderator to approve.

We apologize for the inconvenience but the cause of the issue rests squarely and solely on your email provider.  We recommend you consider a free Google account available at http://www.gmail.com/.  For more technical information, please see: http://www.pcworld.com/article/2141120/yahoo-email-antispoofing-policy-breaks-mailing-lists.html and http://postmaster-blog.aol.com/2014/04/22/aol-mail-updates-dmarc-policy-to-reject/

Sincerely,

Kevin A. McGrail
President, PCCC";

          #CUSTOMIZE NOTIFICATION PARAMS
          $sender = 'do-not-reply at pccc.com';
          $modification_subject = &utf8_to_mime("Important Mailing List Notification re:[". &mime_to_utf8($Subject) ."]");

          #SEND NOTIFICATION
          action_notify_sender_immediately(Sender=>$Sender, DaemonName=>'PCCC Notice', DaemonAddress=>$sender, NotifySenderSubject=>$modification_subject, body=>$dmarc_reject_notice);

          #TEMPORARILY REMOVE MAILING LIST
          #delete_recipient($recip); - NO LONGER NEEDED WITH REWRITE OF FROM

          #Possible Improvement is to do a DKIM/SPF/etc. check on the email before rewriting to minimize forgeries getting farther in the process.

          #CHANGE SENDER ON ENVELOPE
          change_sender($sender);

          #CHANGE SENDER ON FROM
          if (&check_header(header=>'From')) {
            action_delete_all_headers('From');
            action_delete_all_headers('Reply-To');
            action_add_header("From","\"DMARC Modified Email (was $Sender)\" <$sender>");
            action_add_header("Reply-To", "$Sender");
          }
        }
      }
    }
    #END DMARC MAILING LIST HANDLING

...
}

#get domain name from an email address
sub get_domain_from_email {
  my ($domain) = @_;

  #REMOVE ANY LEADING/TRAILING <>'s
  $domain =~ s/(^<|>$)//g;
  #REMOVE ANY LEADING/TRAILING SPACE'S
  $domain =~ s/^ *//g;
  $domain =~ s/ *$//g;
  #REMOVE EVERYTHING UP TO THE @ SYMBOL
  $domain =~ s/.*\@//g;

  return $domain;
}

sub action_notify_sender_immediately {
  my (%params) = @_;

  my ($body, $recip);

  # Send notification to sender - Based on function from mimedefang.pl
  if ($params{'Sender'} ne '<>') {
    $body = "From: $params{'DaemonName'} <$params{'DaemonAddress'}>\n";
    $body .= "To: $params{'Sender'}\n";
    $body .= gen_date_msgid_headers();
    $body .= "Auto-Submitted: auto-generated\n";
    $body .= "MIME-Version: 1.0\nContent-Type: text/plain\n";
    $body .= "Precedence: bulk\n";
    $body .= "Subject: $params{'NotifySenderSubject'}\n\n";
    $body .= "$params{'body'}\n";

    send_mail($params{'DaemonAddress'}, $params{'DaemonName'}, $params{'Sender'}, $body);
  }
}

# check the HEADERS file and return any instances of a specific parameter header (case insensitive on header name)
sub check_header {
  my (%params) = @_;
  my ($filehandle, $preslurp, $contents, $output);

  $params{'header'} || return undef;

  $filehandle = new IO::File('< ./HEADERS') or return undef;

  while (<$filehandle>) {
    if ($_ =~ /^$params{'header'}:/i) {
      $output .= $_;
    }
  }

  close ($filehandle);

  return $output;

}

sub check_dmarc {
  my (%params) = @_;
  my ($res, $packet, @answer);

  $res = Net::DNS::Resolver->new;

  $params{'timeout'} ||= 10;
  $params{'domain'} || return undef;

  if (defined ($res)) {
    $res->tcp_timeout($params{'timeout'});       #Number of Seconds before query will fail
    $res->udp_timeout($params{'timeout'});       #Number of Seconds before query will fail

    $packet = $res->query("_dmarc.$params{'domain'}","TXT","IN");

    #Parse the Query
    if (defined ($packet)) {
      if (defined ($packet->answer)) {
        @answer = $packet->answer;
        if ($answer[0]->type eq "TXT") {
          return $answer[0]->txtdata;
        }
      }
    }
  }

  return undef;
}

#/***
#David F. Skoll: 
#Here are a pair of functions from our commercial CanIt product that
#I hereby place in the public domain.  You need to "use MIME::Words;" first.
#
#mime_to_utf8 takes MIME-encoded stuff and returns a Perl Unicode string.
#utf8_to_mime goes the other way.

sub mime_to_utf8 {
  my ($mime_encoded_str) = @_;

  my @array = MIME::Words::decode_mimewords($mime_encoded_str);
  my $ans = '';
  foreach my $thing (@array) {
    # Use default encoding (iso-8859-1 aka Latin-1)
    # if MIME::Words doesn't detect one.
    my $piece = eval {
      Encode::decode($thing->[1] || 'iso-8859-1', $thing->[0], $Encode::FB_PERLQQ)
    };
    if( ! $piece ) {
      # If decode chokes, just give back the raw version.  It
      # may be ugly, but it's better than dying
      warn "Encode::decode() died with: $@";
      $piece = $mime_encoded_str;
    }
    $ans .= $piece;
  }

  # Ensure internal UTF8 flag is on, even on non-wide
  # characters.
  utf8::upgrade($ans);
  return $ans;
}

sub utf8_to_mime {
  my ($utf8_str) = @_;
  my $qp_result = MIME::Words::encode_mimeword($utf8_str, 'q', 'UTF-8');
  # If it doesn't make the string too long, return it
  if ($qp_result eq "=?UTF-8?Q?$utf8_str?=") {
    # No unsafe chars!
    return $utf8_str;
  }

  # If the ONLY change was to encode spaces, return original string
  my $encoded_spaces = $utf8_str;
  $encoded_spaces =~ s/ /=20/g;
  if ($qp_result eq "=?UTF-8?Q?$encoded_spaces?=") {
    return $utf8_str;
  }
  $encoded_spaces = $utf8_str;
  $encoded_spaces =~ s/ /_/g;
  if ($qp_result eq "=?UTF-8?Q?$encoded_spaces?=") {
    return $utf8_str;
  }

  # Encode spaces as underscores
  $qp_result =~ s/ /_/g;
  $qp_result =~ s/=20/_/g;
  if (length($qp_result) <= 1.6 * length($utf8_str)) {
    return $qp_result;
  }

  my $b64_result = MIME::Words::encode_mimeword($utf8_str, 'b', 'UTF-8');
  if (length($b64_result) < length($qp_result)) {
    return $b64_result;
  }
  return $qp_result;
}