#!/usr/bin/perl
#
# VERSION: 2.2.4
#
#
use strict;
use Getopt::Std;
use IO::File;
use Net::SMTP;
use Sys::Syslog;

our(%opts);
getopts('dhvwDISc:F:H:M:R:T:U:P:p:r:s:',\%opts);

if ($opts{h}) {
    print_help();
    exit 1;
}

my %cfile;
if ($opts{c}) {
    %cfile = read_config($opts{c});
}

my %conf;
$conf{verbose}     = $opts{v} || $cfile{verbose};
$conf{delete}      = $opts{d} || $cfile{delete};
$conf{wipe}        = $opts{w} || $cfile{wipe};
$conf{from}        = $opts{F} || $cfile{from};
$conf{host}        = $opts{H} || $cfile{host};
$conf{milterdir}   = $opts{M} || $cfile{milterdir}    || '/srv/benno/inbox';
$conf{port}        = $opts{p} || $cfile{port}         || 2500;
$conf{to}          = $opts{T} || $cfile{to};
$conf{no_internal} = $opts{I} || $cfile{no_internal};
$conf{no_spam}     = $opts{S} || $cfile{no_spam};
$conf{skip_regex}  = $opts{R} || $cfile{skip_regex};
$conf{sender_list} = $opts{s} || $cfile{sender_list};
$conf{recipient_list} = $opts{r} || $cfile{recipient_list};
$conf{auth_user}   = $opts{U} || $cfile{auth_user};
$conf{auth_pass}   = $opts{P} || $cfile{auth_pass};

$conf{DEBUG}       = $opts{D} || $cfile{DEBUG};
$conf{verbose} = 1 if $conf{DEBUG};

if (!$conf{host}) {
    print STDERR "SMTP hostname not set!\n";
    print_help();
    exit 1;
}


my $send_file = 1;

openlog('benno-milter2archive','nowaid,pid','mail');


if ($conf{sender_list}) {
    $conf{send_senders} = read_listfile($conf{sender_list});
}

if ($conf{recipient_list}) {
    $conf{send_recipients} = read_listfile($conf{recipient_list});
}

# read directory and process files
opendir my $dh, $conf{milterdir}
    or die "Cannot read directory \"$conf{milterdir}\": $!";
syslog('INFO',"Read files from $conf{milterdir}.\n");
foreach my $file (readdir $dh) {
    next if $file =~ /^\./;
    next if $file !~ /\.eml$/;
    chomp $file;
    process_mailfile("$conf{milterdir}/$file",%conf);
}
closedir $dh;



### SUBS #####################################################################

###
# read configuration from file
#
sub read_config
{
  my $configfile = shift;
  my %config;
  # _very_ simple config file parser
  #
  # Config format:   var = val
  #
  open CONF, "$configfile" or die "Cannot open config file $configfile. $!\n";
  foreach my $line (<CONF>) {
      next if $line =~ /^$/;
      next if $line =~ /^#/;
      chomp $line;
      my ($var,$val) = split(/=/, $line,2);
      # strip ws
      $var =~ s/\s//g;
      $val =~ s/^\s+//g;
      $val =~ s/\s+$//g;
      $config{$var} = $val;
  } 
  close CONF;
  return %config;
}


###
# process_mailfile
#
sub process_mailfile
{
    my ($file,%conf) = @_;

    my %header = fetch_header($file);
    my $rcptto       = $header{'X-REAL-RCPTTO'};
    $rcptto          =~ s/[\<\>]//g;
    my ($rcptdomain) = $rcptto =~ /^\S+\@(.+)$/;

    my $mailfrom     = $header{'X-REAL-MAILFROM'};
    $mailfrom        =~ s/[\<\>]//g;
    my ($fromdomain) = $mailfrom =~ /^\S+\@(.+)$/;

    my ($spamflag)   = $header{'X-Spam-Flag'};


    # suppress spam
    if ($conf{no_spam} && ($spamflag =~ /YES/i)) {
        syslog('DEBUG',"Will not transmit spam mail.\n");
        print "Will not transmit spam mail.\n" if $conf{verbose};
        $send_file = 0;
    }

    # simple test of domains (X-REAL-RCPTTO could contain multiple adresses)
    if ($conf{no_internal} && ($rcptdomain eq $fromdomain)) {
        syslog('DEBUG',"Will not transmit internal mail.\n");
        print "Will not transmit internal mail.\n" if $conf{verbose};
        $send_file = 0;
    }

    # send only allowed senders
    if ($conf{send_senders}) {
        $send_file = 0;
        if (grep {/$mailfrom/} @{$conf{send_senders}}) {
            $send_file = 1;
        }
        if (grep {/$fromdomain/} @{$conf{send_senders}}) {
            $send_file = 1;
        }
        syslog('DEBUG',"Sender \"$mailfrom\" matches $conf{sender_list}\n");
    }

    # send only allowed recipients
    if ($conf{send_recipients}) {
        $send_file = 0;
        if (grep {/$rcptto/} @{$conf{send_recipients}}) {
            $send_file = 1;
        }
        if (grep {/$rcptdomain/} @{$conf{send_recipients}}) {
            $send_file = 1;
        }
        syslog('DEBUG',"Recipient \"$rcptto\" matches $conf{recipientlist}\n");
    }

    my $real_from = $header{'X-REAL-MAILFROM'};
    $real_from =~ s/[\<\>]//g;
    $real_from =~ s/\r//g;
    if ($conf{skip_regex} && ($real_from =~ /$conf{skip_regex}/)) {
        $send_file = 0;
        syslog('DEBUG',"Sender \"$real_from\" matches \"$conf{skip_regex}\"\n");
    }

    if ($send_file) {
        print "Read mail from $file\n" if $conf{verbose};
        syslog('DEBUG',"Read mail from $file");
        my $fh = new IO::File;
        $fh->open($file) or die "Cannot open $file: $!\n";
        eval {
            send_file($fh,%conf);
            if ($conf{delete}) {
                unlink $file or die "Cannot remove \"$file\": $!";
            }
        };
        if ($@) {
            print STDERR $@;
            syslog('WARNING',$@."\n");
        }
        $fh->close;
    }
    if ($conf{wipe}) {
        unlink $file or die "Cannot wipe \"$file\": $!";
    }
}



###
# send_file
#
sub send_file
{
    my ($fh,%conf) = @_;
    my $host = $conf{host};
    my $port = $conf{port};
    my $force_from  = $conf{force_from};
    my $force_to    = $conf{force_to};
    my $auth_user   = $conf{auth_user};
    my $auth_pass   = $conf{auth_pass};
    my $DEBUG       = $conf{DEBUG};

    my $ret;
    use Net::SMTP;
    my $smtp = Net::SMTP->new($host,
        Port => $port,
        );

    if (!$smtp) {
        die "Cannot access smtp server at $host:$port\n";
    }

    if ($auth_user && $auth_pass) {
        if (!$smtp->auth($auth_user,$auth_pass)) {
            die 'SMTP AUTH failure: '.$smtp->code.' '.$smtp->message."\n";
        }
    }

    # Extract maildump header (first lines)
    my $envelope_from;
    my @envelope_to;
    my $realheader;
    while (my $line = $fh->getline) {
        $realheader = $line;            # don't loose header
        # X-REAL-* headers are first
        last unless $line =~ /^X-REAL-(MAILFROM|RCPTTO):/;
        if (my ($mailfrom) = $line =~ /^X-REAL-MAILFROM:\s(.*)$/) {
            $envelope_from = $mailfrom;
        }
        if (my ($rcptto) = $line =~ /^X-REAL-RCPTTO:\s(.*)$/) {
            push @envelope_to, $rcptto;
        }
    }

    # If envelopes from maildump should not be used to for archiving,
    # force_* envelopes override the extracted envelopes
    if ($force_from) {
        $envelope_from = $force_from;
    }
    if ($force_to) {
        @envelope_to = ();
        push @envelope_to, $force_to;
    }

    if (!$envelope_from && !@envelope_to) {
        die "Envelope header not set.\n";
    }

    print "MAIL FROM: $envelope_from\n"     if  $DEBUG;
    $smtp->mail($envelope_from);            die_on_error($smtp);
    foreach my $envelope (@envelope_to) {
        print "RCPT TO: $envelope\n"   if  $DEBUG;
        $smtp->to($envelope);               die_on_error($smtp);
    }

    $smtp->data();                          die_on_error($smtp);

    $smtp->rawdatasend($realheader);        die_on_error($smtp); # don't loose header
    # loop over mailfile
    while (my $line = <$fh>) {
        $line =~ s/^\./../;                 # RFC 5321, 4.5.2. Transparency
        $smtp->rawdatasend($line);          die_on_error($smtp);
    }
    $smtp->rawdatasend("\r\n");             die_on_error($smtp);
    my $returncode = $smtp->quit;
    syslog('INFO',"Mail sent to $host");
}


###
# smtp_error
#
sub die_on_error
{
    my ($smtp) = shift;
    if (!$smtp->ok) {
        die 'SMTP error: ',$smtp->code,' ',$smtp->message;
    }
}


###
# fetch_header
#
sub fetch_header
{
    my $file = shift;
    my %header;

    my $fh = new IO::File;
    if ($file) {
        $fh->open($file) or die "Cannot open $file: $!\n";
    }
    else {
        $fh->fdopen(fileno(STDIN),"r");
    }

    my $folded = 0;
    my $hname;
    my $hvalue;
    while (my $line = $fh->getline) {
        last if $line =~ /^\r?$/;          # end of headers
        my $hname_old = $hname;
        ($hname,$hvalue) = $line =~ /^(\S+):\s*?(\S.*)$/;
        if ($line =~ /^\s+/) {
            $hvalue .= $line;
            $hname = $hname_old;
        }
        chomp $hvalue;
        if (exists $header{$hname}) {
            $header{$hname} .= "\n  ".$hvalue;
        }
        else {
            $header{$hname} = $hvalue;
        }
    }
    $fh->close;

    return %header;
} 


###
# read_listfile
sub read_listfile
{
    my ($file) = @_;
    open my $fh, '<', $file or die "Cannot open $file: $!\n";
    local $/;
    my @lines = <$fh>;
    close $fh;

    return \@lines;
}


###
# print_help
#
sub print_help
{
    my ($basename) = $0 =~ m!.*?([^/]+?)$!;
    print "Call: $basename [-c <file>] [-d] [-H <hostname>] [-p <port>] [-M <dir>] [...]\n";
    print "\n";
    print "\n";
    print "  -c <file>      Read config file\n";
    print "  -d             Delete mail file if processed\n";
    print "  -w             Wipe skipped files from spool directory\n";
    print "  -H <hostname>  Hostname of SMTP server\n";
    print "  -M <directory> MILTER dump directory (/srv/benno/inbox)\n";
    print "  -p <port>      Port of SMTP server (default: 2500)\n";
    print "  -F             Override envelope-from (default: value of X-REAL-MAILFROM)\n";
    print "  -T             Override envelope-to (default: value of X-REAL-RCPTTO)\n";
    print "  -I             \"Internal\" mail (same domain of sender,recipient) will not be send\n";
    print "  -S             Suppress delivering of SPAM mail (X-Spam-Flag: YES)\n";
    print "  -R '<regex>'   Skip mail if from address matches regexp\n";
    print "  -s <file>      File with sender adresses (domains) to send.\n";
    print "  -r <file>      File with recipient adresses (domains) to send.\n";
    print "  -U <username>  SMTP AUTH username\n";
    print "  -P <password>  SMTP AUTH password\n";
    print "  -v             verbose\n";
    print "  -D             debug\n";
    print "\n";
}
