#!/usr/local/bin/perl
#**************************************************************************
#
# ActinicSMTPAuth.pm	- module for doing the SMTP authentication
#
# Written by Tamas Viola
#
# Copyright (c) Actinic Software Ltd 2003
#
#**************************************************************************

package ActinicSMTPAuth;

use strict;
use MIME::Base64;

push (@INC, "cgi-bin");

my $bFound = 0;
my $sDir;
foreach $sDir (@INC)
	{
	if ($sDir eq ".")
		{
		$bFound = 1;
		last;
		}
	}
if (!$bFound)
	{
	push (@INC, ".");
	}

#
# define some ACTINIC package constants
#

$ActinicSMTPAuth::prog_name = 'ActinicSMTPAuth.pm';		# Program Name
$ActinicSMTPAuth::prog_name = $ACTINIC::prog_name;		# remove compiler warning
$ActinicSMTPAuth::prog_ver = '$Revision: 18819 $ ';			# program version
$ActinicSMTPAuth::prog_ver = substr($ACTINIC::prog_ver, 11); # strip the revision information
$ActinicSMTPAuth::prog_ver =~ s/ \$//;						# and the trailers

#
# The lsProtocol list contains the supported authentication protocols in the order of security level
# as the first one is the highest, always the higest possible will be selected
# The lpHandler list has the references to the handler routines for the supported protocols.
# the order must be the same as the lProtocol list
#

@ActinicSMTPAuth::lsProtocol	= ("DIGEST-MD5", "CRAM-MD5", "LOGIN", "PLAIN");
@ActinicSMTPAuth::lpHandler	= (\&SMTPAuth_DIGEST_MD5, \&SMTPAuth_CRAM_MD5, \&SMTPAuth_LOGIN, \&SMTPAuth_PLAIN);
$ActinicSMTPAuth::sHostname = "<Actinic:Variable Name="SmtpServer"/>";
$ActinicSMTPAuth::sServername = '';						# will be set by ACTINIC::SMTPAuthentication

#######################################################
#
# GetSMTPUsername	-	decrypt the smtp username
#
# Returns:	0	The SMTP Username
#
#######################################################

sub GetSMTPUsername
	{
	my $sUsername = $::sSMTPUsername;

	$sUsername = decode_base64($sUsername);
	$sUsername ^= "\xa5" x (length $sUsername);
	return ($sUsername);
	}

#######################################################
#
# GetSMTPPassword	-	decrypt the smtp password
#
# Returns:	0	The SMTP Password
#
#######################################################

sub GetSMTPPassword
	{
	my $sPassword = $::sSMTPPassword;

	$sPassword = decode_base64($sPassword);
	$sPassword ^= "\xa5" x (length $sPassword);
	return ($sPassword);
	}


#######################################################
#
# SMTPAuth_LOGIN	-	It does the SMTP authentication
#								for LOGIN protocol
#								See RFC 2554 for details
#
# Params:	0	-	process step number
#				1	-	Response from the server
#
# Returns:	0	$::SUCCESS	-	if the response is
#					$::FAILURE	-	if any error occured or
#										nothing was recognisable
#				1	-	string to be send to the server or error string
#				2	-	$::TRUE if further process is needed
#
#######################################################


sub SMTPAuth_LOGIN
	{
	my ($sBuffer);
	my ( $nStep, $sAnswer) = @_;

	if ($nStep == 0)
		{
		return ($::SUCCESS, '', $::TRUE);			# Auth command trail string is empty
		}
	if ($nStep == 1)										# first answer, must be base64('username')
		{
		$sAnswer = decode_base64($sAnswer);
		if ($sAnswer !~ /username/i)					# or the basg4 encoded answer doesn't contain 'username'
			{
			return($::FAILURE, $sAnswer, $::FALSE);	# return the error for displaying
			}
		$sBuffer = encode_base64(GetSMTPUsername(), '') . "\r\n";
		return ($::SUCCESS, $sBuffer, $::TRUE);
		}
	if ($nStep == 2)										# requesting the password must be base64('password')
		{
		$sAnswer = decode_base64($sAnswer);
		if ($sAnswer !~ /password/i)					# or the basg4 encoded answer doesn't contain 'username'
			{
			return($::FAILURE, $sAnswer, $::FALSE);	# return the error for displaying
			}
		$sBuffer = encode_base64(GetSMTPPassword(), '') . "\r\n";
		return ($::SUCCESS, $sBuffer, $::FALSE);
		}
	return ($::FAILURE, "Unexpected SMTPAuthentication step number!", $::FALSE);
	}

#######################################################
#
# SMTPAuth_LOGIN	-	It does the SMTP authentication
#								for PLAIN protocol
#								See RFC 2554 for details
#
# Params:	0	-	process step number
#				1	-	Response from the server
#
# Returns:	0	$::SUCCESS	-	if the response is
#					$::FAILURE	-	if any error occured or
#										nothing was recognisable
#				1	-	string to be send to the server or error string
#				2	-	$::TRUE if further process is needed
#
#######################################################

sub SMTPAuth_PLAIN
	{
	my ($sBuffer);
	my ( $nStep, $sAnswer) = @_;

	if ($nStep == 0)
		{
		return ($::SUCCESS, '', $::TRUE);			# Auth command trail string is empty
		}
	if ($nStep == 1)
		{
		$sBuffer = '\0' . GetSMTPUsername() . '\0' . GetSMTPPassword() ;	# creating the string with username, password
		$sBuffer = encode_base64($sBuffer, '') . "\r\n";	# base64 encode it
		return ($::SUCCESS, $sBuffer, $::FALSE);
		}
	return ($::FAILURE, "Unexpected SMTPAuthentication step number!", $::FALSE);
	}

#######################################################
#
# SMTPAuth_CRAM-MD5	-	It does the SMTP authentication
#								for CRAM-MD5 protocol
#								See RFC 2554 for details
#
# Params:	0	-	process step number
#				1	-	Response from the server
#
# Returns:	0	$::SUCCESS	-	if the response is
#					$::FAILURE	-	if any error occured or
#										nothing was recognisable
#				1	-	string to be send to the server or error string
#				2	-	$::TRUE if further process is needed
#
#######################################################

sub SMTPAuth_CRAM_MD5
	{
	my ($sBuffer);
	my ( $nStep, $sAnswer) = @_;

	#
	# try to load SimHMAC.pm
	#
	eval
		{
		require Digest::HMAC_MD5;
		import Digest::HMAC_MD5 qw(hmac_md5_hex);
		};
	if ($@)
		{
		require <Actinic:Variable Name="DigestPerlMD5"/>;
		import Digest::Perl::MD5 qw(hmac_md5_hex);				# Use Perl version if not found
	}

	if ($nStep == 0)
		{
		return ($::SUCCESS, '', $::TRUE);			# Auth command trail string is empty
		}
	if ($nStep == 1)
		{
		$sAnswer = decode_base64($sAnswer);			# decode the server ticket
		#
		# creating the string with username, and hmac_MD5 hash of server ticket encoded with the password
		#
		$sBuffer = GetSMTPUsername() . ' '. hmac_md5_hex($sAnswer, GetSMTPPassword());
		$sBuffer = encode_base64($sBuffer, '') . "\r\n";	# base64 encode it
		return ($::SUCCESS, $sBuffer, $::FALSE);
		}
	return ($::FAILURE, "Unexpected SMTPAuthentication step number!", $::FALSE);
	}

#######################################################
#
# SMTPAuth_DIGEST-MD5	-	It does the SMTP authentication
#								for CRAM-MD5 protocol
#								See RFC 2554 for details
#
# Params:	0	-	process step number
#				1	-	Response from the server
#
# Returns:	0	$::SUCCESS	-	if the response is
#					$::FAILURE	-	if any error occured or
#										nothing was recognisable
#				1	-	string to be send to the server or error string
#				2	-	$::TRUE if further process is needed
#
#######################################################

sub SMTPAuth_DIGEST_MD5
	{
	my ($sBuffer);
	my ( $nStep, $sAnswer) = @_;

#
# Actinic fallback mechanism to load md5_hex
#
eval
	{
	require Digest::MD5;									# Try loading MD5
	import Digest::MD5 qw(md5 md5_hex);
	};
if ($@)
	{
	require <Actinic:Variable Name="DigestPerlMD5"/>;
	import Digest::Perl::MD5 qw(md5 md5_hex );				# Use Perl version if not found
	}

	if ($nStep == 0)
		{
		return ($::SUCCESS, '', $::TRUE);			# Auth command trail string is empty
		}
	if ($nStep == 1)
		{
		$sAnswer = decode_base64($sAnswer);			# decode the server ticket
	 	my %sparams;

	 	# Parse response parameters
	 	while($sAnswer =~ s/^(?:\s*,)?\s*(\w+)=("([^\\"]+|\\.)*"|[^,]+)\s*//)  # "
	 		{
			my ($k, $v) = ($1,$2);
			if ($v =~ /^"(.*)"$/s)
				{
				($v = $1) =~ s/\\//g;
		 		}
			$sparams{$k} = $v;
	 		}
	 	if (length $sAnswer)								# if anything left in the answer, then it was not valid
	 		{
			return ($::FAILURE, "Invalid SMTPAuthentication challenge!", $::FALSE);
	 		}
	 	my $sServ_name = $ActinicSMTPAuth::sServername;
	 	my $sUri = 'smtp/' . $ActinicSMTPAuth::sHostname;
	 	if (defined $sServ_name
	 		&& (length $sServ_name > 0))
	 		{
			$sUri .=  '/' . $sServ_name;
			}
		my $sUserName = GetSMTPUsername();
		my $sPassword = GetSMTPPassword();
		my $sRealm  = ($sUserName =~ s/\@(.+)$//o) ? $1 : $sServ_name;
		my $sNonce  = $sparams{nonce};
		my $sCnonce = substr(md5_hex(join (":", $$, time, rand)),0,14);
		my $sQop = 'auth';
		my $nNc  = '00000001';
		my($nHv, $sA1, $sA2);
		$nHv = md5("$sUserName:$sRealm:$sPassword");
		$sA1 = md5_hex("$nHv:$sNonce:$sCnonce");
		$sA2 = md5_hex("AUTHENTICATE:$sUri");
		$nHv = md5_hex("$sA1:$sNonce:$nNc:$sCnonce:$sQop:$sA2");
		$sBuffer = qq(username="$sUserName",realm="$sRealm",nonce="$sNonce",nc=$nNc,cnonce="$sCnonce",digest-uri="$sUri",response=$nHv,qop=$sQop);
		$sBuffer = encode_base64($sBuffer, '') . "\r\n";	# base64 encode it
		return ($::SUCCESS, $sBuffer, $::FALSE);
		}
	if ($nStep == 2)										# rspauth = "xxxxxxxxxxxxxxxxxxxxxx" is received (for subsequent authentication, which we don't want to use
		{
		$sAnswer = decode_base64($sAnswer);			# decode the server ticket
		if ($sAnswer =~ /rspauth/)						# yes, we have an rspauth response
			{
			return ($::SUCCESS, "\n", $::FALSE);	# send an empty line
			}
		else
			{
			return ($::SUCCESS, 'Unexpected response from the SMTP server during DIGEST-MD5 authentication!', $::FALSE);
			}
		}

	return ($::FAILURE, "Unexpected SMTPAuthentication step number!", $::FALSE);
	}

#
# list of quoted parameters
#
my %qdval; @qdval{qw(username realm nonce cnonce digest-uri qop)} = ();

#########################################################
#
# utilit function for quoting necessary parameters
#
# input 	0	-	parameter name
#			1	-	parameter
#
# returns the (non)quoted string depending
#					on the name of the parameter
#
#########################################################

	sub _qdval
		{
		my ($k, $v) = @_;

		if (!defined $v)
			{
			return;
			}
		elsif (exists $qdval{$k})
			{
			$v =~ s/([\\"])/\\$1/g;						# " avoid syntax print problems
			return qq{$k="$v"};
			}

		return "$k=$v";
		}

1;