# $Id: XMPP.pm 62 2007-05-03 15:55:17Z hacker $
package Agent::TCLI::Transport::XMPP;
=pod
=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
Online
Peers
Process
Set
Show
recvmsg
recvmsgError
recvmsgGroupchat
recvmsgHeadline
recv_pres
recv_iqRequest
recv_iqResponse
send_message
send_presence
PostRequest
PostResponse
SendChangeContext
TransmitRequest
TransmitResponse
)],
],
);
}
sub _init :Init {
my ($self, $args) = @_;
# Validate deep arguments
# $self->Verbose("Validating arguments \n" ,1);
# my %jabber_connection = validate ($args->{'jabber_connection'}, {
# jabber_package => { regex => qr/^POE::Component::Jabber/,
# type => Params::Validate::SCALAR | Params::Validate::SCALARREF },
# server => { type => Params::Validate::SCALAR | Params::Validate::SCALARREF },
# port => { optional => 1, default => 5222,
# callbacks =>
# { 'is a number' => sub { Scalar::Utils->looks_like_a_number($_[0]) }
# }},
# password => { type => Params::Validate::SCALAR | Params::Validate::SCALARREF },
# });
}
=back
=head2 METHODS
=over
=item start
Get things rolling. Starts up a POE::Component::Jabber::Client using the user
provided config info.
=cut
sub _start {
my ($kernel, $self, $session) =
@_[KERNEL, OBJECT, SESSION];
# are we up before OIO has finished initializing object?
if (!defined( $self->alias ))
{
$kernel->yield('_start');
return;
}
$self->Verbose("_start: ".$self->alias." Starting up");
# OK, now we can start up POE stuff.
$kernel->alias_set($self->alias);
my $xmpp = Net::Jabber::Client->new(
'debuglevel' => $xmpp_debug[$$self],
'debugfile' => 'stdout',
);
# Add a namespace for IQ nodes to embed YAML output
$xmpp->AddNamespace(
ns => "tcli:request",
tag => "tcli",
xpath => {
'Version' => { 'path' => 'version/text()' },
'Yaml' => { 'path' => 'yaml/text()' },
'Request' => { 'type' => 'master'},
}
);
# $self->Verbose("_start: Setting General XMPP Callbacks" , 2 );
# $xmpp->SetCallBacks(
# 'send' => $session->postback('VerboseCallBack'),
# 'receive' => $session->postback('VerboseCallBack'),
# 'presence' => $session->postback('recv_presence'),
# 'iq' => $session->postback('recv_iq'),
# );
$self->Verbose("_start: Setting XMPP Message Callbacks" , 2 );
$xmpp->SetMessageCallBacks(
'normal' => $session->postback('recvmsg'),
'chat' => $session->postback('recvmsg'),
'groupchat' => $session->postback('recvmsgGroupchat'),
'headline' => $session->postback('recvmsgHeadline'),
'error' => $session->postback('recvmsgError'),
);
# $xmpp->SetPresenceCallBacks(
# available => $session->postback('recv_pres'),
# unavailable => $session->postback('recv_pres'),
# );
$xmpp->SetIQCallBacks(
'tcli:request' => {
'get' => $session->postback('recv_iqRequest'),
# 'set' => function,
'result'=> $session->postback('recv_iqResponse'),
},
);
$self->set(\@xmpp, $xmpp);
$kernel->yield('Login') if (defined( $self->jpassword ));
return ($self->alias."_start whohoo");
} # End sub start
=item stop
Mostly just a placeholder.
=cut
sub _stop {
my ($kernel, $self, $session) =
@_[KERNEL, OBJECT, SESSION];
$self->Verbose("\n ".$self->alias." stopping \n\n" ,1);
return ($self->alias."_stop whohoo");
}
=item shutdown
Forcibly shutdown
=cut
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');
# This is to keep from reconnectiing when XMPP responds that it is disconnected.
$self->connection_retries(0);
if ( defined($self->control_options)
&& exists( $self->control_options->{'packages'} ))
{
# Shut down any packages.
foreach my $package ( @{$self->control_options->{'packages'} })
{
$kernel->post( $package->name => '_shutdown' );
}
}
if ( $xmpp[$$self]->Connected )
{
$xmpp[$$self]->Disconnect;
$self->Verbose("_shutdown: Disconnecting ");
}
# define xmpp
# what about Disconnected????
$self->xmpp->SetMessageCallBacks(
'normal' => undef,
'chat' => undef,
'groupchat' => undef,
'headline' => undef,
'error' => undef,
);
$self->xmpp->SetPresenceCallBacks(
available => undef,
unavailable => undef,
);
$self->xmpp->SetIQCallBacks(
'tcli:request' => {
'get' => undef,
'set' => undef,
'result'=> undef,
},
);
# $_[KERNEL]->alias_remove( $_[OBJECT]->get_alias );
}
sub Disconnected {
my ($kernel, $self, $count ) =
@_[KERNEL, OBJECT, ARG0 ];
# 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...
sub recv_pres {
my ($kernel, $self, $jSessionID, $response) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
my $msg = $response->[1];
$self->Verbose( "\tRP\tGot no response \n") if ( !defined ($response) );
# my $thread = $self->get_thread($msg);
# $self->Verbose( "\tRP\tThread: ".$thread->id()." \n") if ( defined ($thread));
# If we get our own presence, ignore it.
my $from = $msg->GetFrom('jid');
return if ( $from eq $self->jid->GetUserID );
# TODO more presence handling
# need to put presence into thread participant state? Maybe but we
# don't get the thread with the presence.
# how would we find group participants in a groupchat?
# do we need have presence of groupchat participants for anything
return ();
}
sub GetRequestForNode {
my ($self, $node ) = @_;
# This is used to package up a simple request easily
my $input = $node->GetBody;
$self->Verbose("GetRequestForNode: input($input)\n",2);
my $request = Agent::TCLI::Request->new({
'sender' => $self->alias,
'postback' => 'PostResponse',
'input' => $input,
'response_verbose' => 1,
'verbose' => $self->verbose,
'do_verbose' => $self->do_verbose,
});
$request->set_recv($node);
return( $request );
}
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;
# }
my $request = $self->GetRequestForNode($msg);
$self->Verbose("recvmsgGroupChat: sending to contol \n",2);
$kernel->post( $control->id() => 'Execute' => $request );
}
sub recvmsgHeadline {
my ($kernel, $self, $jSessionID, $response) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
my $msg = $response->[1];
return unless $self->authorized(
$msg->GetFrom('jid'),
);
my $input = $msg->GetBody;
$self->Verbose("recvmsgHeadline: got headline ($input) \n");
warn ("recvmsgHeadline: got headline ($input) \n");
return
}
sub recvmsgError {
my ($kernel, $self, $jSessionID, $packet) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
my $msg = $packet->[1];
$self->Verbose("recvmsgError jSessionID",1);
$self->Verbose("recvmsgError packet");
return unless $self->authorized
(
$msg->GetFrom('jid'),
);
my $input = $msg->GetBody;
$self->Verbose("recvmsgError got input($input)\n",3);
# warn ("recvmsgError got command '$input'\n");
return
}
sub recv_iqRequest {
my ($kernel, $self, $jSessionID, $packet) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
my $msg = $packet->[1];
$self->Verbose("recv_iqRequest: got message from ".
$msg->GetFrom('jid')->GetJID('full')." ");
# Since we're here. this is a get IQ, and thus the 'request'
# better be a "tcli:request"
# TODO Assuming version is 1.0 for now.
# my $query = $msg->GetQuery;
my $packed_request = $msg->GetQuery->GetYaml;
# $self->Verbose("recv_iqRequest: msg",4,$msg);
# $self->Verbose("recv_iqRequest: GetRequest",3,$msg->GetQuery->GetRequest);
# Unpack the request..
my $request = $self->UnpackRequest($packed_request);
# Need to put us on the bottom of the stack so we can return response
$request->unshift_sender($self->alias);
$request->unshift_postback('PostResponse');
my $control = $self->GetControlForNode( $msg );
return unless $control;
$self->Verbose("recv_iqRequest: sending to contol(".$control->id().") \n",1);
$self->Verbose("recv_iqRequest: control dump.... \n".$control->dump(1), 5 );
# 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 );
}
}
sub recv_iqResponse {
my ($kernel, $self, $jSessionID, $packet) =
@_[KERNEL, OBJECT, ARG0, ARG1 ];
my $msg = $packet->[1];
$self->Verbose("recv_iqResponse: got message from ".
$msg->GetFrom('jid')->GetJID('full')." ");
# Since we're here. this is a result IQ, and thus the 'request' is really
# a response and is a "tcli:request" result
# TODO Assuming version is 1.0 for now.
my $packed_response = $msg->GetQuery->GetYaml;
# $self->Verbose("recv_iqResponse: msg",1,$msg); #->GetRequest
# $self->Verbose("recv_iqResponse: XMLNS",1,$msg->GetQueryXMLNS);
# $self->Verbose("recv_iqResponse: GetQuery",1,$msg->GetQuery);
# $self->Verbose("recv_iqResponse: GetYaml",1,$msg->GetQuery->GetYaml);
# $self->Verbose("recv_iqResponse: GetRequest",1,\$msg->GetQuery->GetRequest);
# Unpack the response..
my $response = $self->UnpackResponse($packed_response);
# The bottom of the stack should be where to go.
my $sender = $response->shift_sender;
my $postback = $response->shift_postback;
$self->Verbose("recv_iqResponse: posting to ".
$sender." => ".$postback." => ".$response->id);
$kernel->call( $sender => $postback => $response );
}
sub PostRequest {
my ($kernel, $self, $sender, $request, ) =
@_[KERNEL, OBJECT, SENDER, ARG0, ];
$self->Verbose("PostRequest: sender(".$sender->ID.")
request(".$request->id.") \n");
my $addressee;
# First, check if we're on the bottom of the stack.
if ( $request->sender->[0] eq $self->alias )
{
#we're here, take us off
$request->shift_sender;
$request->shift_postback;
}
# elsif ( defined($request->sender->[0]) ) # implied != $self->alias
# {
# # TODO Genereate real error
# $self->Verbose("PostRequest: Whoops! Got something in sender0 that shouldn't be there \n ".$request->dump(1));
# return;
# }
if ( $request->sender->[0] eq 'XMPP' )
{
#take off XMPP and adressee.
$request->shift_sender;
$addressee = $request->shift_postback;
}
elsif ( defined($request->sender->[0]) ) # implied != 'XMPP'
{
# TODO Genereate real error
$self->Verbose("PostRequest: Whoops! Got something in sender0 that shouldn't be there \n ".$request->dump(1));
return;
}
# make sure sender put themselves on stack.
# need to resolve POE sender to alias to do this.
# if ( !defined($request->sender->[0]) || $request->sender->[0] ne $sender )
# {
# # Do them a favor and put them on.
# $request->unshift_sender( $sender );
# # but we'll have to assume they are at least compliant with response returns.
# $request->unshift_postback('PostResponse');
# $self->Verbose($self->alias.":PostRequest: putting ".$sender." on sender/postback stack");
# }
# Transmit will take care of putting self onto stack.
# Now Transmit it
$kernel->call($self->alias, 'TransmitRequest', $request, $addressee );
return;
}
sub PostResponse {
my ($kernel, $self, $sender, $response, $control) =
@_[KERNEL, OBJECT, SENDER, ARG0, ARG1];
$self->Verbose("PostResponse: sender(".$sender->ID.")
Code(".$response->code.") \n");
# my $request = $response->request;
# The response should come back with either message nodes attached
# or something in the sender/postback stack to provide
# directions on where to go. If there a XMPP in the sender/postback
# that means the request should get transmitted as a whole request (iq),
# and not as a message/body, so let Transmit handle that.
# First, check if we're on the bottom of the stack.
if ( defined($response->sender->[0]) && $response->sender->[0] eq $self->alias )
{
#we're here, but we don't take us off anymore, so there is not much to do.
}
elsif ( defined($response->sender->[0]) ) # implied != $self->alias
{
# TODO Genereate real error
$self->Verbose("PostResponse: Whoops! Got something in sender0 that shouldn't be there \n ".$response->dump(1));
return;
}
# Now if there's anything for XMPP on the stack, Transmit it
if ( defined($response->sender->[1]) && $response->sender->[1] eq 'XMPP' )
{
#we're here, take us off bottom
$response->shift_sender;
$response->shift_postback;
$kernel->yield('TransmitResponse', $response );
return;
}
elsif ( defined($response->sender->[1]) ) # implied != 'XMPP'
{
# TODO Genereate real error
$self->Verbose("PostResponse: Whoops! Got something in sender1 that shouldn't be there \n ".$response->dump(1));
return;
}
my $msg = $response->get_send();
# If the send message has not been set up, then do it.
if ( ref($msg) ne 'Net::XMPP::Message')
{
$self->Verbose("PostResponse: Creating new Send XMPP::Message", 2);
# If we've got a recieved message, use it
if ( ref( $response->get_recv ) =~ /Message/)
{
if ( $response->get_recv->GetType eq 'groupchat' )
{
$msg = $response->get_recv()->Reply();
$self->Verbose("PostResponse: Reply dump ", 5, $msg);
$msg->SetTo( $response->get_recv->GetFrom('jid')->GetJID('base') );
$self->Verbose("PostResponse: Getfrom base ".$response->get_recv->GetFrom('jid')->GetJID('base'), 2 );
$msg->SetFrom( $jid[$$self] );
}
else
{
$msg = $response->get_recv()->Reply();
}
}
elsif ( defined($control) )
{
$msg = Net::XMPP::Message->new();
$msg->SetTo( $control->get_jid() );
$msg->SetFrom ( $jid[$$self] );
}
else
{
$self->Verbose("PostResponse: Can't post, nowhere to go");
return;
}
}
$msg->SetBody( $response->body );
$self->Verbose("PostResponse: Sending to xmpp", 2);
$self->Verbose("PostResponse: msg dump ", 5, $msg);
# Put $msg in request for next time.
$response->set_send($msg);
$self->xmpp->Send($msg);
}
sub TransmitRequest {
my ($kernel, $self, $sender, $request, $addressee ) =
@_[KERNEL, OBJECT, SENDER, ARG0, ARG1 ];
$self->Verbose($self->alias.":TransmitRequest: id(".
$request->id.") \n");
# Put us on bottom so we get the response back
$request->unshift_sender('XMPP');
$request->unshift_postback($self->jid->GetJID('full') );
# Prepare the request..
my $packed_request = $self->PackRequest($request);
# Create new msg
my $msg = Net::XMPP::IQ->new();
# addressee must have resource, default to /tcli if not provided
$addressee .= '/tcli' unless ($addressee =~ qr(/) );
$msg->SetIQ (
'to' => $addressee,
'from' => $self->jid,
'type' => 'get',
);
my $msgRequest = $msg->NewChild("tcli:request");
$msgRequest->SetRequest(
'Version' => '1.0',
'Yaml' => $packed_request,
);
$self->Verbose($self->alias.":TransmitRequest: Sending to xmpp for $addressee", 1);
$self->xmpp->Send($msg);
}
sub TransmitResponse {
my ($kernel, $self, $sender, $response, ) =
@_[KERNEL, OBJECT, SENDER, ARG0, ];
$self->Verbose("TransmitResponse: Code(".$response->code.") id(".
$response->id.") \n");
# my $request = $response->request;
my $addressee;
# First, check if we're on the bottom of the stack.
if ( $response->sender->[0] eq 'XMPP' )
{
#we're here, take us off
$response->shift_sender;
$addressee = $response->shift_postback;
}
elsif ( defined($response->sender->[0]) ) # implied != 'XMPP'
{
# TODO Genereate real error
$self->Verbose("TransmitResponse: Whoops! Got something in sender that shouldn't be there ".$response->dump(1));
return;
}
else
{
# TODO Genereate real error
$self->Verbose("TransmitResponse: Got nowhere to go. ");
return;
}
# Prepare the response..
my $packed_response = $self->PackResponse($response);
# Create new msg
my $msg = Net::XMPP::IQ->new();
# addressee must have resource. For now, everybody should be tcli.
$msg->SetIQ (
'to' => $addressee,
'from' => $self->jid,
'type' => 'result',
);
my $msgRequest = $msg->NewChild("tcli:request");
$msgRequest->SetRequest(
'Version' => '1.0',
'Yaml' => $packed_response,
);
$self->Verbose("TransmitResponse: Sending to xmpp for $addressee", 1);
$self->xmpp->Send($msg);
}
sub SendChangeContext {
my ($kernel, $self, $control ) =
@_[KERNEL, OBJECT, ARG0 ];
# for xmpp, we announce context with presence.
# for a terminal, it might be a prompt...
$self->Verbose("SendChangeContext: for control ".$control->id());
# Todo, what happens with a groupchat?
my $presence = Net::XMPP::Presence->new(
'to' => $control->get_jid(),
'status' => 'Available',
'priority' => '1',
'type' => $control->print_context,
);
$self->Verbose("SendChangeContext: presence dump",4,$presence);
$xmpp[$$self]->PresenceSend($presence);
}
sub recv_exit {
my ($kernel, $self, ) =
@_[KERNEL, OBJECT, ];
$self->Verbose("recv_exit: got XMPP exit \n" );
$kernel->delay_set('Disconnected',30, 1 );
} #end sub recv_exit
=item send_presence
Sends a xmpp presence message. See Net::XMPP::Presence for parameter details.
=begin code
$kernel->yield('send_presence' => {
'type' => 'available', # optional, defaults
'to' => xmpp_id, # optional, no default
'status' => 'Online', # optional, defaults
'priority' => '8', # optional, defaults
});
=end code
=cut
sub send_presence {
my ($kernel, $self, $args) =
@_[KERNEL, OBJECT, ARG0];
my $xmpp = $xmpp[$$self];
# get params or use defaults
my $status = defined($args->{'status'}) ? $args->{'status'} : 'Online';
my $priority = defined($args->{'priority'}) ? $args->{'priority'} : '8';
my $to = defined($args->{'to'}) ? $args->{'to'} : undef;
my $type = defined($args->{'type'}) ? $args->{'type'} : 'available';
$self->Verbose( "send_presence: type($type) status($status) priority($priority) \n");
# SetPresence(to=>string|JID
# from=>string|JID,
# type=>string,
# status=>string,
# priority=>integer,
# meta=>string,
# icon=>string,
# show=>string,
# loc=>string)
$xmpp[$$self]->PresenceSend(
'to' => $to,
'status' => $status,
'priority' => $priority,
'type' => $type,
);
return;
} # end end_pres
=item send_message
Sends a xmpp message for a control. Takes the thread and the messaage as parameters. It will overwrite the control->send attribute text with the message parameter.
=begin code
$kernel->yield('send_message' => $control => $message )
=end code
=cut
sub send_message {
my ($kernel, $self, $msg, $message) =
@_[KERNEL, OBJECT, ARG0, ARG1];
return unless (my $xmpp = $self->xmpp);
$self->Verbose("send_message: node(".$msg->GetFrom.") Message(".$message.") \n");
my $rmsg;
# If the send message has not been set up, then do it.
if ( ref($msg) eq 'Net::XMPP::Message')
{
$self->Verbose("send_message: Creating new reply XMPP::Message", 2);
# If we've got a recieved message, use it
$rmsg = $msg->Reply();
if ( $msg->GetType eq 'groupchat' )
{
$self->Verbose("send_response: Reply dump ", 2, $rmsg);
$rmsg->SetTo( $msg->GetFrom('jid')->GetJID('base') );
$rmsg->SetFrom( $jid[$$self] );
$self->Verbose("send_response: Reply post dump ", 2, $rmsg);
}
}
$msg->SetBody( $message );
$self->Verbose("send_message: Sending to xmpp", 2);
# $control->send($rmsg);
$self->xmpp->Send($rmsg);
} # end sub xmpp_send_msg
=item GetControlForNode ( node )
Determines the control from a node and returns the control object.
Takes a node parameter and returns the hash key to the proper control
object in the controls array. If the control object is not in the array,
it will add it.
When a new control object is created, a new Control session must be started
for the control and that is handled here as well.
=cut
sub GetControlForNode {
my ($self, $node) = @_;
$self->Verbose("GetControlForNode: node(".ref($node).") \n");
my $type = $node->GetType;
my $user = $node->GetFrom('jid');
# chats to other groupchat users come from group/nick and not from user.
# don't want peer chats from group.....
my $user_protocol = $type eq 'groupchat' ? qr(xmpp_groupchat) : qr(xmpp);
# Don't talk to oneself.......
return if ( $user->GetJID('full') eq $self->jid->GetJID('full') );
# or to self in chatroom
return if ( $user->GetResource eq $self->jid->GetUserID );
$self->Verbose("GetControlForNode: type(".$type.") user(".$user->GetJID('full').") \n");
my $control_id;
# Message Types
# 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
{
$txt = $action." on ".$id." failed. ";
$code = 400;
}
$self->Verbose('Peers: txt('.$txt.') code('.$code." )",2);
if ($request)
{
$request->Respond($kernel, $txt, $code);
return;
}
}
sub Address {
my $self = shift;
my $sock = $self->xmpp->{STREAM}->GetSock( $self->xmpp->GetStreamID );
my ($port, $naddr) = sockaddr_in(getsockname($sock));
my $addr = inet_ntoa($naddr);
$self->Verbose("Address: $addr");
return ($addr);
}
1;
#__END__
=back
=head1 AUTHOR
Eric Hacker hacker can be emailed at cpan.org
=head1 BUGS
SHOULDS and MUSTS are currently not enforced.
New commands could clobber old ones under certain circumstances.
Test scripts not thorough enough.
Probably many others.
=head1 LICENSE
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.
=cut