#!/usr/bin/perl
#
#
use strict;
use lib '/usr/lib/benno-exchange';
use Getopt::Std;
use Sys::Syslog;
use IO::Socket;
use IO::Socket::SSL;
use File::Temp qw/tempfile/;
use IO::File;
use Mail::POP3Client;
use MIME::Parser;
use Carp;

my $VERSION = '2.4.5';

my %opts;
getopts('A:DSdfhjsvVH:M:P:R:c:i:m:n:p:t:u:w:',\%opts);

help_exit() if $opts{h};

if ($opts{V}) {
    print "benno-exchange $VERSION\n"; exit 0;
}

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


my $DEBUG    = $conf->{DEBUG}     || $opts{D};
my $delete   = $conf->{delete}    || $opts{d};
my $ssl      = $conf->{ssl}       || $opts{s};
my $VERBOSE  = $conf->{VERBOSE}   || $opts{v};
my $host     = $conf->{host}      || $opts{H} || 'localhost';
my $port     = $conf->{port}      || $opts{P} || 110;
my $inbox    = $conf->{inbox}     || $opts{i} || '/srv/benno/inbox';
my $numfetch = $conf->{numfetch}  || $opts{n} || 250;
my $pass     = $conf->{pass}      || $opts{p};
my $type     = $conf->{type}      || $opts{t} || '2007';
my $user     = $conf->{user}      || $opts{u};
my $jcopy    = $conf->{jcopy}     || $opts{j};
my $runuser  = $conf->{runuser}   || $opts{R} || 'benno';
my $authmode = $conf->{authmode}  || $opts{A} || 'BEST';
my $statusfile = $conf->{statusfile}  || $opts{S};
my $whitelist = $conf->{whitelist}    || $opts{w};
my $force_delete = $conf->{force_delete} || $opts{f};
my $filemode = $conf->{filemode}    || $opts{M} || '0640';


help_exit() if not ($user and $pass);

LWs::RunAs->import($runuser);


($type eq '2007') || ($type eq '2003') || help_exit(); 

my $ERRMSG;

$0 = "benno-fetchExchange -H $host -P $port";

openlog('benno-fetchExchange','nowait,pid','mail');

my @whitelist;
if ($whitelist) {
    @whitelist = read_whitelist($whitelist);
}

my $socket;
if ($ssl) {
    $port = 995 if $port == 110;
    $socket = IO::Socket::SSL->new(
        Proto           => 'tcp',
        PeerAddr        => $host,
        PeerPort        => $port,
        SSL_verify_mode => 0x00,
    );
}
else {
    $socket = IO::Socket::INET->new(
        Proto    => 'tcp',
        PeerAddr => $host,
        PeerPort => $port,
    );
}
my $pop = Mail::POP3Client->new();
$pop->User($user);
$pop->Pass($pass);
$pop->AuthMode($authmode);
$pop->Socket($socket);
$pop->Debug(1) if $DEBUG;

if (!$pop->Connect) {
    $ERRMSG = $pop->Message;
    print STDERR "Cannot connect to $host: $ERRMSG\n";
    syslog('ERR',"Cannot connect to $host: $ERRMSG\n");
    exit 2;
}
if (!$pop->Login) {
    $ERRMSG = $pop->Message;
    print STDERR "Login failed: $ERRMSG\n";
    syslog('ERR',"Login failed: $ERRMSG\n");
    exit 3;
}

my $num = $pop->Count();
if ($num < 0) {
    $ERRMSG = $pop->Message;
    print STDERR "Error retrieve message counter: $ERRMSG\n";
    syslog('ERR',"Error retrieve message counter: $ERRMSG\n");
}

print "$num mails on server.\n" if $VERBOSE;
syslog('INFO',"$num mails on server.\n") if $VERBOSE;

my $count;
my $fetched=0;
for($count=1;$count<=$numfetch && $count<=$num;$count++) {

    my ($fh,$tmpfile);
    eval {
        ($fh,$tmpfile) = tempfile($count.'_XXXXXXXXXXXX',
                                  DIR => $inbox,
                                  SUFFIX => '');
    };
    if ($@) {
        my $msg = "Cannot open temporary file $tmpfile: $@";
        syslog('ERR',$msg);
        print STDERR "$msg\n" if $VERBOSE;
    
    }

    my $journal_msg = $pop->HeadAndBody($count);
    if (!$journal_msg) {	# MSG cannot be read
        if (! $fh->close) {
            croak "Cannot write tempfile $tmpfile: $!\n";
        } 
        unlink $tmpfile;
        syslog('ERR',"Cannot fetch mail $count\n");
        next;		
    }

    if ($jcopy) {
        # save journal mail copy
        eval {
            save_journalmail($tmpfile.'.jrnl',$journal_msg);
        };
        if ($@) {
            syslog('ERR',"Cannot fetch mail $count\n");
            die "Error save journalmail. $@\n" if $VERBOSE;
        }
    }

    # download and parse messages
    my ($message,$sender,@recipients);
    eval {
        if ($type == '2003') {
            ($message,$sender,@recipients) = Exchange2003::parse_journalmail($journal_msg);
        }
        elsif ($type == '2007') {
            ($message,$sender,@recipients) = Exchange2007::parse_journalmail($journal_msg);
        }
    };
    if ($@) {
        print $fh $journal_msg; # save original mail data to tmpfile
        if (! $fh->close) {
            croak "Cannot write tempfile $tmpfile: $!\n";
        }
        my $errfile = $tmpfile.'.errdnl';
        if (link $tmpfile, $errfile) {
            unlink $tmpfile;
            my $msg = "Error parse pop3 mail #$count. Saved as $errfile (Original error: $@.";
            print STDERR  "$msg\n" if $VERBOSE;
            syslog('ERR', $msg);
        }
        else {
            my $msg = "Error parse pop3 mail #$count. Saved as $tmpfile (Original error: $@.";
            print STDERR "$msg\n" if $VERBOSE;
            syslog('ERR', $msg);

        }

        next unless $force_delete;
    }

    # save mail in inbox
    eval {
        my $in_whitelist;
        $in_whitelist = check_whitelist($sender,@whitelist);
        my $envelopemsg = "X-REAL-MAILFROM: ".lc $sender."\r\n"; 
        for my $recipient (@recipients) {
            $in_whitelist = check_whitelist($recipient,@whitelist);
            $envelopemsg .= "X-REAL-RCPTTO: ".lc $recipient."\r\n";
        }
        if ($whitelist) {
            die "Sender / Recpient not in whitelist. Skip." if not $in_whitelist;
        }

        print $fh $envelopemsg,$message;
        if (! $fh->close) {
            croak "Cannot write tempfile $tmpfile: $!\n";
        }
        my $emlfile = $tmpfile.'.eml';
        chmod oct $filemode, $tmpfile;
        link $tmpfile, $emlfile or die "Cannot link $tmpfile to $emlfile: $!\n";
        unlink $tmpfile;
    };
    if ($@) {
        my $msg = $@;
        syslog('INFO',"$msg") if $VERBOSE;
        print "$msg" if $VERBOSE;
        unlink $tmpfile;
        next unless $force_delete;
    }

    $pop->Delete($count) if $delete;

    syslog('INFO',"Fetch file #$fetched from POP3 server.\n") if $VERBOSE;
    $fetched++;
}
print "\n" if $VERBOSE;

$pop->Close();
print "Fetched $fetched files from POP3 server.\n" if $VERBOSE;

if ($conf->{statusfile}) {
    open STATUS, ">$conf->{statusfile}" or croak "Cannot open $conf->{statusfile}: $!\n";
    my $timestamp = time();
    print STATUS "$timestamp: $fetched\n";
    print "Status: $timestamp: $fetched\n" if $VERBOSE;
    close STATUS;
}


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


### save_journalfile
#
# Stores a copy of the raw journal message
#
sub save_journalmail
{
    my ($filename,$message) = @_;

    open JOURNAL, ">$filename" or die "Cannot open journalmailfile. $!\n";
    print JOURNAL $message;
    close JOURNAL or die "Cannot close $filename: $!\n";
}


### import whitelist from file
#
# Reads the list of adresses to import
#
sub read_whitelist
{
    my ($wlfile) = @_;

    my @whitelist;
    open my $wl, '<', $wlfile;
    chomp(my @whitelist = <$wl>);
    close $wl;

    return @whitelist;
}


### check if address(es) in whitelist
#
# dies if not in whitelist
#
sub check_whitelist
{
    my ($address,@whitelist) = @_;
    my $iswl = 0;
    foreach my $wladdr (@whitelist) {
        next if $wladdr =~ /^#/;
        next if $wladdr =~ /^$/;
        if ($wladdr =~ /^\@/) {
            $iswl = 1 if $address =~ qr/$wladdr$/;       # domain name
        }
        else {
            $iswl = 1 if $address =~ qr/^$wladdr$/;      # email address
        }
    }

    return $iswl;
}


### Overwrite methods for fancier debugging.
sub Mail::POP3Client::_sockprint
{
  my $me = shift;
  my $s = $me->Socket();
  $me->Debug and print STDERR ">>> ", @_;
  my $outline = "@_";
  chomp $outline;
  push(@{$me->{tranlog}}, $outline);
  print $s @_;
}

sub Mail::POP3Client::_sockread
{
  my $me = shift;
  my $line = $me->Socket()->getline();
  unless (defined $line) {
      return;
  }

  # Macs seem to leave CR's or LF's sitting on the socket.  This
  # removes them.
  $me->{STRIPCR} && ($line =~ s/^[\r]+//);

  $me->Debug and print STDERR "<<< ", $line;
  $line =~ /^[\\+\\-](OK|ERR)/i && do {
    my $l = $line;
    chomp $l;
    push(@{$me->{tranlog}}, $l);
  };
  return $line;
}

# help
#
sub help_exit
{
    print "Aufruf: benno-fetchExchange [-c <configfile>] [-D] -u <user> -p <pass> [-i <inbox dir>] [-H <host>] [-n <num>] [-w <file>] [-s] [-j] [-S] [-v]\n";
    print "  -c <config> read configuration from file\n";
    print "  -D          print debug messages\n";
    print "  -u <user>   pop3 username\n";
    print "  -p <pass>   pop3 password\n";
    print "  -i <dir>    Benno inbox (/srv/benno/inbox)\n";
    print "  -H <host>   hostname (localhost)\n";
    print "  -M <mode>   file mode (default 0640)\n";
    print "  -P <port>   port (110)\n";
    print "  -n <num>    fetch num mails per run (200)\n";
    print "  -d          delete mails on pop3 server\n";
    print "  -s          ssl connect to pop3s (default port 995)\n";
    print "  -t 2003     MS Exchange 2003 journal format (default >= 2007)\n";
    print "  -j          save file with raw journalmail (.jrnl)\n";
    print "  -f          force deletion on POP server on parse errors\n";
    print "  -R <userid> run as <userid> (default benno)\n";
    print "  -A <mode>   force authentication mode (PASS, APOP, CRAM-MD5)\n";
    print "  -S <file>   write current fetch status to file\n";
    print "  -w <file>   whitelist with adresses / \@domains to import (one per line)\n";
    print "  -v          verbose\n";
    print "  -V          version info\n";
    exit 1;
}

### EOP ###
1;


################################################################################
package Exchange2003;
### Exchange2003::parse_journalmail($journal_message)
#
# Returns the message with X-REAL-MAILFROM and X-REAL-RCPTTO headers
#
#  -- parse_journalmail($journal_message)
#       |
#       +-- fetch_envelopes($metadata_part)
#             |
#             +-- unfold_header(\@lines)
#             |
#             +-- extract_envelope($headerline)
#
sub parse_journalmail
{
    my ($journal_msg) = @_;
    my $sender;
    my @recipients;

    my $Parser = new MIME::Parser;
    $Parser->output_to_core(1);
    $Parser->extract_nested_messages(0);
    my $Entity = $Parser->parse_data($journal_msg);

    # journal mail structure of Exchange 2003
    #
    # layer | type                      |
    # ------+---------------------------+----------------------------
    # 0     | multipart/mixed           |
    # 1     |     multipart/alternative |
    # 2     |         text/plain        | envelope information (text)
    # 2     |         text/html         | envelope information (html)
    # 1     |     message/rfc822        | original email

    # fetch part with metadata (layer 1)
    my $num;
    $num = $Entity->parts(0)->parts;
    for (my $i=0;$i<$num;$i++) {
        my $metadata_part = $Entity->parts(0)->parts($i);
        print "Type($i): ",$metadata_part->mime_type,"\n" if $main::DEBUG;
        # fetch envelope data from text/plain part
        next unless $metadata_part->mime_type =~ q{^text/plain};

        ($sender,@recipients) = fetch_envelopes($metadata_part);
        print "Sender: $sender\n" if $main::DEBUG;
        print "Recipient: @recipients\n" if $main::DEBUG;
    }
    unless ($sender || @recipients) {
        die "No sender information in metadata.";
    }

    return $Entity->parts(1)->stringify_body,$sender,@recipients;
}


### ($sender,@recipients) fetch_envelopes($mime_part)
#
# Returns the envelope data of the email
#
#
sub fetch_envelopes
{
    my ($entity) = @_;
    my $senderline;
    my $recipientsline;

    my @lines = $entity->bodyhandle->as_lines;
    while (my $line = shift @lines) {
        if ($line =~ /^Sender:/) {
            chomp $line;
            $senderline = $line;
            $senderline .= unfold_header(\@lines);
        }
        if ($line =~ /^Recipients:/) {
            chomp $line;
            $recipientsline = $line;
            $recipientsline .= unfold_header(\@lines);
        }
    }

    my ($sender) = extract_envelope($senderline);
    my (@recipients) = extract_envelope($recipientsline);

    return $sender,@recipients;
}


### ($headerline) unfold_header(@header_lines)
#
# Returns the unfolded header line
#
sub unfold_header
{
    my $lines = shift;

    my $line;
    if ($lines->[0] =~ /^\s+/) {
        $line = shift @{$lines};
        chomp $line;
        $line .= unfold_header($lines);
    }

    return $line;
}


### (@envelopes) extract_envelope($headerline)
#
# Returns an array with envelope adresses
#
sub extract_envelope
{
    my $metaline = shift;

    my @envelopes;
    foreach my $token (split /\s+/, $metaline) {
        next if $token !~ /\<\S+\@\S+\>/;
        $token =~ s/\<(\S+)\>/$1/;
        $token =~ s/^smtp://i;
        $token =~ s/,$//i;
        push @envelopes,$token;
    }

    return @envelopes;
}

### EOP ###
1;


################################################################################
package Exchange2007;
use MIME::Base64;
### Exchange2007::parse_journalmail($journal_message)
#
# Returns the message with X-REAL-MAILFROM and X-REAL-RCPTTO headers
#
sub parse_journalmail
{
    my ($journal_msg) = @_;

    my $Parser = new MIME::Parser;
    $Parser->output_to_core(1);
    $Parser->extract_nested_messages(0);
    my $Entity = $Parser->parse_data($journal_msg);

    # journal mail structure of Exchange 2007 / 2010
    #
    # layer | type                      |
    # ------+---------------------------+----------------------------
    # 0     | multipart/mixed           |
    # 1     |     text/plain            | envelope information (text || base64)
    # 1     |     message/rfc822        | original email

    # first part contains metadata
    my $MetaData = $Entity->parts(0) or die "Mail does not look like a journalmail";
    my ($sender_header,$senderdata,$onbehalfdata,$sender);
    my @recipients;
    foreach my $line ($MetaData->bodyhandle()->as_lines) {
        $line =~ s/[\r\n]//g;
        my ($header,$value) = $line =~ /^(\S+):\s+(.+)$/i;
        if ($header =~ /^(Recipient|To|Cc|Bcc)$/i) {
            foreach my $token (split /,?\s+/, $value) {          # FS#600
                next if $token =~ /Expanded:/i;
                push @recipients, $token;
            }
            next;
        }

        if ($header =~ /^Sender$/) { $senderdata = $value; }
        if ($header =~ /^On-Behalf-Of$/i) { $onbehalfdata = $value; }

        if ($onbehalfdata) {
            $sender = $onbehalfdata;
        }
        else {
            $sender = $senderdata;
        }
        if ($sender =~ /\@/) {
            $sender =~ s/\<^smtp:/</;
        }

        next;
    }
    unless ($sender || @recipients) {
        die "No sender information in metadata.";
    }

    return $Entity->parts(1)->stringify_body,$sender,@recipients;
}

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

package LWs::RunAs;

use strict;

sub import {
    my ($package,$user) = @_;
    unless( $user ){
        print STDERR __PACKAGE__." must be imported with user to run as.\n";
        exit 1;
    }
    if (($< == 0) || (getpwuid($<) eq $user)) {
        my ($uid,$gid) = (getpwnam($user))[2,3];
        $( = $gid;
        $) = $gid;
        $> = $uid;
        $< = $uid;
    }
    else {
        print STDERR "Program must be run as $user or root.\n";
        exit 2;
    }
}
 
### EOP ###
1;

__END__

