#
# Sieve.pm
#
# Module that implements parts of the Sieve-Protocol. 
# Uses Authen::SASL to utilize secure SASL authentication.
#
# Details on the protocol can be found at
# http://www.oceana.com/ftp/drafts/draft-martin-managesieve-04.txt
#
#
# Author: Thomas Wana <thomas@wana.at>
# 
package Net::Sieve;

use IO::Socket;
use Authen::SASL;
use MIME::Base64;

use strict;
use warnings;

sub new
{
        my $class=shift;
        my $self={};
        bless($self, $class);
        return $self;
}

sub connect($$$)
{
	my $self=shift;
	my $hostname=shift;
	my $port=shift;

	# connect to server
	my $sock = new IO::Socket::INET (
			   PeerAddr => $hostname,
			   PeerPort => $port,
			   Proto => 'tcp',
			   Timeout => 30
	) or die("can't create socket: $!");
	$self->{hostname}=$hostname;
	$self->{remoteport}=$port;
	while(<$sock>)
	{
		my $line=$_;
		last if($line=~/^OK/i);

		if($line!~m/^"/)
		{
			# Some other, non-OK response code
			close $sock;
			die("Error in sieve protocol headers: $line");
		}
		if($line=~m/^"SASL"\s+"(.*)"/)
		{
			# list of supported SASL mechanisms
			my @sasls=split(/ /,$1);
			$self->{sasl}=\@sasls;
		}
	}
	if(!defined($self->{sasl}))
	{
		close $sock;
		die("Server didn't advertise any SASL mechanisms");
	}

	# ready to go!
	$self->{sock}=$sock;
	return 1;
}

sub login
{
	my $self=shift;
	my $username=shift;
	my $pass=shift;

	my $sock=$self->{sock};

	$self->{username}=$username;
	$self->{password}=$pass;

	# start with the first mechanism ("connect" guarantees to return at least with one)
	my $mech=$self->{sasl}->[0];
	my $sasl = Authen::SASL->new(
		 mechanism => $mech,
		 callback => { authname => $username, user => $username, pass => $pass },
	);
	my $saslconn = $sasl->client_new("sieve", $self->{hostname}, $sock->sockport(), $sock->peerport())
		or die("Can't create SASL client");

	print $sock "AUTHENTICATE \"$mech\"\r\n";
	while(<$sock>)
	{
		my $line=$_;
		if($line=~/^NO/i or $line=~/^BYE/i)
		{
			die("Error in server reply during authentication: $line");
			last;
		}
		last if($line=~/^\r?\n?$/);
	}

	my $saslstring=$saslconn->client_start();
	print $sock '"'.encode_base64($saslstring, "")."\"\r\n";
	#print encode_base64($saslstring);

	my $authenticated=0;
	do
	{
		while(<$sock>)
		{
			my $line=$_;
			if($line=~/^NO/i or $line=~/^BYE/i)
			{
				die("Authentication failed: $line");
			}
			elsif($line=~/^OK/i)
			{
				# authenticated!
				$authenticated=1;
				last;
			}
			elsif($line=~/^"(.*)"/)
			{
				$saslstring=$saslconn->client_step(decode_base64($1));
				print $sock '"'.encode_base64($saslstring, "")."\"\r\n";
			}
			else
			{
				die("Error in server reply during authentication: $line");
			}
		}
	} while(!$authenticated);

	# List scripts on the server, to force a redirect if necessary. (the server only
	# sends a redirect after the first "reading" command, not after authentication)		
	$self->listscripts();

	# done!
	return 1;
}

# Returns an array of active scripts on the server. Each array element
# consists of a reference to an array with two entries, the first one
# being the script name, and the second one being the active-status
# (1 if its active, 0 otherwise)
sub listscripts
{
	my $self=shift;
	my $redirected=shift;
	my $sock=$self->{sock};
	
	print $sock "LISTSCRIPTS\r\n";
	my @scripts=();
	my $i=0;
	while(<$sock>)
	{
		my $line=$_;
		last if($line=~/^OK/i);

		if($line=~/^NO/i)
		{
			die("Error in sieve protocol: $line");
		}
		elsif($line=~/^BYE/i)
		{
			# special case: login calls listscripts, because only then the server
			# redirects us to the right timsieved. Thus, if this happens, redirect.
			if($line=~/^BYE\s+\(REFERRAL\s+"sieve:\/\/(.*?)"\)/i)
			{
				# redirect to another server... kill the socket, transparently connect
				# there
				my $newhost=$1;
				if($redirected)
				{
					die("redirection limit exceeded");
				}
				$self->logout();
				$self->connect($newhost, $self->{remoteport});
				$self->login($self->{username}, $self->{password});
				return $self->listscripts(1);
			}
			else
			{
				die("Error in server reply during authentication: $line");
				last;
			}
		}
		if($line=~m/"(.*?)"\s*(.*)\r\n$/)
		{
			$scripts[$i]->[0]=$1;
			$scripts[$i]->[1]=0;
			if($2 eq "ACTIVE")
			{
				$scripts[$i]->[1]=1;
			}
			$i++;
		}
	}
	return \@scripts;
}

# Gets a script name and its size in octets. Returns true if there
# is enough space to store the script and false otherwise. Should
# be called prior to putscript.
sub havespace($$$)
{
	my $self=shift;
	my $scriptname=shift;
	my $scriptsize=shift;
	my $sock=$self->{sock};
	my $rval=0;
	
	print $sock "HAVESPACE \"$scriptname\" $scriptsize\r\n";
	while(<$sock>)
	{
		my $line=$_;

		if($line=~/^NO/i)
		{
			# not enough space
			$rval=0;
			last;
		}
		elsif($line=~/^OK/i)
		{
			# there is enough space
			$rval=1;
			last;
		}
		else
		{
			die("Error in sieve protocol: $line");
		}
	}
	return $rval;
}

# Gets the script with the supplied script name. Returns the script as 
# scalar or undef if the script couldn't be found.
sub getscript($$)
{
	my $self=shift;
	my $scriptname=shift;
	my $sock=$self->{sock};
	my $rval=0;
	my $script="";
	
	print $sock "GETSCRIPT \"$scriptname\"\r\n";
	my $line=<$sock>;
	if($line=~/^NO/i)
	{
		# script couldn't be found
		$script=undef;
	}
	elsif($line!~/^\{([0-9]*)\}/)
	{
		die("Error in sieve protocol: $line");
	}
	else
	{
		my $count=$1;
		while(<$sock>)
		{
			my $line=$_;
			$line=~s/\r\n$//;
			if($line=~/^OK/i)
			{
				# done
				last;
			}
			$script.=$line."\n";
		}
	}
	return $script;
}

# Uploads a script to the server. Takes the name of the script and its body as string,
# the body's lines being separated by '\n'. Returns true or false indicating success
# or failure.
sub putscript($$$)
{
	my $self=shift;
	my $scriptname=shift;
	my $scriptorig=shift;
	my $sock=$self->{sock};
	my $rval=0;

	my @script=split(/\n/, $scriptorig);
	my $scriptlen=length(join("\r\n", @script));
	
	print $sock "PUTSCRIPT \"$scriptname\" {$scriptlen+}\r\n";
	foreach my $line (@script)
	{
		print $sock "$line\r\n";
	}
	my $errmsg="";
	while(<$sock>)
	{
		my $line=$_;
		$line=~s/\r\n$//;
		if($line=~/^OK/i)
		{
			# done
			$rval=1;
			last;
		}
		elsif($line=~/^NO/i)
		{
			if($line=~/^NO\s+\{([0-9]*)\+?\}/i)
			{
				my $c=$1;
				do
				{
					$line=<$sock>;
					$line=~s/\r\n$//;
					$errmsg.=$line."\n";
					$c-=length($line)+2;
				} while($c>0);
			}
			elsif($line=~/^NO\s+"(.*)"/i)
			{
				$errmsg=$1;
				last;
			}
			$rval=0;
			last;
		}
	}
	if($errmsg ne "")
	{
		die($errmsg);
	}
	return $rval;
}

# deletes a script. Gets the name of the script to be deleted as string.
# Returns true if successful, false otherwise. Failure could occur because
# the script doesn't exist or because it is still active.
sub deletescript($$)
{
	my $self=shift;
	my $scriptname=shift;
	my $sock=$self->{sock};
	my $rval=0;
	
	print $sock "DELETESCRIPT \"$scriptname\"\r\n";
	while(<$sock>)
	{
		my $line=$_;

		if($line=~/^NO/i)
		{
			# not found or still active
			$rval=0;
			last;
		}
		elsif($line=~/^OK/i)
		{
			# script deleted!
			$rval=1;
			last;
		}
		else
		{
			die("Error in sieve protocol: $line");
		}
	}
	return $rval;
}

# Activates a script. If the supplied script name is "", deactivates
# all scripts on the server. Returns true or false
sub setactive($$)
{	
	my $self=shift;
	my $scriptname=shift;
	my $sock=$self->{sock};
	my $rval=0;
	
	print $sock "SETACTIVE \"$scriptname\"\r\n";
	while(<$sock>)
	{
		my $line=$_;

		if($line=~/^NO/i)
		{
			$rval=0;
			last;
		}
		elsif($line=~/^OK/i)
		{
			$rval=1;
			last;
		}
		else
		{
			die("Error in sieve protocol: $line");
		}
	}
	return $rval;
}

sub logout($)
{
	my $self=shift;

	my $sock=$self->{sock};
	
	print $sock "LOGOUT\r\n";
	while(<$sock>)
	{
		# we just wait for any response and don't care what exactly it is
		my $line=$_;
		last if($line!~/^\r?\n?$/);
	}

	# tear down the socket
	close($sock);
}

return 1;