• Your recent searches
Agent-TCLI
21 results

 view release on metacpan or  search on metacpan

lib/Agent/TCLI/Transport/XMPP.pm  view on Meta::CPAN 


=head1 NAME

Net::CLI::Transport::XMPP - xmpp transport for Net::CLI

=head1 SYNOPSIS

todo

=head1 DESCRIPTION

=head1 GETTING STARTED

=cut

use warnings;
use strict;
use Carp;
use Date::Parse;

use POE;
use Net::Jabber;
use Socket;
use Agent::TCLI::Control;
use Agent::TCLI::Request;
require Agent::TCLI::Transport::Base;

use Object::InsideOut qw( Agent::TCLI::Transport::Base );
use Params::Validate qw(validate_with);

sub VERBOSE () { 0 }

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

=head1 INTERFACE

=head2 ATTRIBUTES

The following attributes are accessible through standard accessor/mutator
methods and may be set as a parameter to new unless otherwise noted.

=over

=item jid

xmpp id of user we're connecting as'
B<set_jid> will only accept SCALAR type values.

=cut
my @jid 	   :Field('All' => 'jid', 'Type' => 'Net::XMPP::JID' );

=item jserver

B<jserver> will only accept SCALAR type values.

=cut
my @jserver 	   :Field('All' => 'jserver' );

=item jpassword

The password for the transport to use to log in to the server.
B<jpassword> will only accept scalar type values.

=cut
my @jpassword  :Field('All' => 'jpassword');

=item xmpp_debug

Sets the debug (verbosity) level for the XMPP libraries

=cut
my @xmpp_debug			:Field  :All('xmpp_debug');

=item xmpp_process_time

Sets the time in seconds to wait before calling XMPP Process to look for
more XMPP data. Defaults to 1 and shouldn't be much larger.

=cut
my @xmpp_process_time	:Field
						:Arg('name'=>'xmpp_process_time', 'default'=> 1 )
						:Acc('xmpp_process_time');

=item peers

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

=cut
#my @peers 	   :Field('All' => 'peers', 'Type' => 'ARRAY' );

# Holds the XMPP connection session
my @xmpp	 	   :Field('Get' => 'xmpp');

=item connection_retries

A max number to retry connection before giving up.
B<connection_retries> will only accept NUMERIC type values.

=cut
my @connection_retries
			:Field
			:Arg('name'=>'connection_retries','default'=>10)
			:Acc('connection_retries')
			:Type('NUMERIC' );

=item connection_delay

How long to wait beteen connection attempts when failed. Defaults to 30 seconds.
B<connection_delay> will only accept NUMERIC type values.

=cut
my @connection_delay
			:Field
			:Arg('name'=>'connection_delay','default'=>30)
			:Acc('connection_delay')
			:Type('NUMERIC' );

=item roster

Holds the Net::XMPP::Roster if enabled. To enable the roster,
a paramater of 'roster' => 1, must be passed in with new.
B<roster> will contain a Net::XMPP::Roster object after initialization if enabled.

=cut
my @roster			:Field
					:All('roster');

=item server_time

The time at the server. Useful for determining if messages were sent before we started up.
B<server_time> should only contain hash values.

=cut
my @server_time		:Field
#					:Type('hash')
					:All('server_time');

=item group_mode

The default setting to determine how to interact with groups. Options are:
'all' - process everything said in room
'named' - process only when called by name: (name followed by colon).
'log' -	don't listen to anything, but log events there (which ones?)
'prefixed' - named + anything beginning with a designated prefix character
B<group_mode> should only contain scalar values.

=cut
my @group_mode		:Field
#					:Type('scalar')
					:Arg('name'=>'group_mode', 'Default' => 'named' )
					:Acc('group_mode');

=item group_prefix

The group_prefix used for group moded prefixed.
B<group_prefix> should only contain a single scalar value.

=cut
my @group_prefix	:Field
#					:Type('scalar')
					:Arg('name'=>'group_prefix', 'Default' => ':' )
					:Acc('group_prefix');


# Standard class utils are inherited

#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 _preinit :Preinit {
	my ($self, $args) = @_;

	$args->{'alias'} = 'transport_xmpp' unless defined( $args->{'alias'} );

	$args->{'session'} = POE::Session->create(
        object_states => [
        	$self => [ qw(
	            _start
            	_stop
        	    _shutdown
        	    _default
        	    _child

				ControlExecute
        	    Disconnected
        	    JoinPeerRooms
				JoinChatRoom
        	    Login

lib/Agent/TCLI/Transport/XMPP.pm  view on Meta::CPAN 


	# if connection retries is zero, then we shutdown with no delay.
	# This is important when we try to shutdown and the
	# xmpp->Disconnect is called. :)
	if ( !defined( $count )  && $connection_retries[$$self] > 0 )
	{
		$kernel->delay_set('Disconnected', $connection_delay[$$self], 1 );
		$self->Verbose("Disconnected: got XMPP disconnect waiting ".$connection_delay[$$self]." seconds" );
		return;
	}
	else
	{
		$count++;
		$self->Verbose("Disconnected: count ($count) \n" );
	}

	if ( $count >= $connection_retries[$$self] )
	{
  		$kernel->yield('_shutdown');
		$self->Verbose("Disconnected: SHUTDOWN in progress");
		return;
	}

	# make connection
	$self->Verbose("Disconnected: XMPP connecting to ".$jserver[$$self] );
	$xmpp[$$self]->Connect(
		hostname	=> $jserver[$$self],
	);
	if ( $xmpp[$$self]->Connected )
	{
		$kernel->yield('Login');
		$self->Verbose("Disconnected: Got connected ");
		return;
	}

	$kernel->delay_set('Disconnected', $connection_delay[$$self], $count );

} #end sub Disconnected

=item JoinPeerRooms

This POE event handler will go through each of the users in the peers array,
and if the peers is a groupchat, join the conference room. It will check to
make sure it is not already conencted (though this could be buggy). It does
not take any arguments.

=cut

sub JoinPeerRooms {
	my ($kernel,  $self, ) =
	  @_[KERNEL, OBJECT, ];
    $self->Verbose("JoinPeerRooms:  ",2);

	foreach my $user ( @{$self->peers} )
	{
		if ( $user->protocol =~ /groupchat/  )
		{
			if ( defined( $self->controls ) &&
				exists( $self->controls->{ $user->id.'-groupchat' } ) )
			{
				# should already be logged on?
			    $self->Verbose("JoinPeerRooms: already connected to ".$user->id ,2);
				return;
			}
			$kernel->yield('JoinChatRoom',
				$user->get_name,		# room name
				$user->get_domain,		# server
				$user->password,		# secret
			)
		}
	}
}

sub JoinChatRoom {
	my ($kernel,  $self, $room, $server, $secret) =
	  @_[KERNEL, OBJECT,  ARG0,    ARG1,   	ARG2];
    $self->Verbose("JoinChatroom: $room at $server ",2);

    $self->xmpp->MUCJoin(
    	'room'		=> $room,
		'server'	=> $server,
		'nick'		=> $self->jid->GetUserID,
		'password'	=> defined($secret) ? $secret : undef,
	);
}

sub Login {
	my ($kernel,  $self, ) =
	  @_[KERNEL, OBJECT, ];

	my $txt = '';

	# make connection
	$self->Verbose("login: XMPP connecting to ".$jserver[$$self] );
	$xmpp[$$self]->Connect(
		hostname	=> $jserver[$$self],
	);

	my @login;
	if ( $xmpp[$$self]->Connected()  )
	{
		#log in
		$self->Verbose("login: XMPP trying login as ".$self->jid()->GetUserID );
		@login = $xmpp[$$self]->AuthSend(
			username	=> $self->jid()->GetUserID,
			password	=> $jpassword[$$self],
			resource	=> $self->jid()->GetResource,
		);
		$self->Verbose("login: Did login for ".$self->jid()->GetUserID." Got ".$login[0] );

		if ( defined($login[0]) && $login[0] eq 'ok')
		{
		    $kernel->yield('Online');
		}
		elsif ( defined($login[1]) )
		{
			$txt .= "Login error-> ".$login[1];
		}
		else
		{
			$txt .= "Bad Login error-> ".$xmpp[$$self]->GetErrorCode();
		}
	}
	else
	{
		$txt .= "Connection error-> ".$xmpp[$$self]->GetErrorCode();
	}

	if ($txt ne '' )
	{
		$self->Verbose("login: ".$txt."\n",1,$xmpp[$$self]->GetErrorCode());
		$kernel->delay_set('Disconnected' => 10 , 1 );
	}

} # end sub login

sub Online {
	my ($kernel,  $self,  ) =
	  @_[KERNEL, OBJECT,  ];
	$self->Verbose("Online: \n" ,1);

	my %server_time = $self->xmpp->TimeQuery('mode'=>'block');
	$self->Verbose("Online: server_time($server_time{display})", 1,\%server_time );
	$self->set(\@server_time, $server_time{utc});

	# start roster
	if ($self->roster)
	{
		$self->Verbose("Online: enabling Roster ");
		$self->set(\@roster, $self->xmpp->Roster);
	}

	if (defined($self->control_options) )
	{
		$self->control_options->{'local_address'} = $self->Address
			unless defined($self->control_options->{'local_address'});
	}

	$kernel->delay_set( 'Process' => $xmpp_process_time[$$self] );

    $kernel->yield('send_presence',(
    {
		status   =>  'Online',
		priority =>  '1',
    } ) );

	$kernel->yield('JoinPeerRooms') if defined($self->peers);

} #end sub Online

=item Process (    )

This event interfaces with the XMPP Process to have it check for new data

=cut

sub Process {
	my ($kernel,  $self, ) =
	  @_[KERNEL, OBJECT, ];
	$self->Verbose("Process: " , 4);
	my $result = $xmpp[$$self]->Process(1);
	if ( defined($result) )
	{
		$self->Verbose("Process: (".$result.") for ".$self->alias." as ".$jid[$$self]->GetJID('full') );
		$kernel->delay_set( 'Process' => $xmpp_process_time[$$self] );
    }
    else
    {
		$kernel->yield( 'Disconnected' );
    }
} # End Process

# When we recv anything from XMPP the $response will be
# an array of the XMPP Session ID and then the XML message
# In ARG1 for some reason...

lib/Agent/TCLI/Transport/XMPP.pm  view on Meta::CPAN 


sub recvmsg {
 my ($kernel,  $self, $jSessionID, $response) =
	  @_[KERNEL, OBJECT,        ARG0,      ARG1 ];
	my $msg = $response->[1];
	$self->Verbose("recvmsg: got message from ".
  	$msg->GetFrom('jid')->GetJID('full')." ",1);

	my $control = $self->GetControlForNode( $msg );

	return unless $control;

	my $request = $self->GetRequestForNode($msg);

	# The control is transport agnostic. All it needs to know
	# is the input and what is stored in the control and request.
	$self->Verbose("recvmsg: sending to contol \n",2);

	$kernel->post( $control->id() => 'Execute' => $request );
}

sub recvmsgGroupchat {
	my ($kernel,  $self, $jSessionID, $packet) =
	@_[KERNEL, OBJECT,        ARG0,      ARG1 ];
	my $msg = $packet->[1];
	$self->Verbose("recvmsgGroupchat: msg dump",3,$msg);

	if ( $msg->GetFrom eq $jid[$$self] )
	{
		$self->Verbose("recvmsgGroupchat: ignoring from me \n",2);
		return;
	}

	if ($msg->DefinedX('jabber:x:delay') )
	{
		$self->Verbose("recvmsgGroupchat: delayed message, ignoring \n",2);
		return;
	}

#	# The server will hold older messages. We need to ignore these.
#	# Giving a 10 second window for past.
#	my $msgtime = str2time( $msg->GetTimeStamp );
#	$self->Verbose("recvmsgGroupchat: ts (".$msg->GetTimeStamp.") msgtime (".$msgtime.") time(".time().")  ");
#	if ( $msgtime < time - 10 )
#	{
#		$self->Verbose("recvmsgGroupchat: ignoring past messages \n");
#		return;
#	}

	my $control = $self->GetControlForNode( $msg );
	return unless $control;

	my $input = $msg->GetBody;
	$self->Verbose("recvmsgGroupchat: got input($input)\n",4);

	# currently, this is what we're joining the chatroom as.
	my $me = $jid[$$self]->GetUserID;

	# Figure out if we're addressed in this input depends on mode.
	my $doit = 0;
	if ( $group_mode[$$self] eq 'log' )
	{
		$self->Verbose("recvmsgGroupchat:log ignoring ");
		return;
	}
	elsif ( $group_mode[$$self] eq 'all' )
	{
		$self->Verbose("recvmsgGroupchat:all input($input) ");
	}
	elsif ( $group_mode[$$self] =~ /named|prefixed/ )
	{
		if ( $input =~ /$me:/i  )
		{
			my ($ignore, $myinput) = split(/$me:/, $input, 2);
			#put input without our name into body.
			$msg->SetBody($myinput);
			$self->Verbose("recvmsgGroupchat:named input($input) ");
		}
		elsif ( $input =~ /$group_prefix[$$self]/i &&
			$group_mode[$$self] eq 'prefixed' )
		{
			my ($ignore, $myinput) = split(/$group_prefix[$$self]/, $input, 2);
			#put input without prefix into body.
			$msg->SetBody($myinput);
			$self->Verbose("recvmsgGroupchat:prefixed input($input) ");
		}
		else
		{
			$self->Verbose("recvmsgGroupchat:named-prefixed not for me ignoring");
			return;
		}
	}
	else
	{
		$self->Verbose("recvmsgGroupchat: mode error ignoring");
		return;
	}

#	if ( $input =~ /$me:/i )
#	{
#		$input =~ s/\s*($me):\s*//;
#		my $target = $1;
#		$self->Verbose("recvmsgGroupchat  input($input) target($target) ");
#		if ( $target ne $me )
#		{
#			$kernel->yield('send_message'
#				 =>  $msg
#				 =>  "I heard my name but saw no command. Use '$me: help' to get help."
#			);
#			return;
#		}
#		else
#		{
#			#put input without our name into body.
#			$msg->SetBody($input)
#		}
#	}
#	else
#	{
#		$self->Verbose("but it's to the group and not for $me \n");
#		return;
#	}

lib/Agent/TCLI/Transport/XMPP.pm  view on Meta::CPAN 

	# Using user with resource for normal and chat. Not even sure about headline or error.
	if ( $type eq 'normal' || $type eq '' )
	{
  		$control_id = $user->GetJID('full').'-'.$type;
	}
	elsif ( $type eq 'chat' )
	{
  		$control_id = $user->GetJID('full').'-'.$node->GetThread;
	}
	elsif ( $type eq 'groupchat' )
	{
		# chatroom should not use the resource
  		$control_id = $user->GetJID('base').'-'.$type;
	}
	elsif ( $type eq 'headline' )
	{
  		$control_id = $user->GetJID('full').'-'.$type;
	}
	elsif ( $type eq 'error' )
	{
  		$control_id = $user->GetJID('full').'-'.$type;
	}
	# IQ, treat like a normal message
	elsif ( $type eq 'get' )
	{
  		$control_id = $user->GetJID('full').'-'.$type;
	}

	else
	{
  		$self->Verbose("GetControlForNode: BAD TYPE ignoring node");
  		return(undef);
	}

	my $control = $self->GetControl($control_id, $user->GetJID('base'), $user_protocol);

	# If not auth, no control,
	unless ($control)
	{
		$self->Verbose("GetControlForNode: No Control!!!!");
		return (0);
	};

    $self->Verbose( "GetControlForNode: Control ".$control_id." on input from ".$user." \n",2);

	# These are not part of the default control attributes set by GetControl.
	# TODO don't reset every time.
	$control->set_jid($user);
	$control->type($type);

  return ( $control );

} # End GetControlForNode

=item Peers

This POE event handler performs the transport end of the peer manipulation
commands, such as add peer. It takes an action, a User object and an optional
Request object as arguments.

Valid actions are add and delete. Currently delete does not force a log
off from a chatroom, but it might if I fix that and forget to update the docs.

=cut

sub Peers {
	my ($kernel,  $self, $action, $user, $request) =
	  @_[KERNEL, OBJECT,  ARG0,   ARG1, 	ARG2];

	# either we're given a user or just the id
	my $id = ref($user) =~ /User/i ? $user->id : $user;

    $self->Verbose("Peers: $action ".$id );

	my $txt = '';
	my $code;

	# lets see how it goes....
	if ($action eq 'add' && ref($user) =~ /User/i )
	{
		eval { 	$self->push_peers($user); };

		if( $@ )
		{
			$self->Verbose("Peers: self->push_peers(".$user->id.") got (".$@.') ');
			$txt = "Invalid user ".$user->id." : $@ !";
			$code = 400;
		}
		else
		{
			$txt = $action." ".$user->id." successful. ";
			$code = 200;
			$kernel->yield('JoinPeerRooms');
		}
	}
	elsif ($action eq 'delete')
	{
		my $i = 0;
		# loop over the users and remove the matching one.

		PEER: foreach my $peer ( @{$self->peers} )
		{
			if ( $peer->id eq $id  )
			{
				splice( @{$self->peers},$i,1);

				# TODO we need a separate remove control command
				if ( defined( $self->controls ) &&
					exists( $self->controls->{ $id.'-groupchat' } ) )
				{
					delete( $self->controls->{ $id.'-groupchat' } );
				}
				$txt = $action." ".$user->id." successful. ";
				$code = 200;
				last PEER;
			}
			$i++;
		}
	}

	if( $txt eq '' )  # we didn't do anything



( run in 0.566 second using v1.01-cache-2.11-cpan-39bf76dae61 )