#!/usr/bin/perl -w
#
# 22-feb-05 dgs Sample file for eximuser group conference
#
use strict;

=head1 NAME

exim.pl -- start up script that is run by exim the MTA before processing mail

=head1 SYNOPSIS

perl_startup = do '/etc/exim/exim.pl'

...in /etc/exim/exim.conf

=head1 DESCRIPTION

Taken from the exim spec document currently at
L<http://www.exim.org/exim-html-3.00/doc/html/spec_9.html#SEC169>
chapter 10:

[W]here `/etc/exim/exim.pl' is Perl code which defines any subroutines you
want to use from Exim.

See the above document for more information on using perl in exim.

=cut


my $MAX_ADDRESSES = 5;
# AH changed DEBUG from 2 to 0 on 03-Dec-1999 16:41 CST
# As it turns out, under $DEBUG > 0, warnings are printed out to the
# sending MTA. In the case of Post.Office sending to exim, when
# sender_verify or sender_try_verify is set to 'true', Post.Office
# will get confused by the extra warnings, i.e. '>>> <some_warning_messages>...'
# and will defer delivery to the exim host (duh!).
my $DEBUG = 2;
my $DUNNO = 'DUNNO';

my $local_part;
my $domain;
my $new_address = '';
my %addresses = ();
my %result;


# insane_address:
# Perform sanity check on the email address being sent to. This reduces
# the burden on the LDAP server if the address is too short (COMPANY1 has a
# three-character minimum) or contains characters that might cause
# it problems.

sub insane_address ($) {
        for (Exim::expand_string('$local_part')) {
                # AH added on 19991113 the two lines containing
                # '$orig_local_part', to guard against segmentation fault
                # crashes of exim while parsing local_parts containing
                # invalid chars (for example: kniferob%hotmail.com)
                my $orig_local_part = $_;
                #if (/[^-.\w]/ || !/[-a-z0-9]{3}/i) {
                # IF and AH: Replaced line above with following 3 lines
                s/[^-.\w]/\./g; # convert any invalid chars to '.'
                s/^\.*/\./;     # min leading '.' & ensure it starts with a '.')
                if (   ($orig_local_part =~ /[^-.\w]/)
                    || !/[\-a-zA-Z0-9]{2}/
                    || (length($_) < 4)
                   )
                {
                        $result{$_} = 'insane';
                        return 1;
                } else {
                        return 0;
                }
        }
}

sub punc_to_dash ($) {
        my $local_part = shift;
        $local_part =~ s/\W+/-/g;
        $local_part;
}

sub punc_to_spc ($) {
        my $local_part = shift;
        $local_part =~ s/[^-a-z0-9]+/ /gi;
        $local_part;
}

sub first_word ($) {
        my $local_part = shift;
        $local_part =~ /([^\W_]+)/;
        $1;
}

sub last_word ($) {
        my $local_part = shift;
        $local_part =~ /(\w+)\W*$/;
        $1;
}

sub cn_match ($) {
        my $query;

        $query .= "(|(cn=$_)(cn=* $_)(cn=* $_ *)(cn=$_ *))"
                for split /[^-a-z0-9]+/, shift;

        "&$query";
}

sub cnstar_match ($) {
        my $query;

        $query .= "(cn=*$_*)"
        #$query .= "(|(cn=$_)(cn=* $_)(cn=* $_*)(cn=$_*))"
                for split /[^-a-z0-9]+/, shift;

        "(&$query)";
}

sub givenname_sn_match ($) {
        my $query;
	my @words=split /[^-a-z0-9]+/, shift;
	if ($#words <= 0) {
	  # Only one word, so return non existent search
	  $query= q{objectclass=exim dummy};
	} else {
	  $query=q{|};
	  foreach my $i (1..$#words) {
	    $query.=q{(&(givenname=}.join(q{ },@words[0..$i-1]).
        	    q{)(sn=}.join(q{ },@words[$i..$#words]).
		    q{))};
	  }
	}
        $query;
}

# strip leading spaces after = on incoming address
sub ldap_who {
    my $mail = 0;

    (my $addresses = shift) =~ s/\b([a-z;]+=)\s+/$1/ig;
    my @addresses = split /\n/, $addresses, $MAX_ADDRESSES;
    
    $local_part = Exim::expand_string('$local_part');
    $domain     = Exim::expand_string('$domain');
    
    ($new_address) = $addresses[0] =~ /mail=([^,\s]+)/;

    $mail = $1;
    
    if ($mail =~ /\@company1.com/i) {

	if ($DEBUG) {
	    warn "invalid email address in record: $mail\n";
	}

	$result{$local_part} = 'invalid_entry';
	$addresses{$local_part} = [@addresses];
    }
    else {
	my $naddresses = $addresses ne $DUNNO ? @addresses : 0;
	
	if ($DEBUG) {
	    warn ">>> $local_part\@$domain returns $naddresses", ($naddresses == 1 ? " ($new_address)" : ""), "\n";
	    warn "$addresses\n" if $DEBUG > 1;
	}
	
	$result{$local_part} =
	    $naddresses == 1 ?
		($new_address ? 'one' : ($addresses{$local_part} = [@addresses], 'one_no_mail')) :
		    $naddresses == 0 ? 'none' :
			$naddresses >= $MAX_ADDRESSES ? 'too_many' :
			    ($addresses{$local_part} = [@addresses], 'multiple');
        $result{$local_part} eq 'one';
    }
}

sub new_address { $new_address }

# $mime_boundary must not be set or else the parent exim will provide
# children with identical copies. So we do a one-time set from within
# the child the first time the sub is actually called..

my $mime_boundary;

sub mime_boundary {
        $mime_boundary ||=
                "WishThatM1MewaSn-tsucHaPain666" .
                sprintf("%x%x%x", $$, rand $$, time);
}

sub mime_bounce {
        my $domain = shift;
        my $gripe = failure_message();
        my $subject = Exim::expand_string('$h_Subject');

        my $msg = <<TEXT;
This is a MIME multipart message. Upgrade your email client today!

--$mime_boundary
Content-type: text/plain; charset=iso-8859-1

$gripe

--$mime_boundary
Content-type: message/rfc822
Content-Disposition: attachment; filename="$subject"

TEXT
        # Commented out by Alex Hristov on 29-Nov-1999
        #eval {
        #       open(FH_MSG, "> /var/spool/exim/mime_bounce/msg.$$");
        #       print FH_MSG $msg;
        #       close(FH_MSG);
        #};
        return $msg;
}

sub bounce_suggestion {
 my $domain = shift;
 "Please try again perhaps including first and last names, for example\n" .
 "<william.shakespeare\@" . $domain . ">, include middle initials, alternative\n" .
 "spellings, etc.\n";
}

# $bounce_footer is set in the parent. If this needs to be dynamic
# use the technique used with $mime_boundary.

my $multiple_bounce_footer = <<MULTIPLEFOOTER;
If you believe that this address should have resolved to a single
recipient or it did so consistently in the past please notify the
Postmaster <postmaster\@company1.com> including as much detail as possible:
at least full name, department, and approximate geographic region
and of course the email address you believe was previously correct.

You may reply to this email and it will be read by someone who will do
their best to help you.

Sorry I couldn't get your message through this time. Your original
message is attached. If you have been given enough information above
to try again, I would suggest re-sending your original message to
the new address.

Best wishes,

Your humble Company1 email server.
Human contact: <postmaster\@company1.com>
MULTIPLEFOOTER

my $single_bounce_footer = <<SINGLEFOOTER;
You may reply to this email and it will be read by someone who will do
their best to help you. You may reply to Postmaster <postmaster\@company1.com> 
including as much detail as possible: at least full name, department,
and approximate geographic region and of course the email address you
believe was previously correct.

Sorry I couldn't get your message through this time. Your original
message is attached. 

Best wishes,

Your humble Company1 email server.
Human contact: <postmaster\@company1.com>
SINGLEFOOTER


# dispatch table used in failure_message()
my %failure_sub = (
#          insane          => \&fail_reject,
#          none            => \&fail_reject,
#          one_no_mail     => \&fail_one_no_mail,
#          multiple        => \&fail_reject,
#          too_many        => \&fail_reject,
#          invalid_entry   => \&fail_reject, 
        insane          => \&fail_insane,
        none            => \&fail_none,
        one_no_mail     => \&fail_one_no_mail,
        multiple        => \&fail_multiple,
        too_many        => \&fail_multiple,
        invalid_entry   => \&fail_reject, 
);

my %failure_reason = (
        insane          => 'invalid address',
        none            => 'no matches at all',
        one_no_mail     => 'single match but no email address',
        multiple        => 'few matches',
        too_many        => 'too many matches',
        invalid_entry   => 'invalid database entry', 
);


# failure_reason called by autoreply transport to make X-LDAP-Uid header

sub failure_reason {
        if (   !defined $result{Exim::expand_string('$local_part')}
            || !$result{Exim::expand_string('$local_part')}
           )
        {
                $failure_reason{'insane'};
        } else {
                $failure_reason{$result{Exim::expand_string('$local_part')}}
        }
}


sub failure_message {
        $local_part = Exim::expand_string('$local_part');
        $domain     = Exim::expand_string('$domain');

        if (   !defined $result{$local_part}
            || !$result{$local_part}
           )
        {
        &{$failure_sub{'insane'}};
        } else {
                &{$failure_sub{$result{$local_part}}};
        }
}

sub show_details {
        my @addresses = @_;
        my $details = '';

        my $d = '(?:\s|$)';
	my $c = '(?:"|,)';
        my $email = 0;
        my @properties;
        foreach (@addresses) {
                @properties = ();
		$email = 0;
		
		if (/cn=/) {
		    if (/cn=$c(.+?)$c/oi) { push @properties, "Name\t\t:  $1"; }
		    elsif (/cn=([^0-9]+?)$d/oi) { push @properties, "Name\t\t:  $1"; }
		}
		if (/uid=$c([a-zA-Z0-9-]+?)$c/oi ){ push @properties, "Uid\t\t:  $1"; }

		if (/mail=$c(.+?)$c/oi) { push @properties, "Email\t\t:  $1"; $email = 1;}

		if (/ou=/) {
		    if (/ou=$c(.+?)$c/oi) { push @properties, "Dept\t\t:  $1"; }
		    elsif (/ou=(.+?)$d/oi) { push @properties, "Dept\t\t:  $1"; }
		}

		if (/o=/) {
		    if (/o=$c(.+?)$c/oi) { push @properties, "Organisation\t:  $1"; }
		    elsif (/o=(.+?)$d/oi) { push @properties, "Organisation\t:  $1"; }
		}

		if (/ l=/) {
		    if (/ l=$c(.+?)$c/oi) { push @properties, "City\t\t:  $1"; }
		    elsif (/ l=(.+?)$d/oi) { push @properties, "City\t\t:  $1"; }
		}

                next if $email;

		if (/telephonenumber=/i) {
		    if (/telephonenumber=$c(.+?)$c/oi) { push @properties, "Tel\t\t:  $1"; }
		    elsif (/telephonenumber=(.+?)$d/oi) { push @properties, "Tel\t\t:  $1"; }
		}

        } continue {
                $details .= join "\n", map {"\t$_"} @properties;
                $details .= "\n\n";
        }

        $details;
}

sub fail_multiple {

    my $header = <<HEADER;

Dear email sender,

This message has been automatically generated because I, the email
server, found more than one email address that could possibly match
<$local_part\@$domain>.

My steering philosophy is that mail should be delivered only to the
addressed individual.  Since the supplied information is insufficient
to locate a specific individual, your message is being returned.

HEADER

    my $help;
    if ($result{$local_part} eq 'too_many') {
	my $bounce_suggestion = &bounce_suggestion($domain);
	$help = <<HELP;

The address given, <$local_part\@$domain> matches more than
$MAX_ADDRESSES possible entries in our database.  In order to make a
delivery you will need to provide an address that is more specific.

$bounce_suggestion

If that fails, please contact <postmaster\@$domain> who will try to
assist you.

HELP

    } else {
	    $help = <<HELP . show_details(@{$addresses{$local_part}});

To help you locate the correct individual, selected fields from the
possible matches are included below.  The uid field is the only one
guaranteed unique within a given community.

HELP
    }

    return $header . $help . <<SIGNOFF;

$multiple_bounce_footer

SIGNOFF
}

sub fail_none {
        warn "$local_part\@$domain does not resolve to any addresses\n" if $DEBUG;

        my $bounce_suggestion = &bounce_suggestion($domain);
        return <<FAIL;

Dear email sender,

This message has been automatically generated because I, the email
server, was unable to find an email address that matched
<$local_part\@$domain>.

The unique uid <$local_part> does not exist in the directory. It
also did not match any last names or full names in the directory.

$bounce_suggestion

$multiple_bounce_footer

FAIL
}

sub fail_one_no_mail {
    warn "$local_part\@$domain finds one match but no email address\n" if $DEBUG;
    my $details = show_details(@{$addresses{$local_part}});
    
    return <<FAIL;

Dear email sender,

This message has been automatically generated because I, the email
server, found a single match looking for <$local_part\@$domain> but
that match contained no forwarding email address and was thus
undeliverable.  The details of this match are as follows:

$details

$single_bounce_footer

FAIL
}


sub fail_entry {
    warn "$local_part\@$domain finds one match but no email address\n" if $DEBUG;
    my $details = show_details(@{$addresses{$local_part}});

    return <<FAIL;

Dear email sender,

This message has been automatically generated because I, the email
server, found a single match for <$local_part\@$domain> but that match
contained an invalid forwarding email address and was thus
undeliverable. The details of this match (including the invalid email
address) are as follows:

$details

$single_bounce_footer

FAIL
}


sub fail_insane {
        warn "$local_part\@$domain is considered an insane address\n" if $DEBUG;

        my $bounce_suggestion = &bounce_suggestion($domain);
        return <<FAIL;

Dear email sender,

This message has been automatically generated because the local part
of the email address supplied, <$local_part\@$domain>, is not a valid
Company1 address. Specifically, the address must comprise only
numbers, letters, underscores, periods or dashes.  It must also be a
minimum of three characters in length.

$bounce_suggestion

$multiple_bounce_footer

FAIL
}

sub fail_reject {
	warn "$local_part\@$domain does not exist(fail_reject)\n" if $DEBUG;

        my $bounce_suggestion = &bounce_suggestion($domain);
        return <<FAIL;
 
Dear email sender,

The account 
 <$local_part\@$domain>
that you have sent an email message to, does not exist.

This may mean that the recipient's address has been changed, the recipient
has left the company, or the recipient's address may have been mistyped.

It may also mean that this email was sent by a spammer with a
ficticious 'From:' address and/or computer generated 'To:' address
without our knowledge or permission. Many spammers are using this
scheme in an effort to hide their true identity. This usually results
in a message being returned to the sender that is difficult to
understand.

If you believe that this message was spam that originated from a domain
owned or managed by Company1, please report this to "abuse\@company1.com".
Company1 has a very strong stance on spam (unsolicited commercial email)
and will take appropriate actions.

There are free tools available which may help you find the origin of the
email. Company1 does not endorse any particular tool, but SpamCop
 http://spamcop.net/ 
may be of assistance.

FAIL
}

sub exim_pl_version {
  my $version;
  $version=q{$Revision: 1.8 $};
  $version=~ s/^\$()Revision: (.*?) +\$$/:$2/;
  return $version;
}