Agent::TCLI::Transport::Base - Base Class for transports

Agent-TCLI documentation Contained in the Agent-TCLI distribution.

Index

Code Index:

NAME

Top

Agent::TCLI::Transport::Base - Base Class for transports

SYNOPSIS

Top

Use as a base class for a Agent::TCLI::Transport

DESCRIPTION

Top

GETTING STARTED

Top

ATTRIBUTES

The following attributes may be accessed through a combined mutator. If the attribute is an array type, then additional array mutators are available and described below.

controls

A hash of the active controls controls will only accept hash objects.

alias

An alias that the session will be run under. Alias can't be changed after starting.

peers

An array of peers set_peers will only accept ARRAYREF type values.

control_options

A hash of options to pass to a new control object. These are passed straight through as is. See Agent::TCLI::Control for information about the options. control_options will only accept HASHREF type values.

Arrays

Attributes that are typed as arrays also support the following mutators for the lazy: shift_>field< - works the same as shift, returing the shifted member. unshift_>field<(list) - works the same as unshift. pop_>field< - works the same as pop, returing the popped member. push_>field<(list) - works the same as push. depth_>field< - returns the curent size of the array.

METHODS

These methods may be used as is, or subclasses may use them as starting point.

_start

Get things rolling.

_stop

Mostly just a placeholder.

_child

Just a placeholder.

_shutdown

Forcibly shutdown

PackRequest

This object method is used by transports to prepare a request for transmssion.

Currently the code is taking a lazy approach and using Perl's YAML and OIO->dump to safely freeze and thaw the request/responses for Internet transport. By standardizing these routines in the Base class, more elegant methods may be transparently enabled in the future.

PackResponse

This object method is used by transports to prepare a reseponse for transmssion. See PackRequest for more details.

UnpackRequest

This object method is used by transports to unpack a request from transmssion. See PackRequest for more details.

UnpackResponse

This object method is used by transports to unpack a reseponse from transmssion. See PackRequest for more details.

authorized ( { parameters (see usage) } )

Checks to see if a id is authorized to use us.

Usage

$self->authorized ( user@example.com, qr(master|writer), # optional regex for auth qr(xmpp), # optional regex for protocol );

GetControl( <control_id>, <user>, <user_protocol>, [ <user_auth> ] )

GetControl returns a control object for a control_id / user combination. It will return either an existing control or create a new one. All requests for a control are authenticated. Thus when a Transport recieves a new request, user priviledges are rechecked against the latest database if GetControl is used to obtain the Control.

The control_id is a unique ID for the transport to use to identify the control. This is useful in situations where a user may have more than one control active at a time. The user must be a Agent::TCLI::User object. The protocol should be one that the Transport supports and will be matched for authentication. A transport may optionally override the user_auth level. This would be best used to drop to a read only transport, but currently the direction is not enforced.

DeleteControl ( <control_id> )

DeleteControl will remove a reference to Control from the transport. This does not shutdown the Control's POE session, but will allow it to stop if there are no other existing references.

Set

This POE event handler is may be used by a Transport to enable a Package to set attributes in the Transport. It currently is not filtering out anything, so if something should not be accessible, either the Transport needs to implement its own Set, or the Package should apply necessary filters.

Set takes a hash of attribute => value pairs, and the Request object as arguments.

Show

This POE event handler is may be used by a Transport to enable a Package to show current settings in the Transport. It currently is not filtering out anything, so if something should not be shown, either the Transport needs to implement its own Show, or the Package should apply necessary filters.

Show takes the attribute to show and the Request object as arguments.

_default

This POE event handler is used to catch wayard calls to unavailable states. If verbose is on, it makes it rather obvious in the logs that an event was not handled.

AUTHOR

Top

Eric Hacker hacker can be emailed at cpan.org

BUGS

Top

SHOULDS and MUSTS are currently not enforced.

New commands could clobber old ones under certain circumstances.

Test scripts not thorough enough.

Probably many others.

LICENSE

Top

Copyright (c) 2007, Alcatel Lucent, All rights resevred.

This package is free software; you may redistribute it and/or modify it under the same terms as Perl itself.

Agent-TCLI documentation Contained in the Agent-TCLI distribution. 
# $Id: Base.pm 62 2007-05-03 15:55:17Z hacker $
package Agent::TCLI::Transport::Base;


# General setup {{{
use warnings;
use strict;
use Carp;

use POE;
use Agent::TCLI::Control;
use Agent::TCLI::Request;
require Agent::TCLI::Base;

use Object::InsideOut qw( Agent::TCLI::Base );

use Data::Dump qw(pp);
use YAML qw(freeze thaw);

our $VERSION = '0.031.'.sprintf "%04d", (qw($Id: Base.pm 62 2007-05-03 15:55:17Z hacker $))[2];


my @controls 	:Field
				:All('controls')
				:Type('hash');


my @alias		:Field
				:Get('alias');


my @peers		:Field
				:All('peers')
				:Type('ARRAY');

# Holds our session data. Made weak per Merlyn
# http://poe.perl.org/?POE_Cookbook/Object_Methods.
# We also don't take session on init.
my @session		:Field
				:Arg('session')
				:Get('session')
				:Weak;


my @control_options	:Field
					:All('control_options')
					:Type('HASHREF');

# Standard class utils are inherited


my %init_args :InitArgs = (
    'alias' => {
        'Default'		=> 'base',
    	'Field'			=> \@alias,
    },
);

##u_ subs can't be private if used in %init_args
##named u_ to sort nicer in Eclipse
#sub u_is_text {
#	return (
#		 validate_pos( @_, { type => Params::Validate::SCALAR | Params::Validate::SCALARREF } )
#		 )
#}
#sub u_is_num {
#	return (
#		 Scalar::Utils->looks_like_number($_[0])
#		 )
#}
#sub u_is_int {
#         my $arg = $_[0];
#         return (Scalar::Util::looks_like_number($arg) &&
#                 (int($arg) == $arg));
#     }


sub _init :Init {
	my ($self, $args) = @_;

}


sub _start :Cumulative {
  my ($kernel,  $self, $session) =
    @_[KERNEL, OBJECT,  SESSION];

	# are we up before OIO has finished initializing object?
	if (!defined( $self->alias ))
	{
    $self->Verbose("_start: OIO not started delaying ",0);
		$kernel->call('_start');
		return;
	}

	# There is only one command object per TCLI
    $kernel->alias_set($self->alias);

    $self->Verbose("_start: Starting alias(".$self->alias.")",0);

} # End sub start


sub _stop :Cumulative {
  my ($kernel,  $self, $session) =
    @_[KERNEL, OBJECT,  SESSION];
    $self->Verbose("stop: ".$self->name." stopping " ,1);
}


sub _child {
  my ($kernel,  $self, $session, $id, $error) =
    @_[KERNEL, OBJECT,  SESSION, ARG1, ARG2 ];

   $self->Verbose("child: id($id) error($error)") if (defined($error));
}


sub _shutdown :Cumulative {
    my ($kernel,  $self, $session) =
    @_[KERNEL, OBJECT,  SESSION];
	# TODO, do some proper signal handling
	# especially reconnect on HUP and something on INT

	$self->Verbose('_shutdown: dropping controls',1, $self->controls);

	if ( defined( $self->controls ) )
	{
		foreach my $control ( values %{$self->controls} )
		{
			$kernel->post( $control->id() => '_shutdown' );
			delete(  $self->controls->{ $control->id }  );
		}
	}

	$self->Verbose("_shutdown: removing alarms",1,$kernel->alarm_remove_all() );

    $kernel->alias_remove( $self->alias );

    return("_shutdown ".$self->alias  );
}

sub ControlExecute {
	my ($kernel,  $self, $control, $request ) =
	  @_[KERNEL, OBJECT,     ARG0,     ARG1 ];
	$self->Verbose("ControlExecute: control(".$control->id.") req(".$request->id.") ");

	# Sometimes, control has not started, so we wiat if we have to.
	if ( defined($control->start_time) )
	{
		$kernel->post( $control->id() => 'Execute' => $request );
	}
	else
	{
		$kernel->delay('ControlExecute' => 1 => $control, $request );
	}
}


# TODO review XEP on this, esp version numbers and best practices.

sub PackRequest {
	my ($self, $request) = @_;
	my $dump = $request->dump();

	# Take out the Base to save space since we're ignore this at the other end.
	delete $dump->[1]{'Agent::TCLI::Base'};

	my $packed_request = freeze($dump);
	return($packed_request);
}


sub PackResponse {
	my ($self, $response) = @_;
	my $dump = $response->dump();

	# Take out the Base to save space since we're ignore this at the other end.
	delete $dump->[1]{'Agent::TCLI::Base'};

	# freeze does not terminate the yaml
	my $packed_response = freeze($dump);
	return($packed_response);
}


sub UnpackRequest {
	my ($self, $packed_request) = @_;
	$self->Verbose("UnpackRequest: $packed_request");

	my $request_array = thaw($packed_request);
	my %automethod_fields;

	foreach my $field ( keys %{ $request_array->[1]{'Agent::TCLI::Request'} } )
	{
		if ( $field =~ s/^get_// )
		{
			my $acc = 'get_'.$field;
			my $mut = 'set_'.$field;
			$automethod_fields{$mut} = $request_array->[1]{'Agent::TCLI::Request'}{ $acc }
				if (defined( $request_array->[1]{'Agent::TCLI::Request'}{ $acc } ));
			delete $request_array->[1]{'Agent::TCLI::Request'}{ $acc };
		}
	}

	my $request = Object::InsideOut->pump( $request_array );

	foreach my $field ( keys %automethod_fields )
	{
		$request->$field( $automethod_fields{$field} );
	}

	$request->verbose($self->verbose);
	$request->do_verbose($self->do_verbose);

	$self->Verbose("UnpackRequest: unpacked ".$request->dump(1),3 );

	return($request);
}


sub UnpackResponse {
	my ($self, $packed_response) = @_;
	$self->Verbose("UnpackResponse: $packed_response");

	my $response_array = thaw($packed_response);
	my %automethod_fields;

	foreach my $field ( keys %{ $response_array->[1]{'Agent::TCLI::Request'} } )
	{
		if ( $field =~ s/^get_// )
		{
			my $acc = 'get_'.$field;
			my $mut = 'set_'.$field;
			$automethod_fields{$mut} = $response_array->[1]{'Agent::TCLI::Request'}{ $acc }
				if (defined( $response_array->[1]{'Agent::TCLI::Request'}{ $acc } ));
			delete $response_array->[1]{'Agent::TCLI::Request'}{ $acc };
		}
	}

	my $response = Object::InsideOut->pump( $response_array );

	foreach my $field ( keys %automethod_fields )
	{
		$response->$field( $automethod_fields{$field} );
	}

	$response->verbose($self->verbose);
	$response->do_verbose($self->do_verbose);

	$self->Verbose("UnpackResponse: unpacked ".$response->dump(1),3 );

	return($response);
}


sub authorized {
	my ($self, $id, $auth, $protocol) = @_;
	$auth = defined($auth) ? $auth : qr(.*);
	$protocol = defined($protocol) ? $protocol : qr(.*);
	$self->Verbose("authorized: id(".$id.") auth($auth) protocol($protocol)",2);

	# create a blank user as kludge to simply debugging output.
	# This might be a slow memory exhaustion for lots of auth checks
	# if they are not getting cleand up properly
	my $authorized = 	Agent::TCLI::User->new(
			'id'		=> 'no one',
			'protocol'	=> 'none',
			'auth'		=> 'nil',
		);

	# only one should match on id and we get 0 on non id match,
	# so we'll just add through the whole loop of authorized peers
	# and add up the total.

	foreach my $pid ( @{$peers[$$self]} )
	{


		# user not_authorized returns something when not authorized.
	  	my $check = $pid->not_authorized ( {
	  		id	   		=>  $id,
			protocol 	=>  $protocol,
			auth		=>  $auth,
			} );
		$self->Verbose("not_authorized: Checked peer ".$pid->id." got ($check)",3);

	  	if ( !$check  )
	  	{
			# Set authorized to last matched user
			$authorized = $pid;
		}
	} #end foreach peer

	$self->Verbose("authorized:  ".$id." auth check got ".
		$authorized->id()." \n",1);

	return ($authorized)
} # End authorized


sub GetControl {
	my ($self, $control_id, $user, $user_protocol, $user_auth ) = @_;
	$self->Verbose($self->alias.":GetControl: id(".$control_id.") \n");

	my $user_id = ref($user) =~ /User/i ? $user->id : $user;

	my $auth_user = $self->authorized (
	  	$user_id,
	  	qr(.*),
	  	$user_protocol,
	  	);

	return (0) if ( $auth_user->auth eq 'nil' );

	$user_auth = $auth_user->auth unless defined($user_auth);

	if (defined( $controls[$$self]{$control_id} ))   #control in controls hash
	{
	  	$self->Verbose("GetControl: returning existing control for ".$control_id);
	}
	else   # new control
	{
		$controls[$$self]{$control_id} = Agent::TCLI::Control->new({
			'id'		=> $control_id,
			'user'		=> $auth_user,
			'auth'		=> $auth_user->auth(),
			'owner'		=> $self,
        	'verbose'	=> $self->verbose,
        	'do_verbose'=> $self->do_verbose,
        	%{$self->control_options},
    	});

		# This EXAMPLE shows how to set new control attributes.
		# $controls[$$self]{$control_id}->set_option($option);

	    $self->Verbose( "GetControl: New control ".$control_id." on input from ".$auth_user->id." \n",2);
	    $self->Verbose( "GetControl: self dump \n",4,$self);

    } # end if defined control

    return ( $controls[$$self]{$control_id} );

} # End GetControl


sub DeleteControl {
	my ($self, $control_id ) = @_;
	$self->Verbose($self->alias.":GetControl: id(".$control_id.") \n");

	if (defined( $controls[$$self]{$control_id} ))   #control in controls hash
	{
	  	$self->Verbose("DeleteControl: deleting control for ".$control_id);
	  	delete($controls[$$self]{$control_id});
	}
	else   # not there
	{
	  	$self->Verbose("DeleteControl: control ".$control_id." not found");
    } # end if defined control

  return ( 1 );

} # End DeleteControl


sub Set {
	my ($kernel,  $self, $params, $request) =
	  @_[KERNEL, OBJECT,    ARG0,     ARG1];
    $self->Verbose("Set: params ",1,$params);

	my $txt = '';
	my $code;

	# TODO a way to unset/restore defaults....

	# lets see how it goes....
	foreach my $attr ( keys %{$params} )
	{
		# special case for verbose.
		$attr = 'verbose' if ($attr =~ qr(_verbose));


		eval { $self->$attr( $params->{$attr} ) };

		if( $@ )
		{
			$self->Verbose("Set: self->".$attr.'('.$params->{$attr}.' ) got ('.$@.') ');
			$txt = "Invalid: $attr => ".$params->{$attr}." !";
			$code = 400;
		}
		else
		{
			$txt = "Set: $attr =>  ".$params->{$attr}."  ";
			$code = 200;
		}

		if ($request)
		{
			$self->Verbose('Set: responding txt('.$txt.') code('.$code." )",2);
			$request->Respond($kernel, $txt, $code);
		}
	}
}


sub Show {
	my ($kernel,  $self, $attr, $request) =
	  @_[KERNEL, OBJECT,  ARG0,     ARG1];
    $self->Verbose("Show: $attr ",1);

	my $txt = '';
	my ($code, $value);

	if ($attr eq 'peers')
	{
		# loop over the users
		foreach my $peer ( @{$self->peers} )
		{
			$txt .= "\nid: ".$peer->id."\nprotocol: ".$peer->protocol.
				"\nauth: ".$peer->auth."\npassword: ******\n";
			$code = 200;
		}
	}
	elsif ($attr eq 'controls')
	{
		# loop over the controls
		foreach my $control ( keys %{$self->controls} )
		{
			$txt .= "\nid: ".$control->id."\n";
			$code = 200;
		}
	}
	else
	{
		# lets see how it goes....
		eval { $value = $self->$attr };

		if( $@ )
		{
			$self->Verbose("Show: self->$attr got (".$@.') ');
			$txt = "Invalid $attr : $@ !";
			$code = 400;
		}
		elsif ( ref($value) )
		{
			$txt = "$attr is not a scalar. Dumping: \n";
			$txt .= pp($value);
			$code = 200;
		}
		else
		{
			$txt = "$attr => $value ";
			$code = 200;
		}
	}

	if ($request)
	{
		$self->Verbose('Show: responding txt('.$txt.') code('.$code." )",3);
		$request->Respond($kernel, $txt, $code);
		return;
	}
	# What do we do if there is no request?
}


sub _default {
  my ($kernel,  $self, ) =
    @_[KERNEL, OBJECT, ];
 	my $oops = "\n\n\n".
	"\t  OOOO      OOOO    PPPPPP    SSSSSS    ##  \n".
	"\t OO  OO    OO  OO   PP   PP  SS         ##  \n".
	"\tOO    OO  OO    OO  PP   PP  SS         ##  \n".
	"\tOO    OO  OO    OO  PPPPPP    SSSSSS    ##  \n".
	"\tOO    OO  OO    OO  PP             SS   ##  \n".
	"\t OO  OO    OO  OO   PP             SS       \n".
	"\t  OOOO      OOOO    PP        SSSSSS    ##  \n";
	$self->Verbose($oops);
	$self->Verbose("\n\nDefault caught an unhandled $_[ARG0] event.\n");
	$self->Verbose("The $_[ARG0] event was given these parameters:");
	$self->Verbose("ARG1 dumped",1,$_[ARG1]) if defined($_[ARG1]);
	$self->Verbose("ARG2 dumped",1,$_[ARG2]) if defined($_[ARG2]);

	return (0);
}

1;

#__END__