#!/usr/bin/perl -w

# poor man's ICQ group chat implementation
#
# Dobrica Pavlinusic <dpavlin@rot13.org> 2005-03-14
# released under GPL v2 or perl artistic licence

use strict;
use Net::OSCAR qw(:standard);
use YAML qw(LoadFile DumpFile Dump);
use Text::Iconv;

# local encoding
my $encoding = 'ISO-8859-2';

my $motd = <<_MOTD_;
Welcome to group ICQ chat.
Change your name with: !nick [your_name]
For help type: !help
_MOTD_

my $help = <<_HELP_;
Confused?
Change your name with !nick [nickname]
Exit group chat !leave or !exit
List group members !members or !list
Invite new member with !invite [uin] [name]
Turn echo to sender with !echo
See last messages with !last
_HELP_

my $config_file = shift @ARGV || $ENV{'HOME'}.'/.icq-chat';

# name of buddy group
my $buddy_group = 'chat';
my $echo = 0;
# default DSN for log
my $dsn = 'dbi:Pg:dbname=test';

my $my_uin;
my $config;
my $oscar;
my $signon_done = 0;

my $iconv_utf8 = Text::Iconv->new("UTF-8", $encoding);
my $iconv_utf16 = Text::Iconv->new("UTF-16BE", $encoding);

$|=1;

sub readln {
	my $msg = shift || return;
	print "$msg ";
	my $in = <STDIN>;
	chomp($in);
	return $in;
}

sub read_config {
	if (-e $config_file) {
		$config = LoadFile($config_file) || die "can't open $config_file: $!";
		$config->{'uin'} ||= readln("group uin:");
		$config->{'passwd'} ||= readln($config->{'uin'}." password:");
		die "configuration file $config_file is corrupt. Erase it to recover.\n" unless ($config->{'uin'} && $config->{'passwd'});
	} else {
		$config->{'uin'} = readln("group uin:");
		$config->{'passwd'} = readln("password:");
		$config->{'members'} = {};
		$config->{'motd'} = $motd;
	}
	$config->{'dsn'} ||= readln("log dns [$dsn]:");
	$config->{'dsn'} ||= $dsn;

	save_config();
	$my_uin = $config->{'uin'};
}

sub save_config {
	DumpFile($config_file, $config) || die "can't open $config_file: $!";
	xlog('config', $my_uin, "$config_file updated");
}

sub uin2name {
	my $uin = shift || return "uin2name: missing uin";
	return "bot" if ($uin eq $my_uin);
	return $config->{'members'}->{$uin} || "anonymous $uin";
}

sub im_in {
	my($oscar, $sender, $message, $is_away) = @_;

	$message =
		$iconv_utf16->convert($message) ||
		$iconv_utf8->convert($message) ||
		$message || return;

	if ($is_away) {
		xlog('away', $sender, $message);
		return;
	} else {
		xlog('im_in', $sender, $message);
	}

	# strip html from message
	$message =~ s#</*(?:html|body|font|b|p)[^>]*?/*>##gsi;

	$config->{'last_sender_t'}->{$sender} = time();
	$config->{'last_t'} = time();

	if ($message =~ m#^!ping\s*(.*)$#) {
		my $stamp = $1;

		$config->{'ping'}->{$sender}->{'rcv'}++;
		$config->{'ping'}->{$sender}->{'rcv_stamp'} = $stamp if ($stamp);
		$config->{'nack_cnt'} = 0;

		$stamp ||= '';
		$stamp .= " -> ".int(time());
		xsend_im($sender, "!pong $stamp") if ($sender ne $my_uin);
		xlog('ping', $sender, $stamp);
		return;
	}


	# make user online and count it's messages
	$config->{'online'}->{$sender}++;

	if ($sender ne $my_uin &&			# not me (bot)
		! $config->{'members'}->{$sender}	# not member
	) {
		$config->{'members'}->{$sender} = $sender;
		$config->{'online'}->{$sender}++;
	}

	# seen first time?
	if ($config->{'online'}->{$sender} == 1) {
		# send motd
		xsend_im($sender, $config->{'motd'}) if ($config->{'motd'});
		add_member($sender);
		xlog('add_member', $sender);
	}

	if ($message =~ m#^!nick\s+(.+)\s*$#) {
		$config->{'members'}->{$sender} = $1;
		xsend_im($sender, "Your name will be: $1");
		xlog('nick', $sender, $1);
		save_config();
		return;
	}
	
	if ($message =~ m#^!invite\s+(\S+)\s+(.+)*\s*$#) {
		my ($uin, $nick) = ($1, $2);
		xsend_im($uin, "Your are joined to chat by ".uin2name($sender).". You screen name is: $nick");
		xsend_im($sender, "You invited $nick [$uin] to join this chat.");
		add_member($uin, $nick);
		xlog('invite', $uin, $nick);
		return;
	}

	if ($message =~ m#^!(?:skip|kick|leave|exit)\s*(\S*)\s*$#) {
		my $uin = $1 || $sender;
		if ($config->{'members'}->{$uin}) {
			if ($uin == $sender) {
				xsend_im($sender, "You left group chat.");
				xlog('leave', $sender);
			} else {
				xsend_im($sender, "You kicked ".uin2name($uin)." out of this group.");
				xlog('leave', $uin, "kicked by $sender [".uin2name($sender)."]");
			}
			remove_member($uin);
		} else {
			xsend_im($sender, "UIN $uin is not member of group");
		}
		return;
	}

	if ($message =~ m#^!config#) {
		read_config();
		xsend_im($sender, "Configuration reloaded.");
		xlog('config', $sender, 'reloaded');
		return;
	}
	
	if ($message =~ m#^!(?:members*|list)#) {
		my $members = join(", ",
			map { uin2name($_) } keys %{ $config->{'online'} }
		);
		xsend_im($sender, "Group members: $members");
		xlog('members', $sender, $members);
		return;
	}

	if ($message =~ m#^!help#) {
		xsend_im($sender, $help);
		xlog('help', $sender);
		return;
	}

	if ($message =~ m#^!fortune#) {
		my $text = `fortune` || "Can't guess your fortune.";
		chomp($text);
		xsend_im($sender, $text);
		xlog('fortune', $sender, $text);
		return;
	}

	if ($message =~ m#^!debug#) {
		my $debug = Dump($config);
		$debug =~ s/^passwd:.*$/passwd removed/m;
		xsend_im($sender, $debug);
		xlog('debug', $sender, $debug);
		return;
	}

	if ($message =~ m#^!info\s+(\S+)\s*$#) {
		my $uin = $1;
		my $info = Dump($oscar->buddy($uin)) || "Can't get info for $uin [".uin2name($uin)."]";
		xsend_im($sender, $info);
		xlog('info', $sender, $info);
		return;
	}

	if ($message =~ m#^!on-*line\s*(\S*)\s*$#) {
		my $uin = $1;
		xlog('online', $sender, $uin);
		if ($uin && $config->{'members'}->{$uin}) {
			$config->{'online'}->{$uin}++;
			xsend_im($sender, "Changed status of $uin to on-line.");
		} elsif ($uin) {
			xsend_im($sender, "UIN $uin is not member. Try !invite $uin [name] first");
		} else {
			# check and list on-line members
			xsend_im($sender, "on-line members: ".
				join(", ", map { uin2name($_) } online_uins($oscar) ));
		}
		return;
	}

	if ($message =~ m#^!(?:broadcast|all)#) {
		foreach my $uin (keys %{$config->{'members'}}) {
			$config->{'online'}->{$uin} = 1 unless ($config->{'online'}->{$uin});
		}
		xsend_im($sender, "Your next message will be broadcasted to all members without regard to on-line flag.");
		xlog('broadcast', $sender);
	}

	if ($message =~ m#^!echo#) {
		my $own;
		my $echo = $config->{'echo'}->{$sender};
		if ($echo) {
			$own = "not sent back";
			delete($config->{'echo'}->{$sender});
		} else {
			$own = "sent back to sender";
			$config->{'echo'}->{$sender}++;
		}
		xsend_im($sender, "own messages are $own");
		xlog('echo', $sender, $echo);
		save_config();
		return;
	}

	if ($message =~ m#^!last\s*?(\d*)$#) {
		my $nr = $1;
		xsend_im($sender, "\n".xlast($nr));
		xlog('last', $sender);
		return;
	}

	if ($message =~ m#^!rmskip\s+(\S+)\s*$#) {
		my $uin = $1;
		my $who = uin2name($uin)." [$uin]";

		if ($config->{'skip_buddy'}->{$uin}) {
			delete $config->{'skip_buddy'}->{$uin};
			xsend_im($sender, "removed $who from skip list");
			xlog('rmskip', $sender, $uin);
		} else {
			xsend_im($sender, "can't remove $who from skip list, not a member");
		}
		return;
	}

	$message =~ s#&lt;br&gt;#\n#gis;

	if ($message =~ m#^!motd\s*?(.*)#s) {
		$config->{'motd'} = $1 || $motd;
		xsend_im($sender, "New MOTD is:\n".$config->{'motd'});
		save_config();
		xlog('motd', $sender);
		return;
	}

	xlog('msg', $sender, $message);

	if ($message =~ m#^(!.*)#) {
		xsend_im($sender, "Unknown command: $1");
		xlog("unkown", $sender, $1);
		return;
	}

	# prefix with name
	if ($sender ne $my_uin) {
		my $m = $message || return;
		$message = "[".uin2name($sender)."] $m";
	}

	foreach my $uin (keys %{$config->{'online'}}) {
		next if (! $config->{'echo'}->{$sender} && $uin eq $sender || $uin eq $my_uin);
		xsend_im($uin, $message);
	}
	print "\n";
}

sub xsend_all_except {
	my $sender = shift || return;
	my $message = shift || return;
	foreach my $uin (keys %{$config->{'online'}}) {
		# don't send to sender or bot
		next if ($uin eq $sender or $uin eq $my_uin);
		xsend_im($uin, $message);
	}
}

sub buddy_in {
	my ($oscar, $uin) = @_;
	warn "buddy in got empty uin\n" and return unless ($uin);
	return if ($uin eq $my_uin);
	$config->{'online'}->{$uin}++;
	xsend_all_except($uin, uin2name($uin)." joined chat.") if ($config->{'online'}->{$uin} == 1);
	xlog('buddy_in', $uin);
	save_config();
}

sub buddy_out {
	my ($oscar, $uin) = @_;
	return if ($uin eq $my_uin);	# me?
	delete($config->{'online'}->{$uin});
	xsend_all_except($uin, uin2name($uin)." left chat.");
	xlog('buddy_out', $uin);
	save_config();
}

my $buddylist_commit_active = 0;

sub remove_member($) {
	my $uin = shift || return;
	delete ($config->{'online'}->{$uin});
	$oscar->remove_buddy($buddy_group, $uin);
	$oscar->commit_buddylist() if ($buddylist_commit_active == 0);
	$buddylist_commit_active++;
	xlog('remove_member', $uin);
}

sub add_member($$) {
	my ($uin, $nick) = @_;
	return unless ($uin && $nick);
	$config->{'members'}->{$uin} = $nick;
	$oscar->add_buddy($buddy_group, $uin);
	$oscar->add_permit($uin);
	$oscar->commit_buddylist() if ($buddylist_commit_active == 0);
	$buddylist_commit_active++;
	xlog('add_member', $uin);
}

sub buddylist_ok {
	my $oscar = shift;
	print "Buddy list commited with $buddylist_commit_active changes commited.\n";
	$buddylist_commit_active = 0;
	save_config();
	xlog('buddylist_ok', $my_uin);
}

sub buddylist_error {
	my ($oscar, $error, $what) = @_;
	if ($error = 14 && $what =~ m/(\d+)/) {
		my $uin = $1;
		print "ERROR: $what [$error], adding $uin [",uin2name($uin),"] to skip buddy list\n";
		$config->{'skip_buddy'}->{$uin}++;
		remove_member($uin);
	} else {
		print "ERROR: Buddy list commit failed [$error]: $what\n";
	}
	xlog('buddylist_error', $my_uin, $what);
}

sub online_uins($) {
	my $oscar = shift || return;
	my @online;
	$config->{'online'} = {};
	foreach my $uin (keys %{$config->{'members'}}) {
		next if ($uin eq $my_uin);
		my $info = $oscar->buddy($uin);
		if ($info->{'online'}) {
			$config->{'online'}->{$uin}++;
			push @online, $uin;
		}
	}
	xlog('online_uins', $my_uin, join(", ", @online));
	save_config();
	return @online;
}

sub signon_done {
	my $oscar = shift;
	my @buddies = $oscar->buddies();
	print "adding buddies:\n";
	foreach my $uin (keys %{$config->{'members'}}) {
		my $status = 'old';
		unless (grep(/^$uin$/, @buddies)) {
			if ($config->{'skip_buddy'}->{$uin}) {
				$status = 'SKIPPED';
			} else {
				$oscar->add_buddy($buddy_group, $uin);
				$oscar->set_buddy_alias($buddy_group, $uin, uin2name($uin));
				$status = 'NEW';
			}
		}
		printf("%-10d : %s - %s buddy\n",
			$uin,
			uin2name($uin),
			$status,
		);
		xlog('signon_done', $uin, $status);
	}

	# fixup (just in case) -- remove own uin from members and buddies
	my $me = $my_uin;
	$oscar->remove_buddy($buddy_group, $config->{$me});
	delete($config->{'members'}->{$me});
	
	$oscar->commit_buddylist();

	print "on-line buddies:\n";
	$config->{'online'} = {};
	foreach my $uin (online_uins($oscar)) {
		printf("%-10d : %s online\n", $uin, uin2name($uin));
	}
	save_config();

	$signon_done++;
}

sub rate_alert {
	my ($oscar, $level, $clear, $window, $worrisome) = @_;

	my $msg = "$window messages max in $clear ms limit reached";

	xlog('rate_alter', $my_uin, $level . " " . $msg);

	print "# $msg - sleeping $clear ms\n";
	select(undef, undef, undef, ($clear/100));

#	if ($worrisome) {
#		xsend_im($my_uin, $msg);
#	}
}

sub error {
	my ($oscar, $connection, $error, $description, $fatal) = @_;

	xlog('error', $my_uin, $description);
	print "ERROR [$error]: $description\n";

	if ($fatal) {
		$signon_done = 0;
		print "# repeating sign-on\n";
		$oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
	}

}

## DSN logging support

my ($dbh,$sth_log, $sth_sent, $sth_sent_ok, $sth_last);

sub create_log_table {
	$dbh ||= connect_db();
	return unless ($dbh);

	# exit if table exists
	return if ($dbh->do("select * from log limit 1"));

	print "# creating log table in $dsn\n";
	$dbh->do(q{
		create table log (
			id serial,
			date timestamp default now(),
			bot text not null,
			type text not null,
			uin text not null,
			name text not null,
			message text,
			primary key(id)
		)
	}) || die $dbh->errstr();
	$dbh->do(qq{ create index log_date on log(date) }) or die $dbh->errstr();
	$dbh->do(qq{ create index log_bot on log(bot) }) or die $dbh->errstr();
	$dbh->do(qq{ create index log_type on log(type) }) or die $dbh->errstr();
	$dbh->do(qq{ create index log_uin on log(uin) }) or die $dbh->errstr();
	$dbh->do(qq{ create index log_name on log(name) }) or die $dbh->errstr();
	$dbh->do(qq{
		create table sent (
			date timestamp default now(),
			bot text not null,
			uin text not null,
			name text not null,
			r_id text not null,
			message text,
			sent boolean default false,
			primary key(r_id)
		)
	});
}

sub connect_db {
	return unless ($config->{'dsn'});
	return if ($dbh);

	require DBI;
	print "# using $dsn for log\n";
	$dbh = DBI->connect($config->{'dsn'},"","") || die $DBI::errstr;

	return $dbh;
}

sub xlog {
	my ($type,$uin, $message) = @_;

	my $name = uin2name($uin);

	print localtime()." $type: $uin [$name] ", ( $message || '' ),"\n";

	return unless ($dbh);

	$sth_log ||= $dbh->prepare(qq{
		insert into log (bot,type,uin,name,message) values (?,?,?,?,?)
	}) || die $dbh->errstr();

	$sth_log->execute($my_uin, $type, $uin, $name, $message) || print "$type: [$uin] $message";
}

sub xsend_im {
	my ($who, $message, $away) = @_;

	my $r_id = $oscar->send_im($who, $message, $away);
	print "# sent $who $r_id\n";

	return unless ($dbh);

	if (! $r_id) {
		xlog('error', $my_uin, "failed send_im to $who: $message");
		return;
	}

	$sth_sent ||= $dbh->prepare(qq{
		insert into sent (bot,uin,name,r_id,message) values (?,?,?,?,?)
	}) || die $dbh->errstr();
	$sth_sent->execute($my_uin, $who, uin2name($who), $r_id, $message) ||
		xlog('error', $my_uin, "insert of sent $who $r_id failed");
}

sub im_ok {
	my ($oscar, $to, $r_id) = @_;
	print "# im_ok $to $r_id\n";

	return unless ($dbh);

	# oh, there seem to be bug in Net::OSCAR. It returns totally off-sync
	# request_id, so I just ack last send messages.
	$sth_sent_ok ||= $dbh->prepare(qq{
		update sent set sent = true where
			bot = ? and uin = ? and r_id = 
			(select r_id from sent as s2 where s2.uin = sent.uin and s2.sent = false order by s2.date desc limit 1)
	}) || die $dbh->errstr();

	$sth_sent_ok->execute($my_uin, $to) ||
		xlog('error', $my_uin, "insert of im_ok $to $r_id failed");
}

sub xlast {
	my $nr = shift;
	$nr ||= 10;	# default: show last 10 messages

	return 'last not supported without database support' unless ($dbh);

	$sth_last ||= $dbh->prepare(qq{
		select date,name,message from log where type = 'msg' and bot = ? order by date desc limit ?
	}) || die $dbh->errstr();

	$sth_last->execute($my_uin, $nr) ||
		xlog('error', $my_uin, "last failed") && return 'last failed';

	my @last;
	my $last_date = '';

	while (my $row = $sth_last->fetchrow_hashref() ) {
		my ($date, $time);
		if( $row->{'date'} =~ m#^(\d+-\d+-\d+)\s(\d+:\d+:\d+)# ) {
			($date,$time) = ($1,$2);
			if ($date ne $last_date) {
				unshift @last, "date: $date";
				$last_date = $date;
			}
		}

		$time ||= "unknown";

		unshift @last, "($time) [".$row->{'name'}."] ".$row->{'message'};
	}

	return join("\n", @last);
}


$oscar = Net::OSCAR->new(capabilities => [qw(extended_status typing_status)]) || die;
$oscar->loglevel(3);

read_config();
create_log_table();

$oscar->set_callback_im_in(\&im_in);
$oscar->set_callback_im_ok(\&im_ok);
$oscar->set_callback_buddy_in(\&buddy_in);
$oscar->set_callback_buddy_out(\&buddy_out);
$oscar->set_callback_buddylist_ok(\&buddylist_ok);
$oscar->set_callback_buddylist_error(\&buddylist_error);
$oscar->set_callback_signon_done(\&signon_done);
$oscar->set_callback_rate_alert(\&rate_alert);

$oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";

my $interval = 3600;
my $signoff_i = 5;

$config->{'last_t'} = time();
$config->{'nack_cnt'} = 0;

while(1) {
	$oscar->do_one_loop();

	next unless ($signon_done);

	my $last_t = $config->{'last_t'} || die "no last_t?";

	my $dt = time() - $last_t;
	if ($dt >= $interval) {

		my $nack_cnt = $config->{'nack_cnt'}++;
		print "# dt[$nack_cnt]: $dt\n";

		if ($nack_cnt < $signoff_i) {
			print "# ping keep-alive timeout: $dt s - sending ping, count: $nack_cnt\n";
			xsend_im($my_uin, "!ping ".int(time()) );
			$config->{'last_t'} = time();
		} else {
			print "# serious problems!\n";
			$config->{'nack_cnt'} = 0;

#			$oscar->signoff;
#			$signon_done = 0;
#			$oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
		}
	}

}

# make strict happy
$DBI::errstr++;