#!/usr/bin/perl
use strict;
use warnings;
use Fcntl qw(:flock);
use Encode qw(encode decode);
my %fields;

# (c) 2001-2024/02 Alexander Thomas
# Simple e-mail form script.
# This script is free to use. It may not be sold.
# Use of this script is at your own risk. There is no guarantee
# or liability whatsoever for fitness for any purpose.
#
# INSTRUCTIONS:
# Fill in the correct values in the Parameter section below.
# Make a form on your website with method "POST" and as action the
#   URL of this script on your server. (Of course this script must
#   have execute permissions.)
# You can easily set fixed values for certain fields by making them hidden.
# The form can contain the following fields (case sensitive!):
#   -"from": the e-mail address of the sender
#   -"sendername": the name of the sender
#   -"carboncopy" (checkbox): if this is checked, a copy of the message
#     will be sent to the address in 'from'.
#   -"subject": subject of the mail
#   -"nextpage": the page to be loaded after sending the mail. If empty,
#     the message itself will be displayed instead.
#   -"message": the message itself.
# You can add custom fields by modifying the mail_it subroutine below.

##################################################################
#
# PARAMETER SECTION

# Memo: all @list values must be comma-separated ('like', 'this');

# Your system's e-mail program, typically either /usr/sbin/sendmail or
# /usr/lib/sendmail
my $MAIL_PROGRAM = '/usr/sbin/sendmail';

# The e-mail address to send the mails to.
my $RECIPIENT = 'YOUR@E-MAIL.HERE';

# If not empty, will be used as the "From:" address, and the form's "from" field
# will be used for "Reply-To:" instead. By using an address from the same domain
# as the server this script runs on, you can avoid that mails get filtered out
# by mail servers that do not allow mails coming from a different domain than
# the From: address.
my $SENDFROM = '';

# If not empty, will be forced as Return-Path header. This may help prevent
# messages from being marked as suspicious when used in combination with an SPF
# DNS record.
my $RETURN_PATH = '';

# If set, is where the script can be called from. You'll want to put
# your domain name in here so that only you can run this script.
# Leave off http:// and anything that may be omitted, like 'www.'.
# Use () for no restrictions (not recommended!)
my @VALID_DOMAINS = ('YOUR-DOMAIN-HERE.com');

# Put a list here of IPs that should be blocked. You can also omit the
# last parts, like '12.34.56.' or even '12.34.' to block domains.
my @BLOCKED_IPS = ();

# Enter keywords here for user-agents that should be blocked. If any
# of these strings is found in HTTP_USER_AGENT, the message is rejected.
# Even though this may seem obsolete because most spambots now use fake
# identifiers, some still use a fixed string.
my @BLOCKED_UAS = ('WebaltBot');

# If you specify any of the following parameters, they must point to either an
# existing file that has read & write permissions for the user under which this
# script will run, or a yet to be created file in an existing directory with
# 'rwx' permissions for that user.

# Optional: give the path to a log file to report unusual stuff to.
# (Use '' to disable.)
my $LOGFILE = '';

# Optional: if not empty, dump the last message sent by one of the BLOCKED_UAS
# here, should you be curious what they're trying to send.
my $LOGBLOCK = '';

# Optional: give the path to a file where some status info can be stored, to
# detect and temporarily block people hammering the 'send' button.
my $STATFILE = '';

##################################################################
#
# MAIL LAY-OUT
#
# Makes the message, sends it, and returns what has been sent.
# You can tailor this to your own needs, e.g. add headers or markers.
# Make sure not to remove essential headers like From, To and Subject,
# and make sure the header section ends with \n\n.
sub mail_it
{
	my ($fromLine, $replyToLine) = ('', '');
	if($SENDFROM) {
		$fromLine = 'From: '. getMailAddress($SENDFROM, $fields{'sendername'});
		$replyToLine = safeHeader('Reply-To: '. getMailAddress($fields{'from'}, $fields{'sendername'})) ."\n";
	}
	else {
		$fromLine = 'From: '. getMailAddress($fields{'from'}, $fields{'sendername'});
	}
	my $mailHeaders = safeHeader($fromLine) ."\n";
	$mailHeaders .= "To: ${RECIPIENT}\n";
	if(defined($fields{'carboncopy'}) && $fields{'carboncopy'} eq 'on') {
		$mailHeaders .= safeHeader('Cc: '. getMailAddress($fields{'from'}, $fields{'sendername'}));
	}
	$mailHeaders .= $replyToLine;
	$mailHeaders .= safeHeader("Subject: $fields{'subject'}") ."\n";
	$mailHeaders .= xHeaders();

	my $theMail = $mailHeaders ."\n". $fields{'message'} ."\n\n";

	sendMail($theMail);
	return $theMail;
}

# Output from this method should still be sent through safeHeader, as it may be
# based on form input.
sub getMailAddress
{
	my ($address, $name) = @_;
	my $from = '';
	$from = $address if defined($address);
	return $from if(! defined($name) || $name eq '');
	$name = encode('MIME-Header', decode('UTF-8', $name));
	return "\"${name}\" <${from}>";
}

# This is only intended for logging. Use getMailAddress for headers.
sub getFromAddress
{
	return safeHeader(getMailAddress($fields{'from'}, $fields{'sendername'}));
}

sub sendMail
{
	my ($theMail, $noReturnPath) = @_;
	my $xtra = '';
	$xtra = " -f ${RETURN_PATH}" if($RETURN_PATH ne '' && !$noReturnPath);
	open(MZT, '|-', "${MAIL_PROGRAM} -t${xtra}") || die "Unable to send mail: $^E";
	print MZT $theMail;
	close(MZT);
}

##################################################################
# You can extend this function to test for a mandatory answer on
# a simple question, to thwart spambots. You could also use a
# 'mouse trap' field, which must be empty, and reject messages
# where this field is not empty.
sub test_required
{
	my $testmail = '';
	$testmail = $fields{'from'} if(defined $fields{'from'});
	if($testmail ne '' && bad_address($testmail)) {
		$testmail =~ s/</&lt;/g;
		$testmail =~ s/>/&gt;/g;
		error_exit('Invalid address', "<B>Bad e-mail format: ${testmail}</B><br><br>Press your browser's 'BACK' button to return to the entry form.", '400 Bad Request');
	}

	# Example spambot detection: a 'bait' field called "mail" must be left empty.
#	if( defined($fields{'mail'}) && $fields{'mail'} ne '' ) {
#		error_exit("Access denied", "You triggered the spambot detection. If you are human, go back and do not enter anything into fields that must be left empty.", '400 Bad Request');
#	}
}


##################################################################
##### No user serviceable parts below! #####
##################################################################

# MAIN ###########################################################
# This is where the script starts execution from

decode_vars();
valid_page();
test_required();
test_spamming();

my $theMail = mail_it();

if($fields{'nextpage'}) {
	print <<__END__;
Status: 307 Temporary Redirect
Location: $fields{'nextpage'}

__END__
}
else {
	$theMail =~ s/&/&amp;/g;
	$theMail =~ s/</&lt;/g;
	$theMail =~ s/>/&gt;/g;
	print_html('Message sent', 'Message sent', "<PRE>${theMail}</PRE>");
}
exit;


# SUBROUTINES ####################################################

##################################################################
# Decodes form variables into hash %fields
sub decode_vars
{
	my $temp = '';
	if($ENV{'REQUEST_METHOD'} eq 'GET' || $ENV{'REQUEST_METHOD'} eq 'HEAD') {
		$temp = $ENV{'QUERY_STRING'};
	}
	elsif($ENV{'REQUEST_METHOD'} eq 'POST') {
		read(STDIN, $temp, $ENV{'CONTENT_LENGTH'}) if(defined $ENV{'CONTENT_LENGTH'});
	}
	else {
		error_exit('Method Not Allowed', 'What the title says.', '405 Method Not Allowed');
	}
	my @pairs = split(/&/, $temp);
	foreach my $item (@pairs) {
		my ($key, $content) = split(/=/, $item, 2);
		if(! defined $key) {
			error_exit('Malformed form data', 'Form data is malformed, which most likely means you are a bot. Bots are requested to go to /dev/null.', '400 Bad Request');
		}
		$content = '' if(! defined $content);
		$content =~ tr/+/ /;
		$content =~ s/%(..)/pack('U',hex($1))/ge;

		# We are not interested in typewriter compatibility.
		$content =~ s/\r\n/\n/g;
		$fields{$key} = $content;
	}
}

##################################################################
# Basic tests on whether access is allowed
sub valid_page
{
	my $check = $ENV{'HTTP_REFERER'};
	if(@VALID_DOMAINS && $check) {
		my $referer_ok = 0;
		foreach my $ref (@VALID_DOMAINS) {
			$ref = "\Q${ref}\E";
			if($check =~ m|https?://([^/]*)$ref|i) {
				$referer_ok = 1;
				last;
			}
		}
		if($referer_ok != 1) {
			error_exit('Access denied', "<B>Sorry! You can't run this script from your server. Please use your own script.</B><br>", '403 Forbidden');
		}
	}

	$check = $ENV{'REMOTE_ADDR'};
	if(@BLOCKED_IPS && $check) {
		foreach my $ip (@BLOCKED_IPS) {
			if($check =~ m/^\Q${ip}\E/) {
				write_log('blocked IP');
				error_exit('Access denied', "You are not allowed to send mail because there has been a case of abuse originating from your address. There are two possibilities:<br>1. Your internet connection uses a shared access point (e.g. proxy server) and an other user of the same network is responsible. In this case we're sorry, but we really can't block users on a finer grain than this.<br>2. You are the offender. No further explanation necessary.", '403 Forbidden');
			}
		}
	}

	$check = $ENV{'HTTP_USER_AGENT'};
	if(@BLOCKED_UAS && $check) {
		my $uaIndex = 0;
		foreach my $ua (@BLOCKED_UAS) {
			$uaIndex++;
			if($check =~ m/\Q${ua}\E/) {
				write_log("blocked UA: match #${uaIndex}");
				if($LOGBLOCK) {
					open(my $fHandle, '>', $LOGBLOCK) or die "Failed to open '${LOGBLOCK} for writing: $!\n";
					print $fHandle "$fields{'subject'}\n\n$fields{'message'}\n" if(flock($fHandle, LOCK_EX));
					close($fHandle);
				}
				error_exit('Access denied', 'No spambots allowed.', '403 Forbidden');
			}
		}
	}
}


##################################################################
# Detect whether the sender is spamming the web form, when they got past
# all other protections, which probably means it's a real human acting
# like an idiot or hooligan.
# Lines are recorded in $STATFILE as: "$IP Spam $lastSentTime $penalty"
#   (lines not matching this format are ignored).
# If an IP sends mail before lastSentTime+penalty, multiply penalty by 2,
# show error message, and update $STATFILE.
# If an IP sends mail after $lastSentTime+penalty or there was no entry,
# reset penalty to 15.
# Remove any 'Spam' lines whose $lastSentTime+penalty has expired.
sub test_spamming
{
	return if($STATFILE eq '');

	my $timeNow = time;
	my $fHandle;
	if(-f $STATFILE) {
		open($fHandle, '+<', $STATFILE) or die "Cannot open '${STATFILE}': $!";
	}
	else {
		# There's still an abysmally small risk of WaW conflict here, but nobody cares
		open($fHandle, '+>', $STATFILE) or die "Cannot create '${STATFILE}': $!";
	}
	flock($fHandle, LOCK_EX);
	my $senderIP = getFullAddress();
	my (%ipDataSpam, %ipDataOther);
	my ($newSentTime, $newPenalty, $youreABadBoy);
	foreach (<$fHandle>) {
		chomp;
		my ($ip, @entry) = split(/ /, $_);
		next if(! @entry);
		if($entry[0] ne 'Spam') {
			$ipDataOther{$ip} = \@entry;
			next;
		}
		my ($lastSentTime, $penalty) = ($entry[1], $entry[2]);
		# Drop expired entries
		next if($lastSentTime + $penalty <= $timeNow);
		if($ip ne $senderIP) {
			$ipDataSpam{$ip} = [$lastSentTime, $penalty];
			next;
		}
		($newSentTime, $newPenalty) = ($lastSentTime, $penalty);
	}
	if($newSentTime) {
		$youreABadBoy = 1;
		$newPenalty *= 2;
	}
	else {
		$newPenalty = 15;
	}
	$newSentTime = $timeNow;
	$ipDataSpam{$senderIP} = [$newSentTime, $newPenalty];

	seek($fHandle, 0, 0);
	truncate($fHandle, 0);
	foreach my $key (keys %ipDataSpam) {
		print $fHandle join(' ', ($key, 'Spam', @{$ipDataSpam{$key}})) ."\n";
	}
	foreach my $key (keys %ipDataOther) {
		print $fHandle join(' ', ($key, @{$ipDataOther{$key}})) ."\n";
	}
	close($fHandle);

	if($youreABadBoy) {
		my $from = getFromAddress();
		my $oldPenalty = $newPenalty/2;
		write_log("antispam: ${senderIP} ${from} (penalty ${oldPenalty})");
		error_exit('Patience is a Virtue', "Your message was not sent because you have sent a message or retried less than <EM>${oldPenalty} seconds</EM> ago.<br>\nYou must now wait <STRONG>${newPenalty} seconds</STRONG> before you can send a new mail.<br>\nYou can spend this time thinking about whether it really is necessary to send another message (or worse, the same message again).<br>\nThe penalty time will double each time it is violated.", '429 Too Many Requests');
	}
}

# Attempt to get an identifier as complete as possible. This is unavoidably
# dodgy because of NAT/proxy and lack of a standard or even requirement to forward
# the internal network address, but it's better to try than to give up.
# http://stackoverflow.com/questions/527638/getting-the-client-ip-address-remote-addr-http-x-forwarded-for-what-else-coul
sub getFullAddress
{
	my $addr = $ENV{'REMOTE_ADDR'};
	$addr .= '/'.$ENV{'HTTP_X_FORWARDED_FOR'} if(defined($ENV{'HTTP_X_FORWARDED_FOR'}));
	$addr .= '/'.$ENV{'HTTP_CLIENT_IP'} if(defined($ENV{'HTTP_CLIENT_IP'}));
	$addr .= '/'.$ENV{'HTTP_X_FORWARDED'} if(defined($ENV{'HTTP_X_FORWARDED'}));
	$addr .= '/'.$ENV{'HTTP_X_CLUSTER_CLIENT_IP'} if(defined($ENV{'HTTP_X_CLUSTER_CLIENT_IP'}));
	$addr .= '/'.$ENV{'HTTP_FORWARDED_FOR'} if(defined($ENV{'HTTP_FORWARDED_FOR'}));
	$addr .= '/'.$ENV{'HTTP_FORWARDED'} if(defined($ENV{'HTTP_FORWARDED'}));
	return $addr;
}

##################################################################
# Returns 0 if the argument seems a valid e-mail address
sub bad_address
{
	my ($mailaddr) = @_;
	return 1 if($mailaddr eq '');
	return 1 if($mailaddr =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)/ ||
	            $mailaddr =~ / / ||
	            $mailaddr !~ /^.+\@(\[?)[a-zA-Z0-9\-\.]+\.([a-zA-Z]{2,3}|[0-9]{1,3})(\]?)$/);
	return 0;
}

##################################################################
# Return a string that is safe to put in a mail header (e.g. ensure
# newlines are followed by a space to thwart attempts at header
# injection). Any header constructed from user-submitted text must
# be sent through this function!
sub safeHeader
{
	my ($line) = @_;
	# A newline followed by a space is equivalent to a space. By not simply
	# dropping the newline, failed attempts at header injection remain visible.
	$line =~ s/\n([^ ])/\n $1/g;
	# RFC 822 does not define a maximum length, but RFC 5322 limits it to 998 characters.
	# Actually this limit concerns a single line and not the entire header, but I am too
	# lazy to implement that. Under no circumstances should any header reach this limit
	# anyhow when called from the pages on my website.
	$line = substr($line, 0, 998) if(length($line) > 998);
	return $line;
}

##################################################################
# Adds extra optional header fields
sub xHeaders
{
	# I trust the address ENV variables to be safe.
	my $head = "X-Http-Remote-Addr: $ENV{'REMOTE_ADDR'}\n";
	if(defined($ENV{'HTTP_X_FORWARDED_FOR'}) && $ENV{'HTTP_X_FORWARDED_FOR'} ne '') {
		$head .= "X-Http-Forwarded-For: $ENV{'HTTP_X_FORWARDED_FOR'}\n";
	}

	# If you wish, you can add optional hidden 'BrowserType' and 'Referrer' fields to
	# your web form, and fill these by means of some JavaScript, this may help to
	# detect and filter out spammers.
	my $userAgent = "X-Http-User-Agent: $ENV{'HTTP_USER_AGENT'}";
	$userAgent .= "; $fields{'BrowserType'}" if(defined($fields{'BrowserType'}) && $fields{'BrowserType'} ne '');
	$head .= safeHeader($userAgent) ."\n";

	my $referers = "X-Http-Referer: $ENV{'HTTP_REFERER'}";
	$referers .= "; $fields{'Referrer'}" if(defined($fields{'Referrer'}) && $fields{'Referrer'} ne '');
	$head .= safeHeader($referers) ."\n";

	return $head;
}

##################################################################
# Requires three arguments: page title, text title, and page text.
# Optional 4th argument is custom HTTP response status (should be
# number followed by status message).
sub print_html
{
	my ($pTitle, $title, $text, $status) = @_;

	if($status) {
		$title = "${status}" if(! $title);
		print "Status: ${status}\n";
	}
	$title = "<H1>${title}</H1>\n" if($title ne '');

	print <<__END__;
Content-Type: text/html; charset=utf-8

<!DOCTYPE html>
<HTML lang="en">
<HEAD><TITLE>${pTitle}</TITLE>
<META name="robots" content="noindex">
<META name="viewport" content="width=device-width, initial-scale=1.0">
</HEAD><BODY>
${title}
${text}
</BODY>
</HTML>
__END__
}

##################################################################
# Requires two arguments: title and message.
# Optional 3rd argument is custom HTTP response status.
sub error_exit
{
	my ($title, $errmesg, $status) = @_;
	print_html('Error', $title, "<P>${errmesg}</P>", $status);
	exit;
}

##################################################################
sub write_log
{
	return if(! $LOGFILE);

	my $logData = shift;
	# Open file in append mode. This also creates the file if it doesn't exist.
	open(my $logFD, '>>', $LOGFILE) || die "Can't open '${LOGFILE}': $^E";
	flock($logFD, LOCK_EX);  # (test for success intentionally left out)
	my $date = localtime();
	print $logFD "[lexmail] ${date} ${logData}; $ENV{'REMOTE_ADDR'}";
	print $logFD " ($ENV{'HTTP_X_FORWARDED_FOR'})" if($ENV{'HTTP_X_FORWARDED_FOR'});
	my $logAgent = $ENV{'HTTP_USER_AGENT'};
	$logAgent = '(agent undefined)' if(! defined $logAgent);
	$logAgent =~ s/\n/ /g;
	print $logFD ", ${logAgent}\n";
	close($logFD);
}