#!/usr/bin/perl
#
# $Id: 19ba9e55cad041706c3755c873717e342115aa5a $
#
# v1.6.6
use strict;
use lib '/etc/perl';
use Getopt::Std;
use Sys::Syslog;
use IO::Socket;
use File::Temp qw/tempfile/;
use IO::File;
use Mail::POP3Client;
use MIME::Parser;
use Carp;

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

help_exit() if $opts{h};

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 $maxfiles = $conf->{maxfiles}  || $opts{m} || 250;
my $numfetch = $conf->{numfetch}  || $opts{n} || 200;
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};

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

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

my $force_delete = $opts{f};

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

my $ERRMSG;

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

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

# Fetch up to $maxfiles - $files_in_inbox mails
my $inbox_count = inbox_counter($inbox);
$numfetch = $maxfiles - $inbox_count;
if ($numfetch <= 0) {
    syslog('WARNING',"Inbox contains $inbox_count mails. Exit.\n");
    exit 0;
}

my $pop = new Mail::POP3Client(
    HOST      => $host,
    PORT      => $port,
    AUTH_MODE => $authmode,
    DEBUG     => $DEBUG,
    USESSL    => $ssl,
);

$pop->User($user);
$pop->Pass($pass);
$pop->Login;

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

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

print "$num mails on server.\n" if $VERBOSE;

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

    my ($fh,$tmpfile) = tempfile($count.'_XXXXXXXXXXXX',
                                 DIR => $inbox,
                                 SUFFIX => '');
    if (defined $fh) {
    	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;
            }
        }

        eval {
            my $message;
            if ($type == '2003') {
                $message = Exchange2003::parse_journalmail($journal_msg);
            }
            elsif ($type == '2007') {
                $message = Exchange2007::parse_journalmail($journal_msg);
            }
            else {
                print STDERR "Incorrect type of metadata given\n" if $VERBOSE;
                help_exit();
            }

            # No envelope header in message
            if ($message !~ /^X-REAL-MAILFROM/) {
                print STDERR "Error parse pop3 mail #$count.\n" if $VERBOSE;
                $fh->close;
                unlink $tmpfile; 
                next unless $force_delete;
            }

            print $fh $message;
            if (! $fh->close) {
                croak "Cannot write tempfile $tmpfile: $!\n";
            }
            my $emlfile = $tmpfile.'.eml';
            link $tmpfile, $emlfile or die "Cannot link $tmpfile to $emlfile: $!\n";
            unlink $tmpfile;
        };
        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;
                print STDERR "Error parse pop3 mail #$count. Saved as $errfile (Original error: $@.\n" if $VERBOSE;
                syslog('ERR',"Error parse pop3 mail #$count. Saved as $errfile (Original error: $@");
            }
            else {
                print STDERR "Error parse pop3 mail #$count. Saved as $tmpfile (Original error: $@.\n" if $VERBOSE;
                syslog('ERR',"Error parse pop3 mail #$count. Saved as $tmpfile (Original error: $@");

            }
            next unless $force_delete;
        }

        $pop->Delete($count) if $delete;
    }
    else {
        syslog('ERR',"Cannot open temp file $tmpfile\n");
    }
    syswrite STDOUT,"." 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;
}

### 
#
# check number of inboxfiles
#
sub inbox_counter
{
    my ($inboxdir) = @_;
    my $counter = 0;

    opendir INBOXDIR, $inboxdir or die "Cannto open $inboxdir: $!";
    while (my $filename = readdir INBOXDIR) {
        next unless $filename =~ /\.eml$/;
        $counter++;
    }
    close INBOXDIR;
    return $counter;
}


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


### 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>] [-s] [-j] [-S]\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 "  -P <port>   port (110)\n";
    print "  -n <num>    fetch num mails per run (200)\n";
    print "  -m <num>    max files in inbox directory (250)\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";
    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.\n";
    }
    my $envelopes = "X-REAL-MAILFROM: ".lc $sender."\r\n"; 
    for my $recipient (@recipients) {
        $envelopes .= "X-REAL-RCPTTO: ".lc $recipient."\r\n";
    }
    return $envelopes.$Entity->parts(1)->stringify_body;
}


### ($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;
### 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)
    # 1     |     message/rfc822        | original email

    # first part contains metadata
    my $MetaData = $Entity->parts(0);
    my ($sender_header,$sender);
    my @recipients;
    foreach my $line (@{$MetaData->body}) {
        $line =~ s/[\r\n]//g;
        my ($header,$value) = $line =~ /^(\S+):\s+(.+)$/i;
        if ($header =~ /^(Recipient|To|Cc|Bcc)$/i) {
            push @recipients, $value;
            next;
        }
        if ($header =~ /^Sender$/) {
            if ($value =~ /\@/) {
                $sender = $value;
                $sender =~ s/\<^smtp:/</;
            }
            else {
                $sender = '<>';
            }
            next;
        }
    }
    unless ($sender || @recipients) {
        die "No sender information in metadata.\n";
    }
    my $message = "X-REAL-MAILFROM: ".lc $sender."\r\n"; 
    my $outline;
    for my $recipient (@recipients) {
        $message .= "X-REAL-RCPTTO: ".lc $recipient."\r\n";
    }
    $message .= $Entity->parts(1)->stringify_body;

    return $message;
}

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

