package Event::RPC::Connection;

use Carp;
use Socket;

my $CONNECTION_ID;

sub get_cid			{ shift->{cid}				}
sub get_sock			{ shift->{sock}				}
sub get_server			{ shift->{server}			}

sub get_classes			{ shift->{server}->{classes}		}
sub get_loaded_classes		{ shift->{server}->{loaded_classes}	}
sub get_objects			{ shift->{server}->{objects}		}
sub get_client_objects		{ shift->{client_objects}		}

sub get_watcher			{ shift->{watcher}			}
sub get_message			{ shift->{message}			}
sub get_is_authenticated	{ shift->{is_authenticated}		}
sub get_auth_user		{ shift->{auth_user}			}

sub set_watcher			{ shift->{watcher}		= $_[1]	}
sub set_message			{ shift->{message}		= $_[1]	}
sub set_is_authenticated	{ shift->{is_authenticated}	= $_[1]	}
sub set_auth_user		{ shift->{auth_user}		= $_[1]	}

sub new {
	my $class = shift;
	my  ($server, $sock) = @_;

	my $cid = ++$CONNECTION_ID;
	
	my $self = bless {
		cid     		=> $cid,
		sock    		=> $sock,
		server  		=> $server,
		is_authenticated	=> (!$server->get_auth_required),
		auth_user		=> "",
		watcher 		=> undef,
		message 		=> undef,
		client_objects		=> {},
	}, $class;

	if ( $sock ) {
		$self->log (2,
			"Got new RPC connection. Connection ID is $cid"
		);
		$self->{watcher} = $self->get_server->get_loop->add_io_watcher (
			fh   => $sock,
			poll => 'r',
			cb   => sub { $self->input; 1 },
			desc => "rpc client cid=$cid",
		);
	}

	my $connection_hook = $server->get_connection_hook;
	&$connection_hook($self, "connect") if $connection_hook;

	return $self;
}

sub disconnect {
	my $self = shift;

	close $self->get_sock;
	$self->get_server->get_loop->del_io_watcher($self->get_watcher);
	$self->set_watcher(undef);

	my $server = $self->get_server;

	$server->set_clients_connected ( $self->get_server->get_clients_connected - 1 );

	foreach my $oid ( keys %{$self->get_client_objects} ) {
		$server->deregister_object($oid);
	}

	$self->log(2, "Client disconnected");

	my $connection_hook = $server->get_connection_hook;
	&$connection_hook($self, "disconnect") if $connection_hook;

	1;
}

sub log {
	my $self = shift;

	my ($level, $msg);
	if ( @_ == 2 ) {
		($level, $msg) = @_;
	} else {
		($msg) = @_;
		$level = 1;
	}

	$msg = "cid=".$self->get_cid.": $msg";
	
	return $self->get_server->log ($level, $msg);
}

sub input {
	my $self = shift;
	my ($e) = @_;

	my $server  = $self->get_server;
	my $message = $self->get_message;

	if ( not $message ) {
		$message = Event::RPC::Message->new ($self->get_sock);
		$self->set_message($message);
	}

	my $request = eval { $message->read } || '';
	my $error = $@;

	return if not defined $request and not $error;

	$self->set_message(undef);

	return $self->disconnect
		if $request eq "DISCONNECT\n" or
		   $error =~ /DISCONNECTED/;

	my ($cmd, $rc);
	$cmd = $request->{cmd} if not $error;
	
	$self->log(4, "RPC command: $cmd");
	
	if ( $error ) {
		$self->log ("Unexpected error on incoming RPC call: $@");
		$rc = {
			ok  => 0,
			msg => "Unexpected error on incoming RPC call: $@",
		};

	} elsif ( $cmd eq 'version' ) {
		$rc = {
			ok       => 1,
			version  => $Event::RPC::VERSION,
			protocol => $Event::RPC::PROTOCOL,
		};

	} elsif ( $cmd eq 'auth' ) {
		$rc = $self->authorize_user ($request);

	} elsif ( $server->get_auth_required && !$self->get_is_authenticated ) {
		$rc = {
			ok  => 0,
			msg => "Authorization required",			
		};

	} elsif ( $cmd eq 'new' ) {
		$rc = $self->create_new_object ($request);

	} elsif ( $cmd eq 'exec' ) {
		$rc = $self->execute_object_method ($request);

	} elsif ( $cmd eq 'classes_list' ) {
		$rc = $self->get_classes_list ($request);

	} elsif ( $cmd eq 'class_info' ) {
		$rc = $self->get_class_info ($request);

	} elsif ( $cmd eq 'class_info_all' ) {
		$rc = $self->get_class_info_all ($request);

	} elsif ( $cmd eq 'client_destroy' ) {
		$rc = $self->object_destroyed_on_client ($request);

	} else {
		$self->log ("Unknown request command '$cmd'");
		$rc = {
			ok  => 0,
			msg => "Unknown request command '$cmd'",
		};
	}

	$message->write($rc) and return;

	my $watcher;
	$watcher = $self->get_server->get_loop->add_io_watcher (
		fh	=> $self->get_sock,
		poll	=> 'w',
		cb	=> sub {
		    $self->get_server->get_loop->del_io_watcher($watcher)
		    	if $message->write;
		    1;
		},
	);

	1;
}

sub authorize_user {
	my $self = shift;
	my ($request) = @_;
	
	my $user = $request->{user};
	my $pass = $request->{pass};
	
	my $auth_passwd_href = $self->get_server->get_auth_passwd_href;
	my $server_pass = $auth_passwd_href->{$user} || '';

	if ( $server_pass eq $pass ) {
		$self->set_auth_user($user);
		$self->set_is_authenticated(1);
		$self->log("User '$user' successfully authorized");
		return {
			ok  => 1,
			msg => "Credentials Ok",
		};
	} else {
		$self->log("Illegal credentials for user '$user'");
		return {
			ok  => 0,
			msg => "Illegal credentials",
		};
	}
}

sub create_new_object {
	my $self = shift;
	my ($request) = @_;

	# Let's create a new object
	my $class_method = $request->{method};
	my $class = $class_method;
	$class =~ s/::[^:]+$//;
	$class_method =~ s/^.*:://;

	# check if access to this class/method is allowed
	if ( not defined $self->get_classes->{$class}->{$class_method} or
	     $self->get_classes->{$class}->{$class_method} ne '_constructor' ) {
		$self->log ("Illegal constructor access to $class->$class_method");
		return {
			ok  => 0,
			msg => "Illegal constructor access to $class->$class_method"
		};

	}
	
	# load the class if not done yet
	$self->load_class($class);

	# resolve object params
	$self->resolve_object_params ($request->{params});

	# ok, the class is there, let's execute the method
	my $object = eval {
		$class->$class_method (@{$request->{params}})
	};

	# report error
	if ( $@ ) {
		$self->log ("Error: can't create object ".
			    "($class->$class_method): $@");
		return {
			ok  => 0,
			msg => $@,
		};
	}

	# register object
	$self->get_server->register_object ($object, $class);
	$self->get_client_objects->{"$object"} = 1;

	# log and return
	$self->log (5,
		"Created new object $class->$class_method with oid '$object'",
	);

	return {
		ok  => 1,
		oid => "$object",
	};
}

sub load_class {
	my $self = shift;
	my ($class) = @_;
	
	my $mtime;
	my $load_class_info = $self->get_loaded_classes->{$class};

	if ( not $load_class_info or
	     ( $self->get_server->get_auto_reload_modules &&
	       ( $mtime = (stat($load_class_info->{filename}))[9])
		  > $load_class_info->{mtime} ) ) {
	
		if ( not $load_class_info->{filename} ) {
			my $filename;
			my $rel_filename = $class;
			$rel_filename =~ s!::!/!g;
			$rel_filename .= ".pm";

			foreach my $dir ( @INC ) {
				$filename = "$dir/$rel_filename", last
					if -f "$dir/$rel_filename";
			}

			croak "File for class '$class' not found"
				if not $filename;
			
			$load_class_info->{filename} = $filename;
			$load_class_info->{mtime} = 0;
		}
	
		$mtime ||= 0;

		$self->log (3, "Class '$class' ($load_class_info->{filename}) changed on disk. Reloading...")
			if $mtime > $load_class_info->{mtime};

		do $load_class_info->{filename};

		if ( $@ ) {
			$self->log ("Can't load class '$class': $@");
			$load_class_info->{mtime} = 0;

			return {
				ok  => 0,
				msg => "Can't load class $class: $@",
			};

		} else {
			$self->log (3, "Class '$class' successfully loaded");
			$load_class_info->{mtime} = time;
		}
	}
	
	$self->log (5, "filename=".$load_class_info->{filename}.
		    ", mtime=".$load_class_info->{mtime} );

	$self->get_loaded_classes->{$class} ||= $load_class_info;

	1;
}

sub execute_object_method {
	my $self = shift;
	my ($request) = @_;

	# Method call of an existent object
	my $oid = $request->{oid};
	my $object_entry = $self->get_objects->{$oid};
	my $method = $request->{method};

	if ( not defined $object_entry ) {
		# object does not exists
		$self->log ("Illegal access to unknown object with oid=$oid");
		return {
			ok  => 0,
			msg => "Illegal access to unknown object with oid=$oid"
		};

	}
	
	my $class = $object_entry->{class};
	if ( not defined $self->get_classes->{$class} or
	     not defined $self->get_classes->{$class}->{$method} ) {
		# illegal access to this method
		$self->log ("Illegal access to $class->$method");
		return {
			ok  => 0,
			msg => "Illegal access to $class->$method"
		};

	}
	
	# (re)load the class if not done yet
	$self->load_class($class);

	# resolve object params
	$self->resolve_object_params ($request->{params});

	# ok, try executing the method
	my @rc = eval {
		$object_entry->{object}->$method (@{$request->{params}})
	};

	# report error
	if ( $@ ) {
		$self->log ("Error: can't call '$method' of object ".
			    "with oid=$oid: $@");
		return {
			ok  => 0,
			msg => $@,
		};
	}
	
	# log
	$self->log (4, "Called method '$method' of object ".
		       "with oid=$oid");

	# check if objects are returned by this method
	# and register them in our internal object table
	# (if not already done yet)
	my $key;
	foreach my $rc ( @rc ) {
		if ( ref ($rc) and ref ($rc) !~ /ARRAY|HASH|SCALAR/ ) {
			# returns a single object
			$self->log (4, "Method returns object: $rc");
			$key = "$rc";
			$self->get_client_objects->{$key} = 1;
			$self->get_server->register_object($rc, ref $rc);
			$rc = $key;

		} elsif ( ref $rc eq 'ARRAY' ) {
			# possibly returns a list of objects
			# make a copy, otherwise the original object references
			# will be overwritten
			my @val = @{$rc};
			$rc = \@val;
			foreach my $val ( @val ) {
				if ( ref ($val) and ref ($val) !~ /ARRAY|HASH|SCALAR/ ) {
					$self->log (4, "Method returns object lref: $val");
					$key = "$val";
					$self->get_client_objects->{$key} = 1;
					$self->get_server->register_object($val, ref $val);
					$val = $key;
				}
			}
		} elsif ( ref $rc eq 'HASH' ) {
			# possibly returns a hash of objects
			# make a copy, otherwise the original object references
			# will be overwritten
			my %val = %{$rc};
			$rc = \%val;
			foreach my $val ( values %val ) {
				if ( ref ($val) and ref ($val) !~ /ARRAY|HASH|SCALAR/ ) {
					$self->log (4, "Method returns object href: $val");
					$key = "$val";
					$self->get_client_objects->{$key} = 1;
					$self->get_server->register_object($val, ref $val);
					$val = $key;
				}
			}
		}
	}

	# return rc
	return {
		ok => 1,
		rc => \@rc,
	};
}

sub object_destroyed_on_client {
	my $self = shift;
	my ($request) = @_;

	$self->log(5, "Object with oid=$request->{oid} destroyed on client");

	delete $self->get_client_objects->{$request->{oid}};
	$self->get_server->deregister_object($request->{oid});

	return {
		ok => 1
	};
}

sub get_classes_list {
	my $self = shift;
	my ($request) = @_;

	my @classes = keys %{$self->get_classes};
	
	return {
		ok      => 1,
		classes => \@classes,
	}
}

sub get_class_info {
	my $self = shift;
	my ($request) = @_;

	my $class = $request->{class};
	
	if ( not defined $self->get_classes->{$class} ) {
		$self->log ("Unknown class '$class'");
		return {
			ok  => 0,
			msg => "Unknown class '$class'"
		};
	}
	
	$self->log (4, "Class info for '$class' requested");

	return {
		ok           => 1,
		methods      => $self->get_classes->{$class},
	};
}

sub get_class_info_all {
	my $self = shift;
	my ($request) = @_;

	return {
		ok             => 1,
		class_info_all => $self->get_classes,
	}
}

sub resolve_object_params {
	my $self = shift;
	my ($params) = @_;
	
	my $key;
	foreach my $par ( @{$params} ) {
		if ( defined $self->get_classes->{ref($par)} ) {
			$key = ${$par};
			$key = "$key";
			croak "unknown object with key '$key'"
				if not defined $self->get_objects->{$key};
			$par = $self->get_objects->{$key}->{object};
		}
	}
	
	1;
}

1;

__END__

=head1 NAME

Event::RPC::Connection - Represents a RPC connection

=head1 SYNOPSIS

Note: you never create instances of this class in your own code,
it's only used internally by Event::RPC::Server. But you may request
connection objects using the B<connection_hook> of Event::RPC::Server
and then having some read access on them.

  my $connection = Event::RPC::Server::Connection->new (
      $rpc_server, $client_socket
  );

=head1 DESCRIPTION

Objects of this class represents a connection from an Event::RPC::Client
to an Event::RPC::Server instance.

The whole Client/Server protocol is implemented here.

=head1 READ ONLY ATTRIBUTES

The following attributes may be read using the corresponding
get_ATTRIBUTE accessors:

=over 4

=item B<cid>

The connection ID of this connection. A number which is unique
for this server instance.

=item B<server>

The Event::RPC::Server instance this connection belongs to.

=item B<is_authenticated>

This boolean value reflects whether the connection is authenticated
resp. whether the client passed correct credentials.

=item B<auth_user>

This is the name of the user who was authenticated successfully for
this connection.

=back

=head1 AUTHORS

  Jörn Reder <joern at zyn dot de>

=head1 COPYRIGHT AND LICENSE

Copyright 2002-2005 by Jörn Reder.

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library 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
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307
USA.

=cut

