#!/usr/bin/perl
# ------------------------------------------------------------------------------------
# Copyright (c) 2012, 2013 Marco Opper
#
# 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 3 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, see <http://www.gnu.org/licenses/>.
#
# You can run this file through either pod2man or pod2html to produce pretty
# documentation in manual or html file format (these utilities are part of the
# Perl 5 distribution).
#
# ------------------------------------------------------------------------------------
use Net::SMTP;
use Net::SMTP::SSL;
use Net::SSLeay;
use IO::File;
use IO::Socket::INET;
use IO::Socket::SSL;
use MIME::QuotedPrint;
use MIME::Base64 qw[encode_base64 decode_base64];
use Getopt::Long;
use Pod::Usage;
use Term::ANSIColor qw(:constants);

### SMTP reply codes
use constant {
	smtp_reply_domainok	 => 220, 	# <domain> Service ready
	smtp_reply_ok 		 => 250,	# requested mail action okay, completed
	smtp_reply_startmail => 354,	# start mail input; end with <CRLF>.<CRLF>
};

### SMTP default ports
use constant {
	port_default_smtp  => 25,
	port_default_smtps => 465,		# SMTP SSL/TLS
	port_default_smtpt => 587,		# SMTP STARTTLS
};

### misc. constants
use constant {
	smtp_offline => 0x00,
	smtp_online	 => 0x01,
	smtp_logged  => 0x10,
	smtp_crlf	 => "\015\012",
	lf			 => "\012",
	cr			 => "\015",
	### content-transfer encoding
	enc_64		 => q(base64),
	enc_8b	 	 => q(8bit),
	enc_qp	 	 => q(quoted-printable),
	### content-type
	type_plain	 => q(text/plain),
	type_html	 => q(text/html),
	type_multi	 => q(multipart/mixed),
};

{ package mail;
  use MIME::Base64 qw[encode_base64 decode_base64];

 sub new {
	my ($caller, %args) = @_;
	my $class = ref $caller || $caller;
	my $self = bless { %args }, $class;

	$self->{content} = q(text/html; charset=UTF8);
	$self->{header} = [];
	$self->{attachments} = [];
	$self->{serializer} = {
		from 	  => sub { return "From: ".$_[0]; },
		to 		  => sub { return "To: ".join ("; ", @{$_[0]}); },
		cc 		  => sub { return "CC: ".join ("; ", @{$_[0]}); },
		subject   => sub { return "Subject: ".$_[0]; },
		content   => sub { return "Content-Type: $_[0]"; },
		useragent => sub { return "User-Agent: $_[0]"; },
		codec	  => sub { return "Content-Transfer-Encoding: $_[0]"; },
		dpos	  => sub { return "Content-Disposition: $_[0]"; },
	};
	return $self;
 }

 sub addHeader {
	my ($self, $type, $val) = @_;
	push @{$self->{header}}, { type => $type, val => $val };
 }

 sub setText {
	$_[0]->{text} = $_[1];
 }

 sub appendAttachment
 {
	my $self = $_[0];
	$self->{boundary} = qq(frontier);
	$self->{content}  = qq(multipart/mixed; boundary="$self->{boundary}");
	map {
		push @{$self->{attachments}}, {
			type => $self->guessFileType($_), file => $_, };
	} @{$_[1]};
 }

 sub guessFileType
 {
	my ($self, $f) = @_;
	local %suffix = (
		'txt'  => 'text/plain',
		'html' => 'text/html',
		'gif'  => 'image/gif',
		'jpg'  => 'image/jpeg',
		'png'  => 'image/png',
		'xml'  => 'text/xml',
		'zip'  => 'application/zip',
	);

	if (lc $f =~ /([^\.]+)$/) {
		return $suffix{$1} if (exists $suffix{$1});
	}
	# fallback
	return 'application/octet-stream';
 }

 sub serialize
 {
	my $self = shift;
	return ($self->{boundary}) ? $self->serializeMultipart() : $self->serializeSimple();
 }

 sub serializeSimple
 {
	my $self = shift;
	my $s;
	### header
	foreach ( qw(useragent content from to cc subject) ) {
		next unless defined $self->{$_};
		$s .= $self->{serializer}->{$_}($self->{$_});
		$s .= qq(\n);
	}

	$s .= qq(\n);
	$s .= $self->{text};
	return $s;
 }

 sub serializeMultipart # Multipart-Message
 {
	my $self = shift;
	my $s;
	$s .= qq(MIME-Version: 1.0\n);
	### header
	foreach ( qw(useragent content from to cc subject) ) {
		next unless defined $self->{$_};
		$s .= $self->{serializer}->{$_}($self->{$_});
		$s .= qq(\n);
	}

	### body (text)
	$s .= qq(\n--$self->{boundary}\n);
	$s .= $self->{serializer}->{content}("text/html; charset=UTF8");
	$s .= qq(\n\n);
	$s .= $self->{text};
	$s .= qq(\n);

	### body (attachments)
	foreach ( @{$self->{attachments}} ) {		
		$_->{file} =~ /([^\/]+)$/;
		$s .= qq(\n--$self->{boundary}\n);
		$s .= $self->{serializer}->{content}( qq($_->{type}; name="$1") );
		$s .= qq(\n);
		$s .= $self->{serializer}->{codec}("base64");
		$s .= qq(\n);
		$s .= $self->{serializer}->{dpos}( qq(attachement; name="$1") );
		$s .= qq(\n\n);	
		$s .= $self->base64Convert(	$_->{file} );
		# main::echoinfo("serialize attachment $_->{file}");
	}
	$s .= qq(--$self->{boundary}--\n);
	return $s;
 }

 sub base64Convert
 {
	my ($self, $file) = @_;
	my ($buf, $ret);
	open FILE, "<$file" or exit_with_error("failed to open file: $file");
	while (read(FILE, $buf, 60 * 57)) {
		$ret .= encode_base64($buf);
	}
	close FILE;
	return $ret;
 }
}

package main;
*echoinfo  = sub { echo(GREEN, shift);  };
*echowarn  = sub { echo(YELLOW, shift); };
*echoerror = sub { echo(RED, shift);    };
*mail_to  = \&recipient; 
*mail_cc  = \&recipient; 
*mail_bcc = \&recipient; 

our $ttyW;
our $VERSION = '0.3.1';

BEGIN 
{ 
	# register the error strings for all libcrypto and libssl related functions
	# and initialize SSL library by registering algorithms
	#
	Net::SSLeay::load_error_strings();
	Net::SSLeay::SSLeay_add_ssl_algorithms();
	Net::SSLeay::randomize();
	Net::SSLeay::initialize();
}

my %gConfig = ( 
	count 	=> 1,
	timeout => 10,
	verbose => 0
);

my $last_char;

### handle to host
my $srv = undef;
*writesocket = sub { datasend($srv->{socket}, $_[0]); };

# ---------------------------------------------------------------------------------------
# If no arguments were given, then allow STDIN to be used only
# if it's not connected to a terminal (otherwise print usage)
#
pod2usage(1) if ((@ARGV == 0) && (-t STDIN));
GetOptions (\%gConfig, 
	"config|c=s"	,
	"count=i"		,
	"cc=s@"			,
	"host|h=s"		,
	"user=s"		,
	"pass|p=s"		,
	"port=i"		,
	"proxy=s"		,
	"hello=s"		,
	"to=s@"			,
	"from=s"		,
	"attachment=s@"	,
	"subject=s"	  	,
	"timeout=i"		,
	"out=s"			,
	"help|?"		,
	"man"			,
	"verbose"
);
pod2usage(1) if $gConfig{help};
pod2usage(-verbose => 2) if $gConfig{man};

if (exists $gConfig{config}) { loadconfig(); }

$srv = connect_server();
login($srv, $gConfig{user}, $gConfig{pass});

if ($srv->{stat} == smtp_logged)
{
	my @mailStack = ();
	for ( 1..$gConfig{count} ) {
		push @mailStack, createmail( $gConfig{from} || $srv->{logaccount}->{username} );
	}

	# now send the full stack via one tcp-ip connection
	sendmail($srv, \@mailStack);
}

quit($srv);

sub createmail
{
	my ($from, $to, $subject, $mailtext) = @_;

	### create record with default parameters
	#   remove leading and trailing double-quotes
	my $mail = mail->new(
		from 	  => subst(rmQuotes($from)),
		to	 	  => $to || $gConfig{to},
		cc		  => $gConfig{cc},
		subject   => subst(rmQuotes($subject || $gConfig{subject})),
		useragent => $gConfig{useragent}
	);
	
	### text of this mail
	$mail->setText($gConfig{body});

	### mail has some attachments?
	if (exists $gConfig{attachment}) {
		$mail->appendAttachment($gConfig{attachment});
	}

	if (exists $gConfig{output}) {
		my $f = IO::File->new($gConfig{output}, "w");
		print $f $mail->serialize;
		$f->close;
	}

	return $mail;
}

sub loadconfig
{
	echoinfo("Using config '$gConfig{config}' ...");
	open my $f, $gConfig{config} or exit_with_error("failed to open file: $gConfig{config}");
	while( my $line = <$f>) {  
		next if ($line =~ /^\s*#/);
		next if ($line !~ /^\s*\S+\s*=.*$/);
		my ($key, $value) = (split /=/, $line, 2);
		$key   =~ s/^\s+//g;
		$key   =~ s/\s+$//g;
		$value =~ s/^\s+//g;
		$value =~ s/\s+$//g;

		$value = rmQuotes($value);
	
		# *** experimental ***
		#	
		#if ($value =~ /\$([a-zA-Z0-9]+)/) {
		#	if (my $v = $gConfig{$1}) {
		#		$value =~ s/\$$1/$v/; 
		#	}
		#}

		if ($gConfig{$key} =~ /ARRAY/) { 
			if (grep { $_ eq $value } @{$gConfig{$key}}) {
				echowarn("removed duplicate recipient '$value'"); next;
			}
			push @{$gConfig{$key}}, $value;
		}

		$gConfig{$key} = $value unless $gConfig{$key};
	}
	close $f;
}

sub connect_server
{
	my $server  = {}; # server record
	exit_with_error("hostname not set") if (!exists $gConfig{host});

	($server->{host} = $gConfig{host}) =~ s/"//g;
	$server->{port}  = $gConfig{port};
	$server->{hello} = $gConfig{hello};
	$server->{stat}  = smtp_offline;

	echoinfo("Connecting ".$server->{host}.":".$server->{port}." ...");

	# optional use SOCKS 4/5 proxy
	if (exists $gConfig{proxy} ) {
		eval {
			use lib 'lib';
			require IO::Socket::Socks;
		}; exit_with_error("IO::Socket::Socks library not found!") if $@;

		local ($proxyaddr, $proxyport, $proxyver) = split /:/, $gConfig{proxy};
		my $nmAt = $gConfig{maxattempts} || 1;

		for ( 1..$nmAt ) {
			echoinfo("Tunneling SOCKS proxy $proxyaddr:$proxyport...");
			$server->{socket} = new IO::Socket::Socks(
			 ProxyAddr 	  => $proxyaddr,
			 ProxyPort	  => $proxyport,
			 ConnectAddr  => $server->{host},
			 ConnectPort  => $server->{port},
			 SocksVersion => $proxyver || 4, # because default is 5
			 SocksDebug	  => 0,
			 Timeout	  => $gConfig{timeout} || 10) or echowarn("Proxy connection failed '$proxyaddr:$proxyport': ".$SOCKS_ERROR);
			last if $server->{socket};
		}
	}
	else {
		$server->{socket} = new IO::Socket::INET(
			PeerAddr => $server->{host}, 
			PeerPort => $server->{port}, 
			Proto    => 'tcp', 
			Timeout  => $gConfig{timeout} || 5) or exit_with_error("Connect failed :$@");
	}

	exit_with_error("Failed to create socket") unless $server->{socket};

	my ($rsp, $txt) = sread($server->{socket});
	exit_with_error("Could not connect to SMTP server: ".$server->{host}." $txt") if ($rsp != smtp_reply_domainok);
	echoinfo($txt);

	extended_hello($server);
	starttls($server);
	$server->{stat} = smtp_online;
	return $server;
}

sub sendmail
{
	my ($server, $mails) = @_;
	my $s = $server->{socket};

	foreach my $mail ( @{$mails} ) {
		#echoinfo("sendmail -> $mail->{cc}");

		mail_from($s, $gConfig{from});
		map { 
			echoinfo("sendmail -> $_"); 
			mail_to($s, $_); 
		} @{$mail->{to}};

		#mail_cc($s, $mail->{cc}) if (defined $mail->{cc});

		### write everything serialized
		datastart($s);
		map { writesocket("$_\n"); } split /\n/, $mail->serialize;
		dataend($s);

		sleep $gConfig{delay} 
			if ($gConfig{delay} != 0 && $gConfig{count} > 1);
	}
}

sub preprocess_body_content
{
	my $body = shift;
	if ($body =~ /file:/) {
		my ($cmd, $file) = split /:/, $body;
		exit_with_error("file not found: $file") unless (-e $file);
		open FILE, "<$file" or exit_with_error("failed to open file: $file");
		my @LINES = <FILE>;
		close FILE;

		$body .= encode_qp(join ('', @LINES)); # read UTF8 should be default
	}	
	elsif ($body =~ /rand:([0-9]+)/) {
		$body .= __get_random_data($1 || 1);
	}
	return $body
}

sub subst
{
	my $from = shift;
	my $fromsub = $from;

	my $i = 0;
	my @S;
	while ($from =~ s/{([^}]+)//) {
		if (-e $1) {
			my $file = $1;
			my $fh = new IO::File $file, "r";
			if (defined $fh) {
				@S = <$fh>;
		        undef $fh; # automatically closes the file

				my $n = @S;
				my $i = int(rand($n));
				my $r = $S[$i]; $r =~ s/\n//g;

				$fromsub =~ s/{$file}/$r/;
			}
		}
		
		last if (++$i > 10); # ?req.
	}
	return $fromsub;
}

sub mail_from 
{
	my ($socket, $from, $rpath) = @_;
	exit_with_error("SOCKET failed.") unless (defined $socket);

	if (defined $rpath) {
		echoinfo("setting return-path: $path") if ($gConfig{verbose});
		$from = "<".$rpath.">";
	}
	swrite($socket, "MAIL FROM: "._addr($from));

	my ($rcd, $txt) = sread($socket);
	if ($rcd != smtp_reply_ok)
	{
		exit_with_error("Could't set FROM: $rcd $txt");
	}
}

sub recipient
{
	my ($socket, $to) = @_;
	swrite($socket, "RCPT TO: "._addr($to));
	my ($rcd, $txt) = sread($socket);
	if ($rcd != smtp_reply_ok) {
		exit_with_error("Couldn't send TO <$to>: $rcd $txt");
	}
}

sub datastart
{
	my $socket = shift;
	swrite($socket, "DATA");
	my ($rcd, $txt) = sread($socket);
	exit_with_error("Data failed: $rcd $txt") 
		if ($rcd != smtp_reply_startmail);
	echoinfo($txt) if !$gConfig{verbose};
}

sub dataend
{	
	my $socket = shift;
	swrite($socket, smtp_crlf.".");
	my ($rcd, $txt) = sread($socket);
	if ($rcd != smtp_reply_ok) {
		exit_with_error("Couldn't send mail: $rcd $txt");
	}
}

sub datasend
{
	my $socket = shift;
	my $arr = @_ == 1 && ref ($_[0]) ? $_[0] : \@_;
	my $line = join "", @$arr;

	return 0 unless defined(fileno($socket));

	my $last_ch = $last_char;
	$last_ch = $last_char = lf unless defined $last_ch;

	return 1 unless length $line;
	if ("\r" ne cr) {
		$line =~ s/\r\n/\015\012/;
	}

	my $first_ch = '';

	if ($last_ch eq cr) {
		$first_ch = lf if $line =~ s/^\012//;
	}
	elsif ($last_ch eq lf) {
		$first_ch = "." if $line =~ /^\./;
	}
	$line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
	$line = qq($first_ch$line);
	$last_char = substr($line, -1, 1);

	my $length  = length($line);
	my $timeout = $socket->timeout || undef;

	while ($length) {
		if ($socket) {
			my $bwrt = syswrite($socket, $line, $length, 0);
			unless (defined $bwrt) {
				echoerror("Error: $!");
				return undef;
			}
			$length -= $bwrt;
		}
		else {
			echoerror("Error: Timeout");
			return undef;
		}
	}
}

sub quit 
{
	my $server = shift;
	swrite($server->{socket}, "QUIT");
	my ($rcd, $txt) = sread($server->{socket});
	if ($rcd != 221) {
		exit_with_error("An error occurred disconnecting from the mail server: $rcd $txt");
	}
	$server->{stat} = smtp_offline;
}

sub _addr 
{
	my $addr = shift;
	$addr = "" unless defined $addr;
	return $1 if $addr =~ /(<[^>]*>)/;
	$addr =~ s/^\s+|\s+$//sg;
	"<$addr>";
}

sub extended_hello
{
	my $server = shift;
	swrite($server->{socket}, "EHLO ".$server->{hello});

	my ($rcd, $txt, $more) = sread($server->{socket});
	if ($rcd != smtp_reply_ok) {
		exit_with_error("EHLO command failed: $rcd $txt");
	}

	my %features = ();
	while ($more eq '-') {
		($rcd, $txt, $more) = sread($server->{socket});
		$txt =~ s/[\n|\r]//g;
		$txt =~ /(\S+)\s(.*)$/;

		my ($feat, $parm) = ($txt =~ /^(\w+)[= ]*(.*)$/);
		$features{$feat} = $parm;
	}

	$server->{features} = \%features;
	return 1;
}

sub starttls
{
	my $server = shift;
	swrite($server->{socket}, "STARTTLS");

	my ($rcd, $txt) = sread($server->{socket});
	exit_with_error("Invalid response for STARTTLS: $rcd $txt") if ($rcd != smtp_reply_domainok);

	# NOTE: this might be deprecated
	#		use IO::Socket::SSL->start_SSL() instead
	if (not IO::Socket::SSL::socket_to_SSL($server->{socket}, SSL_version => "SSLv3 TLSv1"))
	{
		exit_with_error("Couldn't start TLS: ".IO::Socket::SSL::errstr);
	}
	extended_hello($server);
}

sub swrite 
{
	$_[0]->printf( $_[1].smtp_crlf );
	echoinfo("C: $_[1]") if $gConfig{verbose};
}

sub sread 
{
	$_[0]->getline() =~ /(\d+)(.)([^\r]*)/;
	echoinfo("S: $1 $3") if $gConfig{verbose};
	return ($1, $3, $2);
}

sub login
{
	my ($server, $username, $password) = @_;

	# get features from server
	#
	my $type = $server->{features}->{AUTH};
	exit_with_error("Server did not return AUTH in capabilities") if (!$type);

	# TODO: implement CRAM-MD5 PLAIN
	if ($type =~ /LOGIN/) 
	{ 
		auth_LOGIN($server, $username, $password); 
	}
	else {
		exit_with_error("Unsupported Authentication mechanism");
	}
}

sub auth_LOGIN
{
	my ($server, $username, $password) = @_;

	$username =~ s/"//g;
	$server->{logaccount} = { type => 'AUTH', username => $username, };

	echoinfo("AUTH LOGIN user ".$username);

	local *authwr = sub
	{
		my ($w, $prfx, $errCode) = @_;
		swrite($server->{socket}, $w);
		my ($rcd, $txt) = sread($server->{socket});
		exit_with_error("$prfx: $rcd $txt") 
			if ($rcd != $errCode);
	};

	authwr("AUTH LOGIN", "Cannot authenticate via LOGIN", 334);
	authwr(encode_base64($username, ""), "Auth failed (wrong user)", 334);
	authwr(encode_base64($password, ""), "Auth failed (wrong pass)", 235);
	$server->{stat} = smtp_logged;
}

sub rmQuotes
{
	my $s = shift;
	$s =~ s/^["|']//; $s =~ s/["|']$//g;
	return $s;
}

sub exit_with_error
{
	echoerror(shift);
	exit 1;
}

sub echo
{
	print BOLD, $_[0], " * ", RESET, $_[1], "\n"; 
}

sub __get_random_data
{
	my $kbytes = shift;
	my $range = 100;
	my $buffer;

	for (my $i = 0; $i < $kbytes * 1024; ++$i) {
		my $random_number = int(rand($range));
		$buffer .= $random_number;
	}
	return encode_base64($buffer);
}
__END__
=head1 NAME

mailertls -- simple command line tool to test SMTP servers

=head1 SYNOPSIS

    mailertls [options]

=head1 DESCRIPTION

This program sends E-Mail messages over SSL/TLS.

=head2 OPTIONS

=over 8

=item B<-config>

Uses the specified configuration-file

=item B<-host>

Set the host name or address of the SMTP server

=item B<-port>

Set the port where the SMTP server is listening (default is I<587> for SSL/TLS)

=item B<-hello>

Set the hostname used in the EHLO command (default is I<localhost>)

=item B<-timeout>

Close the connection after the specified time in seconds (default is I<10>)

=item B<-user>

Username for SMTP AUTH I<required in plain-text>

=item B<-pass>

Password for SMTP AUTH I<required in plain-text>

=item B<-from>

Address to use in MAIL FROM command

=item B<-to>

Address to use in RCPT TO command

=item B<-subject>

Subject of the message

=item B<-body>

Plaintext of the message

=item B<-attachment>

Sends the specified file as attachment

=item B<-verbose>

Explain what is being done. Output the client-server communication

=item B<-help>

Print a brief help message and exits

=item B<-man>

Prints the manual page and exits


=back

=head1 EXAMPLES

The easiest way to send a single mail is to use a configuration file. Except password and recipient, 
all parameters are used from this file.

C<mailertls --config mailertls.conf --pass secret --to "username@example.com">

The configuration can look like this:

  #file: mailertls.conf
  from="username@domain1.com"
  text="<h1>Hello</h1>Message from mailtools"
  count=1

=head2 Text-substitution

This feature is useful if you want to send a huge amount of mails to one postbox. The substitutions are 
specified with curly braces around the filename(s). Each possible value is represented by one line.

  #file: mailertls.conf
  from="{fornames.txt}.{surnames.txt}@example.com"

=head2 Using a proxy

The following command sends a mail by using the given configuration file through a SOCKS4 proxy to hide
the original source IP:

C<mailertls --config mailertlsconf --to "username@example.com" --proxy "1.2.3.4:1080:4">

=head2 Other examples

Sending with B<attachment>:

C<mailertls --config mailertlsconf --to "username@example.com" --attachment ~/filename>

Multiple recipients

C<mailertls --config mailertlsconf --to "username@example.com" --to "user@example2.com">

=head1 LICENSE

This is released under the GNUv3 License.

=head1 AUTHOR

Marco Opper, L<marco.opper@gmx.de>

=cut

