view release on metacpan or  search on metacpan

lib/Arc/Connection/Server.pm  view on Meta::CPAN

	if ((!defined $sasl) or ($sasl->code != 0)) {
		return $this->_SetError("SASL: ",$sasl->error());
	}

	$this->_Debug("Available mechanisms. ",$sasl->listmech("","|",""));

	return $this->_StepAuthentication(1);
}

## Another SASL step
## Response of a SASL command from the client
## Protocol command: SASL <base64 encoded SASL outout>\r\n
##in> bool $first_step
##out> true when succesful, otherwise false
##eg> $this->_StepAuthentication(1);
sub _StepAuthentication
{
	my $this = shift;
	my $first = shift;
	my $sasl = $this->{_sasl};
	my $ret = 0;
	my $str;

	if ($first) {
		if ($this->{_cmdparameter} =~ /^\s+$/) {
			$this->_Debug("No cmdparameter, plain server start.");
			$str = $sasl->server_start();
		} else {
			$this->_Debug("SASL parameter is present.");
			$str = $sasl->server_start(decode_base64($this->{_cmdparameter}));
		}
	} else {
		$str = $sasl->server_step(decode_base64($this->{_cmdparameter}));
	}

	$str = "" unless defined $str;

	if ($sasl->need_step || $sasl->code == 0) {
		if ($sasl->code == 0) {
			$this->_Sasl($str) if $str ne "";

			$this->{_authenticated} = 1;
			@{$this->{_expectedcmds}} = qw(QUIT CMD);
			$this->{_username} = $sasl->property("user");
			$this->{_realm} = $sasl->property("realm");

			$this->Log(LOG_AUTH,"SASL: Negotiation complete. User '".$this->{_username}.
				"' is authenticated using ".$this->{_saslmech}.". (".$this->{_connection}->peerhost.")");
			$ret = 1;
		} else {
			$ret = $this->_Sasl($str);
		}
	} else {
		$ret = $this->_Error("SASL: Negotiation failed. User is not authenticated. (",$sasl->code,") ",
			$sasl->error);
	}
	return $ret;
}
## parses the AUTHENTICATE[ <SASL mech>]\r\n, sent by the client.
## Checks if the demanded SASL mechanism is allowed and returns the
## selected mechanism.
sub _RAUTHENTICATE
{
	my $this = shift;

	if ( $this->{_cmdparameter} ne "") {
		if (grep ({ $_ eq $this->{_cmdparameter}} @{$this->{sasl_mechanisms}} )) {
			$this->{_saslmech} = $this->{_cmdparameter};
		} else {
			return $this->_Error("SASL mechanism not allowed by server.");
		}
	} else {
		$this->_Debug("Default Sasl: ",@{$this->{sasl_mechanisms}}[0]);

		$this->{_saslmech} = @{$this->{sasl_mechanisms}}[0];
	}

	return $this->_Authtype();
}

## parses the SASL <base64 encoded SASL string>\r\n, sent by the client.
## Sasl challenge/response from the client
sub _RSASL
{
	my $this = shift;
	my $ret;

	if (!defined $this->{_sasl}) {
		$ret = $this->_StartAuthentication() || die "Sasl StartAuthentication failed.";
	} else {
		$ret = $this->_StepAuthentication() || die "Sasl StepAuthentication failed.";
	}
	return $ret;
}

## See source code for this method. /dev/null for unwanted output.
sub tonne {

}

## parses the CMD <cmd>\r\n, sent by the client.
## check if the command exists, prepares the command connection, executes the command and
## does cleanups after execution.
sub _RCMD
{
	my $this = shift;

	my ($cmd,$para) = split(/\s+/,$this->{_cmdparameter},2);
	$this->_Error("Command not found.") unless defined $cmd;

	my $perlcmd = $this->{commands}->{$cmd};
my $reason = $this->_CheckCmd($cmd, $perlcmd);

	if (defined $reason) {
		$this->Log(LOG_USER, "Command '$cmd' requested by user '".$this->{_username}.
		"' not ok", $reason ? ": $reason" : "");
		$this->_Error("Command $cmd not ok", $reason ? ": $reason" : "");
	} elsif( !$this->{_error} && defined $perlcmd ) {
		$this->Log(LOG_USER,"Command '$cmd' requested by user '".$this->{_username}.
			"' mapped to '$perlcmd'",$para ? "with parameters '$para'" : "");
		if (eval "require $perlcmd;") {

lib/Arc/Connection/Server.pm  view on Meta::CPAN

   # This method is mearly here so a sub-class can override it.

   return undef;
}

sub _SplitCmdArgs
{
   my $this = shift;
   my $para = shift;
   return split(/\s+/,$para) if defined $para; # better splitting for array TODO
   return ();
}

sub _RunCmd
{
	my $this = shift;
	my ($cmd, $perlcmd, $argref) = @_;

	my $cmderr;
	my $ret = eval {
		my $object = new $perlcmd (
			_commands => $this->{commands},
			_username => $this->{_username},
			_realm    => $this->{_realm},
			_mech     => $this->{_saslmech},
			_peeraddr => $this->{_connection}->peerhost,
			_peerport => $this->{_connection}->peerport,
			_peername => $this->{_connection}->peername,
			_cmd => $cmd,
			logfileprefix => "command",
		);
		$object->Execute(@{ $argref });
		$cmderr = $object->IsError();
		return 0;
	};

	$ret = 2 unless defined($ret);
	$cmderr .= " ".$@ if $@;

	return ($ret, $cmderr);
}

## does nothing, placeholder for QUIT\r\n command, sent by the client.
sub _RQUIT
{
	my $this = shift;
	return 1;
}

## Public function, gets the clientsocket (from Arc::Server) and handles it.
## Handles a connection (main loop).
##in> $clientsock (IO::Socket)
##out> true on success, otherwise false
##eg> $arc->HandleClient(sock);
sub HandleClient
{
	my $this = shift;
	return $this->_SetError("Client socket needed.") unless (@_ == 1);
	my $client = shift;

# Fill the connected Socket into the select object
	$this->{_connection} = $client;
	$this->{_connected} = 1;
	$this->{_select} = new IO::Select( $client );

	my $line = $this->_RecvLine();
	unless ($this->{_error}) {
		if ($line =~ m/^ARC\/2.(0|1)\r?\n$/) { # Protocoltype 2

			$this->{protocol} = $1;
			$this->Log(LOG_USER,"Arc v2.$1 Session recognized.");
			$this->_Auth();

			my $cmd;
			while ((!$this->{_error}) && ($cmd = $this->_RecvCommand())) {
				last unless $this->_ProcessLine($cmd);
				last if $cmd eq "QUIT";
			}
			$this->Quit();
		} else {
			return $line;
		}
	}
	return !$this->{_error};
}

## Ends the connection.
## Do some cleanup.
##out> always true
##eg> $arc->Quit();
sub Quit
{
	my $this = shift;

	$this->{_connection}->close if ($this->{_connection});
	$this->{_connected} = 0;
	delete $this->{_sasl};
	$this->{_authenticated} = 0;

	1;
}

1;