#!/usr/bin/perl
#
# VERSION: 2.4.1
#
#
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});
}
else {
    %cfile = read_config('/etc/default/benno-milter');
}

my %conf;
# compatiblity to /etc/default/benno-milter config
$conf{host}      = $opts{H} || $cfile{BENNOHOST} || $cfile{host};
$conf{milterdir} = $opts{M} || $cfile{SPOOLDIR}  || $cfile{milterdir} || '/srv/benno/inbox';

$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{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;
}

openlog('benno-milter2smtp','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");
print "Read files from $conf{milterdir}.\n" if $conf{verbose};

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 $send_file = 1;

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

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

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

    $send_file = 0 if $conf{send_senders};
    $send_file = 0 if $conf{send_recipients};

    # send only allowed senders
    if ($conf{send_senders}) {
        if (grep {/^$mailfrom$/} @{$conf{send_senders}}) {
            print "Sender \"$mailfrom\" matches sender list.\n" if $conf{verbose};
            $send_file = 1;
        }

        if (grep {/^$fromdomain$/} @{$conf{send_senders}}) {
            print "Sender domain \"$fromdomain\" matches sender list.\n" if $conf{verbose};
            $send_file = 1;
        }
    }

    # send only allowed recipients
    if ($conf{send_recipients}) {
        if (grep {/^$rcptto$/} @{$conf{send_recipients}}) {
            $send_file = 1;
            print "Recipient \"$rcptto\" matches recipient list.\n" if $conf{verbose};
            $send_file = 1;
        }

        if (grep {/^$rcptdomain$/} @{$conf{send_recipients}}) {
            $send_file = 1;
            print "Recipient domain \"$rcptdomain\" matches recipient list.\n" if $conf{verbose};
            $send_file = 1;
        }
    }

    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}/)) {
        syslog('DEBUG',"Sender \"$real_from\" matches \"$conf{skip_regex}\"\n") if $conf{DEBUG};
        print "Sender \"$real_from\" matches skip_regex \"$conf{skip_regex}\"\n" if $conf{verbose};
        $send_file = 0;
    }

    # suppress spam
    if ($conf{no_spam} && ($spamflag =~ /YES/i)) {
        syslog('DEBUG',"Will not transmit spam mail.\n") if $conf{DEBUG};
        print "Will not transmit spam mail." 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") if $conf{DEBUG};
        print "Will not transmit internal mail." if $conf{verbose};
        $send_file = 0;
    }

    if ($send_file) {
        print "Transfer file: $file\n" if $conf{verbose};
        syslog('DEBUG',"Read mail from $file") if $conf{DEBUG};

        my $fh = new IO::File;
        $fh->open($file) or die "Cannot open $file: $!";
        eval {
            my $store_name = send_file($fh,%conf);
            print "Email $file stored as: $store_name at $conf{host}" if $conf{verbose};
            syslog('INFO',"Email $file stored as: $store_name at $conf{host}");
            if ($conf{delete}) {
                print "Remove file: $file\n" if $conf{verbose};
                syslog('DEBUG',"Remove file: $file") if $conf{DEBUG};
                unlink $file or die "Cannot remove \"$file\": $!";
            }
        };
        if ($@) {
            print STDERR $@;
            syslog('WARNING',$@."\n");
        }
        $fh->close;
        return;
    }
    if ($conf{wipe}) {
        syslog('DEBUG',"Wipe skipped file: $file.\n") if $conf{DEBUG};
        print "Wipe skipped file: $file.\n" if $conf{verbose};
        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";
    }

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

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

    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);
    $smtp->debug(1);
    $smtp->dataend();                       die_on_error($smtp);
    $smtp->debug(0);
    my $smtp_response = $milter2smtp::RESPONSE;
    chomp $smtp_response;
    $smtp_response =~ s/^250\sOk:\ssaved\sas\s//i;
    $milter2smtp::RESPONSE = '';
    $smtp->quit or die "Cannot send mail to $host: $!";

    return $smtp_response.'.eml';
}


###
# 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) = @_;
    my @lines;
    open my $fh, '<', $file or die "Cannot open $file: $!\n";
    while (my $line = <$fh>) {
        chomp $line;
        chomp $line;
        push @lines, $line;
    }
    close $fh;
    return \@lines;
}


### Override class method ###
sub Net::Cmd::debug_print {
  my ($cmd, $out, $text) = @_;
#  #print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
  $milter2smtp::RESPONSE = $text if $text;
}




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


### EOP
1;


package LWs::SingleInstance;

use strict;
use Fcntl ':flock';

#
# Exit program if more than one instance is runningg
#
INIT {
    if (tell(*main::DATA) == -1) {
        # __DATA__ handle not available
        print STDERR "$0 needs an __END__ literal at the end of the file.\n";
        exit 2;
    }
    elsif (!flock main::DATA, LOCK_EX | LOCK_NB) {
        # cannot lock __DATA__ "file"
        print STDERR "An instance of $0 is already running.\n";
        exit 1;
    }
}
### EOP ###
1;
__END__

