#!/usr/bin/perl
#
# Copyright (C) 2008-2025 Manuel Mausz (manuel@mausz.at)
# http://manuel.mausz.at/coding/autoresponder/
#
# 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;
use v5.38;
binmode(STDOUT, ':utf8');
 
my $VERSION = '0.8';
 
#-------------------------------------------------------------------------------
# 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' => 'UD::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 = Getopt::Long::Parser->new();
$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 = Logger->new(($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->warning("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(my $mailfh, '|-') || exec { $args[0] } @args
  or die("Unable to open mailer: $!");
$mailfh->binmode(':utf8');
$reply->{'reply'}->print($mailfh);
$mailfh->close;
 
# 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.\n")
        if ($hvalue eq '<>' || $hvalue eq "#@[]" || $hvalue =~ /MAILER-DAEMON$/i);
      die("Unable to parse mail address.\n")
        if (!(@addrs = Mail::Address->parse($hvalue)));
      die("Value isn't exactly one mail address.\n")
        if (scalar(@addrs) != 1);
      push(@sender, $addrs[0]);
    }
 
    # check From
    $hname = 'From';
    $headers->unfold($hname);
    die("No value.\n")
      if (!($hvalue = $headers->get($hname)));
    chomp($hvalue);
    die("Message is either invalid or from a mailer daemon.\n")
      if ($hvalue =~ /MAILER-DAEMON$/i || $hvalue =~ /Mail Delivery (?:Sub)?(?:system|service)/i);
    die("Unable to parse mail address.\n")
      if (!(@addrs = Mail::Address->parse($hvalue)));
    die("Value isn't exactly one mail address.\n")
      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.\n")
        if ($hvalue =~ /(?:junk|list|bulk|autoreply)/i);
    }
 
    # check Auto-Submitted
    $hname = 'Auto-Submitted';
    $headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      die("Message is flagged as auto submitted.\n")
        if ($hvalue !~ /no/i);
    }
 
    # check X-Auto-Response-Suppress
    $hname = 'X-Auto-Response-Suppress';
    $headers->unfold($hname);
    if ($hvalue = $headers->get($hname))
    {
      chomp($hvalue);
      die("Message has active uto response suppression.\n")
        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.\n")
        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.\n")
        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.\n")
        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.\n")
        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->warning("Unexpected header value '", $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.");
 
  # remove MIME::Lite added header
  $reply->delete('X-Mailer');
 
  # 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
  $reply->add($_, $myheader->{$_})
    foreach (keys($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 v5.38;
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 = IO::Handle->new();
    $fh->fdopen($args{'handle'}, 'w')
      or return undef;
    binmode($fh, ':utf8');
    push($self->{'handles'}->@*, $fh);
  }
  if (defined($args{'file'}))
  {
    my $fh = IO::File->new($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;
  $_->print(POSIX::strftime("[%Y.%m.%d-%H:%M:%S] ", localtime(time)), @_)
    foreach ($self->{'handles'}->@*);
  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;
  $_->close()
    foreach ($self->{'handles'}->@*);
}
 
#-------------------------------------------------------------------------------
 
__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