#!/usr/bin/perl
#
# Copyright (C) 2008-2016 Manuel Mausz (manuel@mausz.at)
# http://manuel.mausz.at/coding/autoresponder/
# Origin code copyright (c) 2004-2008 Parallels GmbH (http://www.parallels.com)
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

use Getopt::Long;
use Pod::Usage;
use Mail::Internet;
use Mail::Address;
use MIME::Lite;
use Encode qw(encode);
use Time::HiRes qw(gettimeofday);
use DBI;
use strict;
use warnings;
use utf8;
binmode(STDOUT, ':utf8');

my $VERSION = '0.7';

#-------------------------------------------------------------------------------
# DATABASE TABLE LAYOUT
#-------------------------------------------------------------------------------

# this table is required for running this software and is used for detecing
# loops. create this table inside the confixx database.
#
# CREATE TABLE `autoresponder_seen` (
#   `ident` int(11) NOT NULL,
#   `sender` varchar(255) NOT NULL,
#   `time` datetime NOT NULL,
#   `server_id` varchar(32) NOT NULL,
#   KEY `ident` (`ident`),
#   KEY `server_id` (`server_id`)
# );
#
# ALTER TABLE `autoresponder` CHANGE `emailtext` `emailtext` TEXT NOT NULL;

#-------------------------------------------------------------------------------
# SENDMAIL INFORMATION
#-------------------------------------------------------------------------------

# if you're using sendmail be sure to modify sendmail.cf so it will pass the
# header "Return-Path" to the executable. this can usually be done by adding
# the char "P" to the field F in line "prog".
# e.g. from:
#   Mprog,   P=/usr/sbin/smrsh, F=lsDFMoqeu9, S=EnvFromL/HdrFromL, ....
# to:
#   Mprog,   P=/usr/sbin/smrsh, F=lsDFMoqeu9P, S=EnvFromL/HdrFromL, ....

#-------------------------------------------------------------------------------
# START OF CONFIGURATION
#-------------------------------------------------------------------------------

# confixx database configuration
# grep from confixx_main.conf
my %db = (
  dsn  => 'INSERT VALUE OF $db_address FROM confixx_main.conf',
  user => 'INSERT VALUE OF $dbUser FROM confixx_main.conf',
  pass => 'INSERT VALUE OF $dbPw FROM confixx_main.conf'
);

# confixx installationid/serverid
my $cfx_serverid = 'INSERT VALUE OF $ServerID FROM confixx_main.conf';

# path to mailer for sending the reply
my $mailer = 'INSERT VALUE OF $bin_sendmail FROM confixx_main.conf';

# used to specify the period in which addresses are kept and are not responded
# to, specified in seconds. should be at least set to 1 day (=86400).
my $respond_period = 86400;

# this/these header/s will be added to every generated reply
# and checked to detect some loops more easily
my %myheader = ('X-Mailer' => 'Confixx Autoresponder');

# this can be enabled if its important to exit with exitcode 0 (=success)
# on all errors. this means "mail sent successfully" although an error occured.
# useful for not keeping "error-generating" mails in the mailserver queue.
#$SIG{'__DIE__'} = sub { our $log; (defined($log) && $log->can('error')) ? $log->error("Error: ", @_) : print STDERR "Error: ", @_; exit(0); };

# default debugging options. may be useful to watch for errors without
# passing commandline options. see --help for description
my $debuglvl = 0;
my $logfile  = undef;
#my $debuglvl = 3;
#my $logfile  = "/tmp/autoresponder.log";

#-------------------------------------------------------------------------------
# END OF CONFIGURATION
#-------------------------------------------------------------------------------

my %args = ();
my $getopt = new Getopt::Long::Parser();
$getopt->configure('prefix_pattern=--|-');
$getopt->getoptions(
  \%args,
  'i|ident=i',
  'd|debug=i',
  'h|help',
  'l|log=s',
  'v|version',
) or pod2usage(2);

pod2usage(1)
  if $args{'h'};

if ($args{'v'})
{
  print "Autoresponder enhanced v", $VERSION, " for Parallels Confixx 3.0.0 and above", $/;
  exit 0;
}

# create logger
$args{'d'} = $args{'d'} || $debuglvl || 0;
$args{'l'} = $args{'l'} || $logfile  || undef;
our $log = new Logger(($args{'l'}) ? (file => $args{'l'}) : (handle => \*STDERR), level => $args{'d'})
  or die("Couldn't create logger: $!");

# fetch ident
my $ident = $args{'i'} || $ARGV[0];
pod2usage(-msg => "Error: No ident given.")
  if (!defined($ident) || length($ident) <= 0);
$log->debug("Got ident value: ", $ident, $/);

# parse mail
$log->debug("Parsing mail...", $/);
my $mail = Mail::Internet->new(\*STDIN)
  or die("Unable to parse mail.");

# parse headers
$log->debug("Parsing headers...", $/);
my $hdata = check_headers($mail->head(), \%myheader);

# connect to database
$log->debug("Connecting to database...", $/);
my $dbh = DBI->connect($db{'dsn'}, $db{'user'}, $db{'pass'})
  or die("Can't connect to database: ".DBI->errstr);
$dbh->{'mysql_enable_utf8'} = 1;

# remove old entries in database
$log->debug("Removing outdated entries from database...", $/);
$dbh->do(
  q(DELETE FROM `autoresponder_seen` WHERE `time` < UTC_TIMESTAMP() - INTERVAL ? SECOND AND `server_id`=?),
  undef, ($respond_period, $cfx_serverid)
) or die("Unable to execute database query: ", DBI->errstr);

# check database for loops
$log->debug("Checking if sender is already known...", $/);
my @cnt = $dbh->selectrow_array(
  q(SELECT COUNT(*) FROM `autoresponder_seen` WHERE `ident`=? AND `sender`=? AND `server_id`=?),
  undef, ($ident, $hdata->{'sender'}->address(), $cfx_serverid)
) or die("Unable to execute database query: ", DBI->errstr);
if (scalar($cnt[0]) > 0)
{
  $log->info("Loop detected.", $/);
  exit(0);
}

# fetch reply data from database
$log->debug("Fetching autoresponder data...", $/);
my $ardata = $dbh->selectrow_hashref(
  q(SELECT `absenderemail`, `absendername`, `emailbetreff`, `emailtext`, `kunde`,
    NOW() between `valid_from` and `valid_till` as `active`
    FROM `autoresponder` WHERE `ident`=? AND `server_id`=?),
  undef, ($ident, $cfx_serverid)
);
if (!defined($ardata))
{
  $log->warning("Unable to fetch autoresponder data from database. Maybe wrong ident.", $/);
  exit(0);
}

if (!$ardata->{'active'})
{
  $log->info("Autoresponder is not active.", $/);
  exit(0);
}

$ardata->{'emailtext'} =~ s/\r//g;

# create reply
my $reply = generate_reply($ardata, $hdata, \%myheader);

# send mail via mailer executable
$log->debug("Sending reply...", $/);
my @args = ($mailer, '-ti', '-f', $reply->{'from'}->address());
open(MAIL, '|-') || exec { $args[0] } @args
  or die("Unable to open mailer: $!");
binmode(MAIL, ':utf8');
$reply->{'reply'}->print(\*MAIL);
close(MAIL);

# insert sender into database
$log->debug("Inserting sender into database...", $/);
$dbh->do(
  q(INSERT INTO `autoresponder_seen` SET `ident`=?, `sender`=?, `time`=UTC_TIMESTAMP(), `server_id`=?),
  undef, ($ident, $hdata->{'sender'}->address(), $cfx_serverid)
) or die("Unable to execute database query: ", DBI->errstr);

# cleanup
$log->info("Reply sent successfully.", $/);
$dbh->disconnect();
$log->close();

#-------------------------------------------------------------------------------

sub check_headers
{
  my ($headers, $myheader) = @_;
  my ($hname, $hvalue) = undef;
  my (@sender, @addrs) = ();
  my $subject = "";
  our $log;

  eval
  {
    local $SIG{'__DIE__'};

    # qmail delivers return-path via environment
    $headers->replace($hname, $ENV{'RPLINE'})
      if (defined($ENV{'RPLINE'}));

    # debug stuff
    $log->debug("Headers of incoming mail:", $/, $mail->head()->as_string());

    # check Return-Path
    $hname = 'Return-Path';
    $headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      die("Message is either invalid, bounced or from a mailer daemon.")
        if ($hvalue eq '<>' || $hvalue eq "#@[]" || $hvalue =~ /MAILER-DAEMON$/i);
      die("Unable to parse mail address.")
        if (!(@addrs = Mail::Address->parse($hvalue)));
      die("Value isn't exactly one mail address.")
        if (scalar(@addrs) != 1);
      push(@sender, $addrs[0]);
    }

    # check From
    $hname = 'From';
    $headers->unfold($hname);
    die("No value.")
      if (!($hvalue = $headers->get($hname)));
    chomp($hvalue);
    die("Message is either invalid or from a mailer daemon.")
      if ($hvalue =~ /MAILER-DAEMON$/i || $hvalue =~ /Mail Delivery (?:Sub)?(?:system|service)/i);
    die("Unable to parse mail address.")
      if (!(@addrs = Mail::Address->parse($hvalue)));
    die("Value isn't exactly one mail address.")
      if (scalar(@addrs) != 1);
    push(@sender, $addrs[0]);

    # check Precedence
    $hname = 'Precedence';
    $headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      die("Message is either junk, bulk or from mailing list.")
        if ($hvalue =~ /(?:junk|list|bulk|autoreply)/i);
    }

    # check X-Auto-Response-Suppress
    $hname = 'X-Auto-Response-Suppress';
    $headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      die("Message is has auto response suppress header.")
        if ($hvalue =~ /(?:all|oof|autoreply)/i);
    }

    # check X-Spam-Status
    $hname = 'X-Spam-Status';
    $headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      die("Message is junk.")
        if ($hvalue =~ /yes/i);
    }

    # check for mailing list
    foreach ('List-Id', 'List-Help', 'List-Subscribe', 'List-Unsubscribe',
             'List-Post', 'List-Owner', 'List-Archive', 'Mailing-List',
             'X-Mailing-List', 'X-ML-Name', 'X-List')
    {
      $hname = $_; # explicit assignment needed
      die("Message is from mailing list.")
        if (($hvalue = $headers->get($hname)) && chomp($hvalue));
    }

    # check Subject
    $hname = 'Subject';
    #$headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      die("Message is bounced.")
        if ($hvalue =~ /^Delivery Status Notification \(Failure\)$/i || $hvalue =~ /Automated reply/i);
      $subject = $hvalue;
    }

    # check my own headers
    foreach (keys(%$myheader))
    {
      $hname = $_; #  explicit assignment needed
      die("Message is signed by myself. Probably looping.")
        if (($hvalue = $headers->get($hname)) && chomp($hvalue) && $hvalue eq $myheader->{$hname});
    }

    # check Reply-To
    $hname = 'Reply-To';
    $headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      # we'll only respond to the first mail address
      push(@sender, $addrs[0])
        if ($hvalue !~ /MAILER-DAEMON$/i && (@addrs = Mail::Address->parse($hvalue)));
    }
  };
  if ($@)
  {
    my $error = $@;
    $log->info("Invalid header '", $hname, "': ", $error);
    $log->debug("Header value: '", $hvalue, "'.", $/);
    exit(0);
  };

  my $sender = (reverse(@sender))[0];

  # fetch some additional headers
  my $references = $headers->get('References') || "";
  my $messageid  = $headers->get('Message-ID') || "";
  chomp($references);
  chomp($messageid);

  # debug stuff
  $log->debug("Sender:     ", $sender->format(), $/);
  $log->debug("Subject:    ", $subject,          $/);
  $log->debug("References: ", $references,       $/);
  $log->debug("Message-ID: ", $messageid,        $/);

  return {
    sender     => $sender,
    subject    => $subject,
    references => $references,
    messageid  => $messageid
  };
}

#-------------------------------------------------------------------------------

sub generate_reply
{
  my ($ardata, $hdata, $myheader) = @_;

  # generate from
  my $from = Mail::Address->new($ardata->{'absendername'}, $ardata->{'absenderemail'})
    or die("Unable to parse sender address for reply.");

  # generate subject
  my $subject = $ardata->{'emailbetreff'};
  $subject = "Auto: " . $hdata->{'subject'}
    if (!length($subject) && length($hdata->{'subject'}));
  $subject = "Automated reply"
    if (!length($subject));

  my $addr_encode = sub
  {
    return encode('MIME-Header', $_) . ' <' . $_[0]->address() . '>'
      if (defined(local $_ = $_[0]->phrase()) && length($_));
    return $_[0]->address();
  };

  # create reply
  $log->debug("Generating reply...", $/);
  my $reply = MIME::Lite->new(
    From     => $addr_encode->($from),
    To       => $addr_encode->($hdata->{'sender'}),
    Subject  => encode('MIME-Header', $subject),
    Data     => $ardata->{'emailtext'},
    Type     => 'text/plain; charset=UTF-8',
  ) or die("Unable to create reply object.");

  # create message-id + threading
  my ($seconds, $microseconds) = gettimeofday();
  my $messageid = sprintf("<%x.%06d.%x@%s>", $seconds, $microseconds,
    rand(2**32 - 1), $from->host());
  $reply->add('Message-ID', $messageid);
  $reply->add('In-Reply-To', $hdata->{'messageid'})
    if (length($hdata->{'messageid'}));
  $reply->add('References', join(' ', $hdata->{'references'}, $hdata->{'messageid'}))
    if (length($hdata->{'references'}) || length($hdata->{'messageid'}));

  # add some other headers
  foreach (keys(%$myheader))
  {
    $reply->add($_ = $myheader->{$_});
  }
  $reply->add('Precedence',     'bulk');
  $reply->add('Auto-Submitted', 'auto-replied');
  $reply->add('X-Auto-Response-Suppress', 'All');

  # debug stuff
  $log->debug("Created reply:", $/, $reply->as_string(), $/);

  return {
    reply => $reply,
    from  => $from
  };
}

#-------------------------------------------------------------------------------

package Logger;
use IO::Handle;
use IO::File;
use POSIX ();
use Carp;
use strict;
use warnings;
use constant ERROR   => 0;
use constant WARNING => 1;
use constant INFO    => 2;
use constant DEBUG   => 3;

$VERSION = "0.1";

sub new
{
  my $class = shift;
  my $self = {};
  my %args = @_;

  bless($self, $class);

  @{$self->{'handles'}} = ();
  if (defined($args{'handle'}))
  {
    my $fh = new IO::Handle();
    $fh->fdopen($args{'handle'}, 'w')
      or return undef;
    binmode($fh, ':utf8');
    push(@{$self->{'handles'}}, $fh);
  }
  if (defined($args{'file'}))
  {
    my $fh = new IO::File($args{'file'}, "a")
      or return undef;
    # this is needed for standard confixx qmail installation
    chmod(0660, $args{'file'});
    binmode($fh, ':utf8');
    push(@{$self->{'handles'}}, $fh);
  }
  croak("No logging destination defined")
    if (scalar(@{$self->{'handles'}}) <= 0);

  $self->{'level'} = (defined($args{'level'})) ? $args{'level'} : WARNING;

  $self;
}

sub print
{
  my ($self) = shift;
  foreach my $fh (@{$self->{'handles'}})
  {
    $fh->print(POSIX::strftime("[%Y.%m.%d-%H:%M:%S] ", localtime(time)), @_);
  }
  return 1;
}

sub printlvl
{
  my ($self, $level) = (shift, shift);
  return
    if ($self->{'level'} < $level);
  return $self->print(@_);
}

sub debug   { shift->printlvl(DEBUG,   @_); }
sub info    { shift->printlvl(INFO,    @_); }
sub warning { shift->printlvl(WARNING, @_); }
sub error   { shift->printlvl(ERROR,   @_); }

sub close
{
  my ($self) = shift;
  foreach my $fh (@{$self->{'handles'}})
  {
    $fh->close();
  }
}

#-------------------------------------------------------------------------------

__END__

=head1 NAME

Autoresponder - Enhanced autoresponder for Parallels Confixx 3.0.0 and above

=head1 SYNOPSIS

B<autoresponder.pl>
I<E<lt>identE<gt>>
[ B<-l> I<logfile> ]
[ B<-d> I<debuglevel> ]
[ B<-v> ]

=head1 OPTIONS

=over 4

=item I<E<lt>identE<gt>>

=item B<-i> I<number>, B<--ident=>I<number>

The autoresponders ident number.

=item B<-l> I<logfile>, B<--log=>I<logfile>

Path to logfile. Default is stderr

=item B<-d> I<debuglevel>, B<--debug=>I<debuglevel>

Specify debug level. Default is 0=off

=item B<-v>, B<--version>

Print version number and exit.

=item B<-h>, B<--help>

Print this usage message.

=back

=head1 USAGE

in F<aliases>:

confixx-du-<ident>: "|/usr/bin/autoresponder.pl <ident>"

=head1 AUTHOR

Manuel Mausz E<lt>manuel@mausz.atE<gt>
L<http://manuel.mausz.at/coding/autoresponder/>

Origin code from Parallels GmbH (L<http://www.parallels.com>)

=cut