# $Id: XMPP.pm 41 2007-04-01 02:01:08Z hacker $
package Agent::TCLI::Transport::XMPP;

=pod

=head1 NAME

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

=head1 SYNOPSIS

todo

=head1 DESCRIPTION

=over

=back

=head1 GETTING STARTED

=head2 DEFINING COMMANDS

=over 4

=item * args

=back

=head2 LAUNCHING THE CONTROL

=over 4

=item * commands

=item * hostname

=item * appname

=back

=head2 SHUTTING DOWN

=cut

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

use POE;
use Net::Jabber;
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 () { 2 }

our $VERSION = '0.'.sprintf "%04d", (qw($Id: XMPP.pm 41 2007-04-01 02:01:08Z hacker $))[2];

=head2 ATTRIBUTES

The following attributes are accessible through standard get_ or set_
methods and may be set as a parameter to new unless otherwise noted.

=head3 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' );

=head3 jserver

B<jserver> will only accept SCALAR type values.

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

=head3 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');

=head3 xmpp_debug

Sets the debug (verbosity) level for the XMPP libraries

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

=head3 xmpp_process_time

Sets the time in seconds to wait before calling XMPP Process to look for
more XMPP data. Should be near 1.

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

=head3 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');

=head3 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' );

=head3 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' );

=head3 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');

=head3 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');

=head3 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');

=head3 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

        	    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 spawn :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 },
#	});


}

=head2 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];

	$self->Verbose("_start: Starting up");

	# are we up before OIO has finished initializing object?
	if (!defined( $self->alias ))
	{
		$kernel->delay('_start', 1 );
		return;
	}

	# 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

=head2 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");
}

=head2 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);

	# 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

=head2 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);
	}

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

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

	$kernel->yield('JoinPeerRooms');

} #end sub Online

=head2 Process (    )

=head3 Description

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->not_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->not_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",1,$msg);
	$self->Verbose("recv_iqRequest: GetRequest",1,\$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');

#	# Put message into request for easy response.
#	$request->set_recv($msg);

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

	$self->Verbose("recv_iqRequest: sending to contol(".$control->id().") \n",2);
	$self->Verbose("recv_iqRequest: control dump.... \n".$control->dump(1), 5 );

	$kernel->post( $control->id() => 'Execute' => $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);

#	my $request = $response->request;

	# 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->post( $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. For now, everybody should be tcli.
	$msg->SetIQ (
		'to'	=> $addressee.'/tcli',
		'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", 2);

	$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", 2);

	$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

=head3 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

=head3 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

=head2 not_authorized ( { parameters (see usage) } )

Checks to see if a id is authorized to use us. Returns 1 if user is
authorized, 0 if id is not a match, and -1 if id a match,
but auth does not match.

=head3 Description

description

=head3 Usage

$self->not_authorized ( <Net:XMPP:JID>,  qr(master|writer),   # option regex for auth
				} );

=cut

#sub not_authorized {
#  my ($self, $id, $auth, $protocol) = @_;
#  $auth = defined($auth) ? $auth : qr(.*);
#  $protocol = defined($protocol) ? $protocol : qr(.*);
#  $self->Verbose("not_authorized: id(".$id->GetJID('full').") auth($auth) protocol($protocol)",2);
#
#  # Self with resource is always authorized for anything currently
#  # This should be OK if server is trustworthy.
#
#  return ( 1 ) if ( $id->GetJID('full') eq $self->jid->GetJID('full') );
#
#  # 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.
#  # send only the base with no resource.
#
#  foreach my $pid ( @{$peers[$$self]} ) {
#
#	$self->Verbose("not_authorized: Checking peer ".$pid->id,3);
#
#  	if ( $pid->not_authorized ( {
#  		id	   		=>  $id->GetJID('base'),
#		protocol 	=>  $protocol,
#		auth		=>  $auth,
#		} ) ) {
#		# Set authorized to last matched user
#		$authorized = $pid;
#	}
#  } #end foreach peer
#
#  $self->Verbose("not_authorized:  ".$id->GetJID('full')." auth check got ".$authorized->id()." \n",1);
#
#  return ($authorized)
#} # End not_authorized

=head2 GetControlForNode (  node  )

Determines the control from a node and returns the control object.

=head3 Description

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.

=head3  Usage

$self->GetControlForNode($node)

=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 );

#Moved auth to getcontrol
#	# send only the base with no resource for auth
#	my $auth_user = $self->not_authorized (
#	  	$user->GetJID('base'),
#	  	qr(.*),
#	  	$user_protocol,
#	  	);
#
#	return if ( $auth_user->id eq 'no one' );

	$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,
	return (0) unless $control;

    $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

=head2 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;
	}
}

1;

#__END__

=pod


=head1 REQUIREMENTS

The following perl modules are required for this module to work properly.

=over 4

=item * Carp

=item * File::Basename

=item * POE

=item * Params::Validate

=item * Sys::Hostname

=back

=head1 BUGS

New commands could clobber old ones under certain circumstances.

=head1 AUTHOR

Eric Hacker    hacker can be emailed at cpan.org

=head1 REVISION

$LastChangedRevision: 63 $

=head1 DATE

$Date: 2004-05-09 22:59:17 -0400 (Sun, 09 May 2004) $

=head1 LICENSE

Copyright (c) 2006, Lucent Technologies

Lucent License here...

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=cut

