view release on metacpan or  search on metacpan

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

	my ($this,$type,$realm,$maxlen,$user) = @_;
	return $user;
}

## send the available SASL mechanisms.
## Protocol command: AUTH <comma-seperated list of SASL mechansims>\r\n
##out> true when succesful, otherwise false
##eg> $this->_Auth();
sub _Auth
{
	my $this = shift;

	@{$this->{_expectedcmds}} = qw(QUIT AUTHENTICATE);
	return $this->_SendCommand("AUTH",join (",",@{$this->{sasl_mechanisms}}));
}

## send an error msg to client (Server error).
## Protocol command: ERR <msg>\r\n
##out> true when succesful, otherwise false
##eg> $this->_Error("failure.");
sub _Error
{
	my $this = shift;
	return $this->_SendCommand("ERR",join("",@_));
}

## send a command error msg to client.
## Protocol command: CMDERR <msg>\r\n
##out> true when succesful, otherwise false
##eg> $this->_CmdError("failure.");
sub _CmdError
{
	my $this = shift;
	return $this->_SendCommand("CMDERR",join("",@_));
}

## command is ready.
## When the ARCv2 command is ready with its work, the server
## sends the DONE command on the control connection.
## Protocol command: DONE\r\n
##out> true when succesful, otherwise false
##eg> $this->_Done();
sub _Done
{
	my $this = shift;
	return $this->_SendCommand("DONE");
}

## tell the client, which SASL mechanism is used.
## Protocol command: AUTHTYPE <SASL mechansism>\r\n
##out> true when succesful, otherwise false
##eg> $this->_Authtype();
sub _Authtype
{
	my $this = shift;
	@{$this->{_expectedcmds}} = qw(QUIT SASL);
	return $this->_SendCommand("AUTHTYPE",$this->{_saslmech});
}

## Creates the sasl object (server_new)
## and sends the first sasl challenge/response.
## Protocol command: SASL <base64 encoded SASL output>\r\n
##out> true when succesful, otherwise false
##eg> $this->_StartAuthentication();
sub _StartAuthentication
{
	my $this = shift;

	$this->_PrepareAuthentication() || return;

	# Setting the Callback for getting the username
	# This has to happen just before the object-creation of cyrus sasl
	# because there is no way to set a callback after sasl_*_new
	$this->{__sasl}->callback(
		canonuser => [ \&_CBCanonUser, $this ],
		checkpass => $this->{sasl_cb_checkpass},
		getsecret => $this->{sasl_cb_getsecret},
	);

	my $sasl = $this->{_sasl} =
		$this->{__sasl}->server_new(
			$this->{service},
			"",
			inet_ntoa($this->{_connection}->sockaddr).";".$this->{_connection}->sockport,
			inet_ntoa($this->{_connection}->peeraddr).";".$this->{_connection}->peerport,
	);

	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;") {

			my $in =  new IO::Pipe || return $this->_SetError("Could not create in-Pipe");
			my $out = new IO::Pipe || return $this->_SetError("Could not create out-Pipe");
			my $err = new IO::Pipe || return $this->_SetError("Could not create err-Pipe");

			my $oldsigchld = $SIG{CHLD};
			$SIG{CHLD} = 'IGNORE';

			my $cmdpid = fork();
			if ($cmdpid == 0) { # Child
				$this->{logfileprefix} = "commandchild";

# prepare environment for the command
				$in->writer(); $out->reader(); $err->writer();
				open STDIN, "<&", $out;
				open STDOUT, ">&", $in;
				open STDERR, ">&", $err;

				my @a = $this->_SplitCmdArgs($para);
				my ($ret, $cmderr) = $this->_RunCmd($cmd, $perlcmd, \@a);

				if ($cmderr) {
					$ret = 1;
					$cmderr =~ s/\r//g; $cmderr =~ s/\n/ /g; $cmderr =~ s/ +/ /g;
					print $err $cmderr;
				}
				close $in; close $out; close $err;

				exit $ret;
			} elsif ($cmdpid) {

				$this->Log(LOG_SIDE,"Awaiting command connection.");
				$this->_CommandConnection();

				# check that the connecting host is really the host we are expecting to be.
				my ($peerport,$peeraddr) = sockaddr_in($this->{_cmdclientsock}->peername);
				$peeraddr = inet_ntoa($peeraddr);

				if ($peeraddr eq $this->{_connection}->peerhost) {

					$this->Log(LOG_CMD,"Command connection established.");