#!/usr/bin/perl

use strict;
use warnings;

my $config = 'resend.conf';
#my $config = '/usr/local/simplelists/resend.conf';

my $my_domain        = 'simplelists.com';
my $email_support    = "support\@$my_domain";
my $from_support     = qq{"Simplelists.com" <$email_support>};
my $mailto_support   = "<mailto:$email_support>";
my $email_nobody     = "nobody\@$my_domain";
my $my_website       = 'www.simplelists.com';
my $approve_link     = "https://$my_website/members/approval.php";
my $unsubscribe_link = "http://$my_website/unsubscribe.php";

use Sys::Syslog;
use DBI;
use URI::Escape;
#use Time::HiRes     qw(clock);
use String::Random;
use Config::General qw(ParseConfig);
use IO::File;
use Mail::Message;
use Mail::Transport::Sendmail;
use HTML::TreeBuilder;
use HTML::FormatText;

sub accept_incoming($$$);
sub addr_match($$;$);
sub bounce_incomimg($$$$);
sub caught_die($);
sub check_header($$$);
sub check_body($$);
sub check_parts($$);
sub check_sender($$);
sub create_taboo_check($);
sub get_account_config($$);
sub get_list_config($);
sub is_subdomain($$);
sub mangle_body($$);
sub mangle_header($$$);
sub mangle_parts($$);
sub parse_addrs($);
sub process_incoming_message();
sub rand_word();
sub return_to_sender($$$);
sub substitute_values($$);
sub tempfail($);
sub trim($);
sub test_mangle();
sub wrap_body_rules($);

if(@ARGV)
{   exit test_mangle() ? 0 : 1
        if @ARGV==1 && $ARGV[0] eq '--test-mangle';

    die "Usage: $0 [--test-mangle]\n";
}

# listconfig moderate values
use constant
 { MODERATE_ALL           => 1   # moderate all messages
 , MODERATE_BY_LIST       => 2   # restrict by list(s)
 , MODERATE_ALLOW_MEMBERS => 4   # allow list members to post
 , MODERATE_ALLOW_ALL     => 8   # allow other addresses to post

 , ADDR_EQUAL             => 1
 , ADDR_IGNORE_SUBDOMAIN  => 2
 , ADDR_USER_IN_DOMAIN    => 3
 , ADDR_USER_IN_SUBDOMAIN => 4   # currently the only one used

 , NOTIFY_KEEP_SILENT     => 0   # keep and don't notify
 , NOTIFY_KEEP_OWNER      => 1   # keep and notify owner
 , NOTIFY_BIN_EMAILS      => 2   # not really a notification
 , NOTIFY_BIN_NON_MEMBERS => 3   # bin emails if user not on list
 };

# very dirty global
my $sample_message = '';

#
### Start logging
#

openlog 'resend', 'cons,pid', 'local0';

my $debug = 0;
sub debug(@) { syslog(info => '%s', join '', @_) if $debug }

$SIG{__DIE__}  = \&caught_die;

open STDERR, qq{|/usr/bin/logger -p local0.err -t "resend[$$]: STDERR"}
    or die "Unable to redirect STDERR to logger\n";

my %prog_options = ParseConfig $config;
my $debug_dir    = "$prog_options{HOMEDIR}/debug";
my ($dbname, $dbuser, $dbpass, $archive_user, $archive_host)
  = @prog_options{qw/DBNAME DBUSER DBPASS ARCHIVE_USER ARCHIVE_HOST/};
my @surety_addresses = @{$prog_options{SURETY}};

#
### Connect to the database
#   When the database connection fails, the incoming message will
#   not have been read.
#

my $dbh = DBI->connect("DBI:mysql:$dbname", $dbuser, $dbpass)
    or tempfail "Unable to connect to database $dbname: $DBI::errstr";

#
### Handle one message
#   To daemonize this implementation, fork here

my ($listname, $domain, $listfull);  # could be avoided using OO
process_incoming_message;

#
### Cleanup nicely
#

$dbh->disconnect;
closelog;
exit 0;

# Control the processing of one message
sub process_incoming_message()
{
    debug 'collect the message';
    my $fromline = <STDIN>; # Ignore first From line
    my $msg  = Mail::Message->read(\*STDIN)
        or die "no valid message received from STDIN\n";
    
    # Look for listname
    # Delivered-To: resend+test=simplelists.com@earth.simplelists.com
    
    my $delivered_to = $msg->get('delivered-to')
        or die "no Delivered-To header\n";
    
    $delivered_to =~ m/^.*\+ (.*) \= (.*) \@/ix
        or die "no list found in Delivered-To header: $delivered_to";
    
    ($listname, $domain) = (lc $1, lc $2);
    $listfull = $listname .'@'. $domain;
    
    debug "List name is $listname domain $domain";
    
    my $account     = get_account_config $domain, $listname
        or die "unable to get account config for $listfull\n";

    my $list_config = get_list_config $account
        or die "unable to get list config for $account->{id}\n";
    
    if($account->{debug})
    {   # write message to debug file
        my $debugfn   = "$debug_dir/debug.$domain.$listname";
        if(my $debugfile = IO::File->new($debugfn , '>>'))
        {   $msg->print($debugfile);
            $debugfile->close;
        }
    }
    
    #
    # Message checking starts here
    #
    
    debug 'About to parse the header';
  
    my ($head_msg, $head_approved) = check_header $msg, $list_config, $account;
    
    $head_msg .= "Approval required: All messages moderated"
        if +($list_config->{moderate} & MODERATE_ALL) && !$head_approved;
    
    # Parse the body
    debug 'About to parse the message body';
    
    my ($body_msg, $body_approved) = check_body $msg, $list_config;
    
    my $result_msg = $head_msg . $body_msg;
    my $approved   = $head_approved && $body_approved;
    
    if($result_msg =~ /\S/ && !$approved)
    {   # Yes Tigger, *now* you can bounce.  We've checked for
        # any Approved headers & lines, taboo_headers, and taboo_bodies
        bounce_incomimg $msg, $list_config, $account, $result_msg;
    }
    else
    {   accept_incoming $msg, $list_config, $account;
    }
}

# The message is accepted (not bounced), but needs to be cleaned-up
# before distribution.
sub accept_incoming($$$)
{   my ($msg,  $list_config, $account) = @_;

    my $mangled = mangle_body $msg, $list_config;
    mangle_header $mangled, $list_config, $account;

    # Deliver the message
    # $postfix_conf specifies the Postfix instance that will be used
    # Different Postfix instances are set up for sending mail on different
    # IP addresses, depending on the list
    my $postfix_conf = $account->{trusted}
      ? $prog_options{TRUSTED_CONF} : $prog_options{UNTRUSTED_CONF};

    my $return_path = 'owner-'.$listfull;
    my $mailer = Mail::Transport::Sendmail->new(sendmail_options
       => [ -C => $postfix_conf, -f => $return_path, "-XV"]);

    # Update message count for the list
    $dbh->do(<<__MSG_COUNT, {}, $account->{id}, $listname);
UPDATE lists SET messages=messages+1 WHERE userid=? AND name=?
__MSG_COUNT

    # Get recipients for email
    my ($sth, $sender_hdr);
    if($account->{listtype} eq 'single')
    {   $sender_hdr = "$listname-manager\@$my_domain";
        my $query = $account->{trusted} ? <<'__TRUSTED' :<<'__UNTRUSTED';
SELECT email, members.unsubscribe AS unsubscribe
  FROM addresses LEFT JOIN members
       ON addresses.id = members.addresses_id
 WHERE userid = ?
   AND digest = 0
__TRUSTED

SELECT email, members.unsubscribe AS unsubscribe
  FROM addresses LEFT JOIN members
       ON addresses.id = members.addresses_id
 WHERE userid  = ?
   AND confirm = 'con.firmed'
   AND digest  = 0
__UNTRUSTED

        $sth = $dbh->prepare($query);
        $sth->execute($account->{id});
    }
    else
    {   $sender_hdr = "list-manager\@$domain";
        my $query = $account->{trusted} ? <<'__TRUSTED' : <<'__UNTRUSTED';
SELECT addresses.email AS email, members.unsubscribe AS unsubscribe
  FROM members, addresses
 WHERE members.lists_id =
       ( SELECT id FROM lists
          WHERE name    = ?
            AND userid  = ?
       )
   AND addresses.id     = members.addresses_id
   AND addresses.digest = 0
__TRUSTED

SELECT addresses.email AS email, members.unsubscribe AS unsubscribe
  FROM members, addresses
 WHERE members.lists_id  =
       ( SELECT id FROM lists
          WHERE name     = ?
            AND userid   = ?
       )
   AND addresses.id      = members.addresses_id
   AND addresses.confirm = 'con.firmed'
   AND addresses.digest  = 0
__UNTRUSTED

        $sth = $dbh->prepare($query);
        $sth->execute($listname, $account->{id});
    }

    my $head = $mangled->head;
    $head->set(Sender => $sender_hdr);

    # Trawl through all the recipient addresses and send to each one
    while(my $row = $sth->fetchrow_hashref)
    {
        # Each mail is updated with the unique unsubscribe header
        my $list_un = $mailto_support;
        if(my $un = $row->{unsubscribe})
        {   $list_un = "<$unsubscribe_link?id=$un>"
                     . "<mailto:unsubscribe-$un\@$my_domain>";
        }
        $head->set('List-Unsubscribe' => $list_un);

        debug "Sending to $row->{email}";
        $mailer->send($mangled, to => $row->{email});
    }

    my $bwuse = $sth->rows * $msg->size;       # XXX or $mangled->size?
    $sth->finish;

    # Send to all the SuretyMail addresses (junk mail monitoring)
    if($account->{suretymail})
    {   $head->set('List-Unsubscribe' => $mailto_support);
        foreach my $addr (@surety_addresses)
        {   debug "Sending to $addr";
            $mailer->send($msg, to => $addr);  # XXX or $mangled?
        }
    }

    # Send to archives email address, which sends to archives file
    # We don't send directly so that this works on the backup mail host
    # (the archive emails will just wait in queue)
    # XXX ???

    $head->set('List-Unsubscribe' => $mailto_support);
    debug 'Sending to list archive';

    # Sendmail without VERP
    $mailer = Mail::Transport::Sendmail->new;
    my $archive = "$archive_user+$listname=$domain\@$archive_host";
    $mailer->send($mangled, to => $archive);

    # Log the total data transfer used
    $dbh->do("SET time_zone = '+0:00'");
    $dbh->do(<<__LOG, {}, $account->{id}, -$bwuse, "List message ($listfull)");
INSERT INTO bwuse (userid,bwchange,reason,date) VALUES (?,?,?,NOW())
__LOG
}

#
# check for a valid sender for moderated lists.
#

sub check_sender($$)
{   my ($msg, $list_config) = @_;
    my $head = $msg->head;

    debug 'Entering check_sender';

    # Uh, who?
    my $from = $head->get('from') or return <<'__NO_FROM';
This may be hard to believe, but there was no "From:" field
in this message I just received.  I'm not gonna send it out,
but you can...
__NO_FROM

    my @restricts = split /\n/, $list_config->{restrict_post};
    my $reply_to  = $head->get('reply-to') || '';

    foreach my $restrict (@restricts)
    {   debug "Checking sender: $restrict";

        my $moderate = $list_config->{moderate} || MODERATE_ALLOW_ALL;
        if($restrict =~ /\@/)
        {   # restrict by email address
            if($moderate & MODERATE_ALLOW_ALL)
            {   return '' if addr_match $from, $restrict;
                return '' if $reply_to ne $from
                          && addr_match $reply_to, $restrict;
            }
        }

        elsif($moderate & MODERATE_ALLOW_MEMBERS)
        {   my $sth;
            if($domain eq $my_domain && $listname eq $restrict)
            {   # All members
                $sth = $dbh->prepare(<<'__ALL_MEMBERS');
SELECT email
  FROM addresses
 WHERE userid = (SELECT id FROM users WHERE listname=?)
__ALL_MEMBERS
                $sth->execute($listname);
            }
            else
            {   # Subset of members
                $sth = $dbh->prepare(<<'__SUBDOMAIN_MEMBERS');
SELECT addresses.email AS email
  FROM members, addresses
 WHERE members.lists_id = (SELECT id FROM lists WHERE name=?
   AND userid           = (SELECT id FROM users WHERE domain=?)
   AND addresses.id     = members.addresses_id
__SUBDOMAIN_MEMBERS

                $sth->execute($restrict, $domain);
            }

            while(my $row = $sth->fetchrow_hashref)
            {   return '' if addr_match $from, $row->{email};
                return '' if $reply_to ne $from
                          && addr_match $reply_to, $row->{email};
            }
            $sth->finish;
        }
    }

    # We only get here if nothing matches.
    " Email address [$from] not permitted to send to list ";
}

#
# check_header.
#  Returns a non-zero length string if
#  a taboo or administrative header is found.
#

sub check_header($$$)
{   my ($msg, $list_config, $account) = @_;
    my ($gonna_bounce, $approved) = ('', 1);

    # Check for approved message
    # This header is set by the web interface when approving a message
    my $approve_password = $list_config->{approve_passwd};

    my $head = $msg->head;
    if(my $appr = $head->get('X-Approved'))
    {   if($appr =~ /^\Q$approve_password/)
        {   $head->delete('X-Approved');
            $approved = $approve_password;
        }
    }

    #Check for approve password in subject
    if(my $subj = $head->get('subject'))
    {   if($subj =~ s/^\Q$approve_password//) {
            $head->set(Subject => $subj);
            $approved = $approve_password;
        }
    }

    # check for taboo_headers
    my $taboo_headers =
        substitute_values $list_config->{taboo_headers}, $listname;

    if(my $has_taboos = create_taboo_check $taboo_headers)
    {   if(my $taboo = $has_taboos->(\$head->string))
        {   $gonna_bounce .= qq{taboo header (possible mail loop): "$taboo"};
            $approved      = 0;
        }
    }

    # Is the sender allowed to post?
    $gonna_bounce .= check_sender $msg, $list_config
        if +($list_config->{moderate} & MODERATE_BY_LIST) && !$approved;

    ($gonna_bounce, $approved);
}

sub check_body($$)
{   my ($msg, $list_config) = @_;

    # make sure the message is not too long
    my $max = $list_config->{maxlength};
    if($max && $msg->size > $max)
    {   debug 'parse_body: message too long';
        return ("Message too long (>$max chars) ", 0);
    }

    check_parts $msg, $list_config;
}

sub mangle_header($$$)
{   my ($msg, $list_config, $account) = @_;
    my $head = $msg->head;

    # Remove these headers
    $head->delete('x-confirm-reading-to');        # pegasus mail (windoze)
    $head->delete('disposition-notification-to'); # eudora
    $head->delete('x-ack');
    $head->delete('return-receipt-to');
    $head->delete('errors-to');
    $head->delete('flags');
    $head->delete('x-pmrqc');
    $head->delete('return-path');

    # Add subject prefix if not already added
    if(my $prefix = $list_config->{subject_prefix})
    {   my $foo = substitute_values $prefix, $listname;

        # prepend subject prefix
        if(my $subject = $head->get('subject'))
        {   $head->set(Subject => "$foo $subject")
                 unless $subject =~ /\Q$foo/;
        }
        else # No existing subject line
        {   $head->set(Subject => $foo);
        }
    }

    # add new header fields
    $head->set(Precedence => "bulk");

    # Set new reply-to if need be
    if(my $rt = $list_config->{reply_to})
    {   $head->set('Reply-To' => substitute_values $rt, $listname);
    }

    # Set new from if need be
    if(my $smf = $list_config->{set_message_from})
    {   $head->set(From => $smf);
    }

    # print out per-list additonal headers
    if(my $mh = $list_config->{message_headers})
    {   my $headers = substitute_values $mh, $listname;
	$head->set($_)
            for split /\n/, $headers;
    }
}

sub wrap_body_rules($)
{   my $list_config = shift;

    my $mf = $list_config->{message_footer} // '';
    my $footer = length $mf ? $mf : undef;

    my $footer_html;
    my $mfh = $list_config->{message_footer_html} // '';
    if(length $mfh)
    {   $footer_html = $mfh;
    }
    elsif($footer)
    {   my $html = $footer;
        $html    =~ s#\b(http://[[:alnum:][:punct:]]+)\b#<a href="$1">$1</a>#i;
        $html    =~ s/\n/<br>\n/g;
        $footer_html = "\n<tt>$html</tt>";
    }

    my $fronter;
    my $mfr = $list_config->{message_fronter} // '';
    if(length $mf)
    {   $fronter      = $mfr;
        $fronter      =~ s/\001|$/\n/g;
    }

    my $fronter_html;
    my $mfrh = $list_config->{message_fronter_html} // '';
    if(length $mfrh)
    {   $fronter_html = $mfrh;
    }
    elsif(defined $fronter)
    {   $fronter_html = $fronter;
        $fronter_html =~ s#\b(http://[[:alnum:][:punct:]]+)\b#<a href="$1">$1</a>#i;
        $fronter_html =~ s/\n/<br>\n/g;
        $fronter_html = "<tt>$fronter_html</tt>";
    }

    my $need_wrap_text = defined $fronter || defined $footer;
    my $wrap_text = sub ($$@) {
       my ($msg, $part, %opts) = @_;

       $need_wrap_text
           or return $part;

       $part->body->mimeType eq 'text/plain'
           or return $part;

       $need_wrap_text = 0;
       my $decoded = $part->decoded;
       my $newpart = (ref $part)->new
         ( head      => $part->head->clone
         , container => undef
         );
       my $newbody = (ref $decoded)->new
         ( based_on  => $decoded
         , data      => ($fronter//'') . $decoded . ($footer//'')
         );
       $newpart->body($newbody);
       $newpart;
    };

    my $need_wrap_html = defined $fronter_html || defined $footer_html;
    my $wrap_html = sub ($$@) {
       my ($msg, $part, %opts) = @_;

       $need_wrap_html
           or return $part;

       $part->body->mimeType eq 'text/html'
           or return $part;

       $need_wrap_html = 0;
       my $decoded = $part->decoded;
       my $newpart = (ref $part)->new
         ( head      => $part->head->clone
         , container => undef
         );
       my $newbody = (ref $decoded)->new
         ( based_on  => $decoded
         , data      => ($fronter_html//'') . $decoded . ($footer_html//'')
         );
       $newpart->body($newbody);
       $newpart;
    };

    ($wrap_text, $wrap_html);
}

sub remove_attachment_rule($$@)
{   my ($msg, $part, %opts) = @_;
    $part->isNested && !$part->isText ? undef : $part;
}

sub mangle_body($$)
{   my ($msg, $list_config) = @_;

    # See Mail::Message::Construct::Rebuild/Adding your own rules
    my @extra_rules = wrap_body_rules $list_config;

    push @extra_rules, \&remove_attachment_rule
        if $list_config->{strip_attachments};

    $msg->rebuild
      ( keep_message_id => 1
      , extra_rules     => \@extra_rules
      );
}

sub check_parts($$)
{   my ($msg, $list_config) = @_;
    my $body = $msg->body;
    my $type = $body->mimeType;  # MIME::Type object

    my ($gonna_bounce, $approved) = ('', 1);

    if($msg->isMultipart)
    {   foreach my $part ($msg->parts)
        {   my ($bounce, $appr) = check_parts $part, $list_config;
            $gonna_bounce     .=  $bounce;
            $appr or $approved = 0;
        }
        return ($gonna_bounce, $approved);
    }

    if($msg->isNested)
    {   return check_parts $msg->nested, $list_config;
    }

    my $decoded = $msg->decoded;
    my $text_ref;
    if($type eq 'text/plain')
    {   # Store the message to send a sample on bounce
        #XXX horrible global variable!!
        my @sample_message = $decoded->lines;
        $#sample_message   = 29 if @sample_message >= 30;
        $sample_message    = join "\n", @sample_message;
        $text_ref  = \$decoded->string;
    }
    elsif($type eq 'text/html')
    {   my $tree   = HTML::TreeBuilder->new_from_content($decoded);
        my $format = HTML::FormatText->new;
        $text_ref  = \$format->format($tree);
    }

    if(my $has_taboos = create_taboo_check $list_config->{taboo_body})
    {   my $taboo = $has_taboos->($text_ref);
        $gonna_bounce .= qq{ taboo body match "$taboo" }
             if defined $taboo;

    }
    ($gonna_bounce, $approved);
}

sub create_taboo_check($)
{   my $ruleset = shift;
    $ruleset =~ m/\S/ or return;

    my @rules;
    foreach my $rule (split /\n/, $ruleset)
    {   push @rules, eval "sub { $rule ? '\Q$rule\E' : undef }";
    }

    sub { local $_ = ${$_[0]};
          foreach my $rule (@rules)
          {   my $taboo = $rule->() or next;
              return $taboo;
          }
        };
}

sub bounce_incomimg($$$$)
{   my ($msg, $list_config, $account, $reason) = @_;
    my $head     = $msg->head;

    my $return_to_sender = 1;  # whether to inform sender of bounce

    my $from     = head->get('from');
    my $subject  = $head->get('subject') || '[No Subject]';

    my $is_member;  # Whether the sender is a list member

    my $notify   = $account->{notify_approval};
    if ($notify==NOTIFY_BIN_EMAILS)
    {   syslog(info =>
           "Email from %s for list %s held for approval and deleted (%s)",
           $from, $listfull, $reason);

        $return_to_sender = 0;
    }

    elsif($notify==NOTIFY_BIN_NON_MEMBERS)
    {   # Trim from header down to just email address
        my $fromcut = Mail::Message::Field::Address->parse($from);
        $fromcut = $fromcut->address;

        my $sth = $dbh->prepare(<<'__FIND_SENDER');
SELECT email
  FROM addresses
 WHERE email=? AND userid=?
__FIND_SENDER
        $sth->execute($fromcut, $account->{id});
        ($is_member) = $sth->fetchrow_array;
        $sth->finish;

        unless($is_member)
        {   # email not found therefore bin and return
            syslog(info =>
               "Email from %s for list %s from non-member so deleted",
                $from, $listfull);
            $return_to_sender = 0;
        }
    }

    my $unique_msg_code;
    if(    $notify==NOTIFY_KEEP_SILENT
       ||  $notify==NOTIFY_KEEP_OWNER
       || ($notify==NOTIFY_BIN_NON_MEMBERS && $is_member))
    {   # Save message to database for approval later
        $unique_msg_code = rand_word;
        $dbh->do(<<'__FOR_APPROVAL', {},
INSERT INTO approval (lists_id,reason,message,code) VALUES (?,?,?,?)
__FOR_APPROVAL
                $list_config->{id}, $reason, $msg->string, $unique_msg_code);

        syslog(info => "Email from %s for list %s held for approval (%s)",
            $from, $listfull, $reason);
    }

    if(   $notify==NOTIFY_KEEP_OWNER
      || ($notify==NOTIFY_BIN_NON_MEMBERS && $is_member))
    {   # Now notify list manager there is a message waiting approval
        # See if we have a custom moderator
        my $approveto
           = $list_config->{moderator} ? $list_config->{moderator}
           : $domain eq $my_domain     ? "$listname-manager\@$my_domain"
           :                             "list-manager\@$domain";

        if($reason && $notify!=NOTIFY_KEEP_SILENT)
        {   $reason =~ s/^ +//;
            my $username = uri_escape $account->{username};

            # If the recipient is only a moderator then do not give
            # option to log in.
            my $review_option
              = $list_config->{moderator} ? undef : <<__PLEASE_REVIEW;
To review the full message please goto:
$approve_link?username=$username

__PLEASE_REVIEW

            my $mailer = Mail::Transport::Sendmail->new(sendmail_options
              => [-C => $prog_options{MISC_CONF}] );

            my $approve_notify_msg = Mail::Message->build
                ( From     => $from_support
                , To       => $approveto
                , Subject  => "Approval required for $listfull"
                , data     => <<__REQUIRES_APPROVAL );
An email message requires your approval. Details as follows:

List:    $listfull
From:    $from
Subject: $subject
Reason:  $reason

$review_option
To approve the message immediately please goto
$approve_link?approve=$unique_msg_code

To reject the message immediately please goto
$approve_link?delete=$unique_msg_code


The first few lines of the message are shown below:
========================================================================
$sample_message

========================================================================
__REQUIRES_APPROVAL

            $mailer->send($approve_notify_msg);
        }
    }

    # Notify sender of bounced message if required
    if($return_to_sender)
    {   my $to = $head->get('reply-to') || $head->get('from');
        return_to_sender $to, $account, $head;
    }

    debug 'bounce exiting';
    1;
}

# Return to Sender
# Emails sender to tell them message has been held
sub return_to_sender($$$)
{   my ($from, $account, $head) = @_;

    debug 'rts enter';

    # Get custom bounce message if it exists
    my $sth = $dbh->prepare(<<'__CUSTOM_BOUNCE');
SELECT lists.bounce_message as bounce_message
  FROM lists,users
 WHERE users.domain = ?
   AND lists.name   = ?
   AND lists.userid = users.id
__CUSTOM_BOUNCE

    $sth->execute($domain, $listname);
    my $ref = $sth->fetchrow_hashref;

    my $bounce_message;
    if(defined $ref->{bounce_message})
    {
        $ref->{bounce_message}  # empty: user doesn't want one
            or return 0;

        $bounce_message = $ref->{bounce_message};
        my $original_subject = $head->get('subject');
        $bounce_message =~ s/\$SUBJECT/$original_subject/g;

    }
    else
    {   # bounce message is NULL then we use the default
        my $subject     = $head->get('subject') || '[No Subject]';
        $bounce_message = <<__BOUNCE_MESSAGE;
A message that you sent to $listfull with the subject
   $subject
is being held for approval. This could be for a number of reasons
such as:

  - only members are allowed to send messages
  - all messages are held for approval first
  - the email list has a limit on the size of emails
  - its content may have caused it to be held

The list owner has been notified and may approve your message.

If the message has been held because of the email address you sent it
from, then it is recommended that in future you send messages from an
address that is subscribed to the list.
__BOUNCE_MESSAGE
    }

    my $rts_subject = "Your message for $listfull held";

    # Don't send the message if the 2 subjects match. This is a sign
    # that there is a mail loop. Who would send a message to a list with
    # the subject along the lines of "you message has been held"??
    my $subject = $head->get('subject');
    if($subject && $rts_subject eq $subject)
    {   syslog info =>
           "Approval notification not sent - suspected mail loop for list %s",
           $listfull;
        return 0;
    }

    # Get list manager email
    my $manager_email = ($account->{listtype} eq 'single' ? $listname : 'list')
     . "-manager\@$domain";

    # Construct message
    my $mailer = Mail::Transport::Sendmail->new(sendmail_options
       => [ -C => $prog_options{MISC_CONF}, -f => $email_nobody ]);

    my $send = Mail::Message->build
       ( From     => qq["$account->{confname}" <$manager_email>]
       , To       => $from
       , Subject  => $rts_subject
       , data     => $bounce_message
       );

    $mailer->send($send);

    debug 'rts exit';
    1;
}

sub trim($)
{   my $string = shift;
    $string =~ s/ ^\s+ | \s+$ | ^\n+ | \n+$ //gx;
    $string;
}

sub get_account_config($$)
{   my ($domain, $listname) = @_;

    my ($listtype, $sth);
    if($domain eq $my_domain)
    {   $listtype = 'single';
        $sth = $dbh->prepare(<<'__SINGLE_LIST');
SELECT id,manager,notify_approval,trusted,debug,suretymail,confname,username,domain
  FROM users
 WHERE listname = ?
__SINGLE_LIST
        $sth->execute($listname);
    }
    else
    {   $listtype = 'multiple';
        $sth = $dbh->prepare(<<'__MULTI_LIST');
SELECT id,manager,notify_approval,trusted,debug,suretymail,confname,username,domain
  FROM users
 WHERE domain = ?
__MULTI_LIST
        $sth->execute($domain);
    }
    unless($sth->rows)
    {   $sth->finish();
        return;
    }

    my $account = $sth->fetchrow_hashref;
    $account->{listtype} = $listtype;
    $sth->finish();

    $account;
}

sub get_list_config($)
{   my $account = shift;
    my $sth     = $dbh->prepare(<<'__LISTCONFIG');
SELECT *
  FROM lists
 WHERE name = ? AND userid = ?
__LISTCONFIG
    $sth->execute($listname, $account->{id});
    unless($sth->rows)
    {   $sth->finish;
        return;
    }
    my $list_config = $sth->fetchrow_hashref;
    $sth->finish;

    $list_config;
}

sub substitute_values($$)
{    my ($string, $list) = @_;
     if(defined $string && $string =~ m/\$/)
     {   $string =~ s/(?<!\\)\$LIST/$list/g;
         $string =~ s/(?<!\\)\$DOMAIN/$domain/g;
     }
     $string;
}

sub caught_die($)
{   my $error = shift;

    syslog err => 'Died with %s', $error;

    $dbh->disconnect if $dbh;
    closelog();
    exit 1;
}

sub tempfail($)
{   my $error = shift;

    syslog err => 'Died with temporary problem - %s', $error;
    $dbh->disconnect if $dbh;
    closelog;

    # Reply with a temp code - Postfix will attempt to redeliver
    print "4.2.4 The mailing list is currently unable to distribute this message\n$error\n";

    exit 1;
}

sub parse_addrs($)
{   my $addr = eval { Mail::Message::Field::Addresses->parse(shift) };
    $@ ? () : $addr->addresses;
}

sub is_subdomain($$) { $_[0] =~ m/\b\Q${_[1]}\E$/i }

# compare two email address to see if they "match"
sub addr_match($$;$)
{   my ($a1, $a2, $partial) = @_;
    length $a1 && length $a2
        or return 0;

    $partial ||= ADDR_USER_IN_SUBDOMAIN;

    debug "addr_match: comparing $a1 against $a2";

    return index(lc($a1), lc($a2)) >= 0
        if $partial==ADDR_EQUAL;

    # If the field contains multiple addresses, only the first is
    # being checked.
    (my $addr1) = parse_addrs $a1;
    (my $addr2) = parse_addrs $a2;

    $addr1 && $addr2  # parse error or missing value
	or return;

    my ($user1, $domain1) = split /\@/, $addr1;
    my ($user2, $domain2) = split /\@/, $addr2;

    if($partial==ADDR_IGNORE_SUBDOMAIN && $addr1 ne $addr2)
    {   # addresses are like foo@baz.bax.edu, foo@bax.edu
        return 1
            if $user1 eq $user2 && is_subdomain $domain1, $domain2;
    }
    elsif($partial==ADDR_USER_IN_DOMAIN && $addr1 ne $addr2)
    {   # addresses are like foo@bax.edu, @bax.edu
        return 1
            if $domain1 eq $domain2 && $user2 eq "";
    }
    elsif($partial==ADDR_USER_IN_SUBDOMAIN && $addr1 ne $addr2)
    {   # addresses are like foo@baz.bax.edu, @bax.edu
        return 1
	    if  $user2 eq "" && is_subdomain $domain1, $domain2;
    }

    $addr1 eq $addr2;
}

sub rand_word()
{   my $code = String::Random->new;
    $code->{A} = [ 'A'..'Z', 'a'..'z' ];
    $code->randpattern('A' x 32);
}

sub test_mangle()
{   eval "require Storable";
    die $@ if $@;
    my $instructions = Storable::fd_retrieve(\*STDIN);
    my ($msg, $list_config, $account) = @$instructions;

    my $mangled = mangle_body $msg, $list_config;
    mangle_header $mangled, $list_config, $account;

    $mangled->print;
    0;
}

1;
