#!/usr/bin/perl
#
#
# Connect to old and new jabber servers and try to migrate roster.
# Note that we don't use ssl; Net::Jabber's ssl mode has some
# strange blocking bugs.  Jabber doesn't expose the password even
# without ssl.
#
# I'm clearly doing *something* wrong, since the jabber servers
# tend to disconnect me after only a few seconds of idle time,
# but it's working reasonably well to just run every once
# in a while.
#
# $Fenner: jmigrate/jmigrate,v 1.1 2004/11/01 18:51:51 fenner Exp $
#
use Net::Jabber qw( Client );

use Data::Dumper;

$name = 'jmigrate';
$version = '$Fenner: jmigrate/jmigrate,v 1.1 2004/11/01 18:51:51 fenner Exp $';

$oldhost = 'psg.com';
$olduser = 'fenner';
$oldpass = 'password';
$newhost = 'jabber.psg.com';
$newuser = 'fenner';
$newpass = 'password';
$movemsg = "I am moving my jabber account from $oldhost to $newhost.";

$debuglevel = 0;

print "Connecting to $oldhost...\n";
$old = new Net::Jabber::Client(debuglevel => $debuglevel);
$old->Info(name => $name, version => $version);
if ($old->Connect(hostname => $oldhost) == 0) {
	$err = $old->GetErrorCode();
	die "Can't connect to $oldhost: " . $err->{"text"} . "\n";
}
@oldr = $old->AuthSend(username => $olduser, password => $oldpass, resource => $name);
if ($oldr[0] ne 'ok') {
	die "Can't log into $oldhost:\n" . join("\n", @oldr), "\n";
}

print "Connecting to $newhost...\n";
$new = new Net::Jabber::Client(debuglevel => $debuglevel);
$new->Info(name => $name, version => $version);
if ($new->Connect(hostname => $newhost) == 0) {
	$err = $new->GetErrorCode();
	die "Can't connect to $newhost: " . $err->{"text"} . "\n";
}
@newr = $new->AuthSend(username => $newuser, password => $newpass, resource => $name);
if ($newr[0] ne 'ok') {
	die "Can't log into $newhost:\n" . join("\n", @newr), "\n";
}

$old->PresenceSend(type => 'unavailable', show => 'I am a robot');
$new->PresenceSend(type => 'unavailable', show => 'I am a robot');

print "Getting roster from $oldhost...\n";
%oldroster = $old->RosterGet();
print "Getting roster from $newhost...\n";
%newroster = $new->RosterGet();

# set a callback for normal + chat to reply "Sorry"
$old->SetMessageCallBacks(normal => \&reply, chat => \&reply);
$new->SetMessageCallBacks(normal => \&reply, chat => \&reply);

# set a callback for subscribed on the new id so that
# we can unsubscribe & delete from old roster.
$new->SetPresenceCallBacks(subscribed => \&subscribed);

# for each person in oldroster
# if it's foo@oldhost first try foo@newhost else fallback to foo@oldhost
# if not in newroster, invite to newroster (with message?)
# set a callback for the bidirectional presence notification
# when presence is bidirectional, delete from oldroster

foreach $oldjid (keys %oldroster) {
	if ($oldjid =~ /\@${oldhost}$/) {
		$oldjid2 = $oldjid;
		$oldjid2 =~ s/\@${oldhost}$/\@${newhost}/;
	} else {
		$oldjid2 = "";
	}
	#if ($newroster{$oldjid} || $newroster{$oldjid2}) {
	if (($newroster{$oldjid} && $newroster{$oldjid}->{'subscription'} eq 'both') ||
	    ($newroster{$oldjid2} && $newroster{$oldjid2}->{'subscription'} eq 'both')) {
		print "$oldjid is subscribed in the new roster -> deauth and remove from old.\n";
		$old->PresenceSend(to => $oldjid, type => 'unsubscribe', show => $movemsg);
		$oldr = $oldroster{$oldjid};
		$oldr->{'JID'} = $oldjid;
		$old->RosterRemove(%{$oldr});
		next;
	} elsif ($newroster{$oldjid}) {
		print "$oldjid is in the new roster but subscription is $newroster{$oldjid}->{'subscription'}\n";
	} elsif ($newroster{$oldjid2}) {
		print "$oldjid2 is in the new roster but subscription is $newroster{$oldjid2}->{'subscription'}\n";
	}
	#if ($oldjid2) {
	#	print "want to invite $oldjid2 if it exists.\n";
	#}
	print "inviting ${oldjid}:\n";
	$new->PresenceSend(to => $oldjid, type => 'subscribe', show => $movemsg);
	$newr = $oldroster{$oldjid};
	$newr->{'JID'} = $oldjid;
	delete $newr->{'subscription'};
	$new->RosterAdd(%{$newr});
}

while (1) {
	print "Processing...\n";
	if ($new->Process(5) == undef) {
	    $err = $new->GetErrorCode();
	    die "Connection to $newhost closed.\n";
	}
	if ($old->Process(5) == undef) {
	    $err = $old->GetErrorCode();
	    die "Connection to $oldhost closed.\n";
	}
}

#
# presence callback:
# - Remove from old roster
# - reply with subscribed
sub subscribed {
	my $self = shift;
	my $sid = shift;
	my $presence = shift;

	my $oldrep = $presence->Reply(type=>"unsubscribe", show=>$movemsg);
	$old->Send($oldrep, 1);
	$old->RosterRemove(JID => $presence->GetFrom());
	my $reply = $presence->Reply(type=>"subscribed");
	$self->Send($reply, 1);
}

#
# Reply to chats or messages.
sub reply {
	my $self = shift;
	my $sid = shift;
	my $msg = shift;
	my($from) = $msg->GetFrom();

	print "Want to reply to a message from $from\n";
	#
	# Only reply once every 10 minutes.
	if ($lastrep{$from} > time - 600) {
		return;
	}
	$lastrep{$from} = time;

	my($reply) = $msg->Reply;
	$reply->SetBody("I'm sorry, I'm a robot trying to migrate contacts.  If there's no less-idle instance, maybe this user isn't online.");
	$self->Send($reply);
	print Dumper($self, $sid, $reply);
}