#!/usr/bin/perl

# (copyleft) 2006 alexander@oelzant.priv.at
# web chatserver client
# best use with webchat.sh and rlwrap (no direct readline support built in)
# TODO: make highlighting configurable
#       IRC proxy mode


use strict;
use warnings;

require LWP::UserAgent;
use Net::HTTP;
use IO::Select;
require HTTP::Request;
require HTTP::Cookies;

use Encode;
use HTML::Entities;
#use LWP;
use CGI (qw/escape/);


# thousands of lines just for autoflush :-(
use IO::Handle;

use LWP::ConnCache;

my $chatservice="chatservice";         # -S ...
my $chatserver="chat.$chatservice.at"; # -s ...
my $chatbaseurl="/new";
# my $infourl="http://www.$chatservice.at/pages/$chatservice/single_detail_chat.php?username=";
my $infourl="http://www.$chatservice.at/pages/site/de/"; # 517183.html";

my $smileypfad="/smilies/";
my $smileyext=".gif";

my $chatuser="atest";                  # -u ...
my $chatpass="";                       # -p ...
my $chatroom="international";
my $highlight="\\b$chatuser\\b|\\bfl.ster";

my $timeout=500;
#my $timeout=200;
my $logfile="$ENV{HOME}/webchat.log";

my $ircproxy=0;

# test /info:
#print &info($ARGV[0]);
#exit 0;

use Getopt::Std;

my %opts;

getopt('S:c:u:p:s:T:', \%opts);
$chatroom=$opts{"c"} if $opts{"c"};
$chatpass=$opts{"p"} if $opts{"p"};
$chatuser=$opts{"u"} if $opts{"u"};
$chatservice=$opts{"S"} if $opts{"S"};
$chatserver="chat.$chatservice.at";
$chatserver=$opts{"s"} if $opts{"s"};
&HELP_MESSAGE if defined($opts{"?"}); 
&HELP_MESSAGE if defined($opts{"h"}); 

$highlight="\\b$chatuser\\b|\\bfl.ster";

sub HELP_MESSAGE {
	print "$0 usage:
	-h                     help
	-c channel [$chatroom]
	-p pass    [xxx]
	-u user    [$chatuser]
	-S service [$chatservice]
	-s server  [$chatserver]
";
exit(0);
}

if ($opts{"T"}) {
	$logfile="";
	&out($opts{"T"});
	exit(0);
}



my (%smileys);
my ($sessionid);
my ($rin,$rout,$rtime,$count,$msg);

%smileys=(
"sleep2" => "I-)",
"knussel" => "*knutsch*",
"Bolt" => "8-O",
"goodnight" => "",
"huepfer1" => "",
"streiten" => "",
"bad" => "",
"kochen" => "",
"idee" => "",
"love2" => "*love2*",
"popo" => "*popo*",
"tel" => "*tel*",
"kotz" => "*kotz*",
"ka" => "*ka*",
"smiliefluester" => "",
"lieb" => "",
"sex" => "",
"speaker" => "",
"bye" => "",
"cry" => "*heul*",
"naughty" => "*naughty*",
"bussirot" => "*bussi*",
"schwein" => "*schwein*",
"bye2" => "*bye2*",
"roseschenk" => "@}-;-",
"tanz" => "*tanz*",
"love" => "",
"troesten" => "",
"saug" => "",
"respekt" => "*respekt*",
"-r" => "",
"l" => ":-D",
"engel" => "*engel*",
"crazy" => "*crazy*",
"ok" => "",
"box" => "",
"handy" => "",
"bye1" => "",
"cry1" => "",
"zwinker" => ";-)",
"sonne" => "*sonne*",
"bier" => "*bier*",
"bg" => "*bg*",
"watsche" => "*watsche*",
"bang" => "*headbang*",
"kopf" => "",
"sexsmoke" => "",
"-)" => ":-)",
"rrofl" => "",
"rolleyes" => "*rolleyes*",
"schock" => "=:-O",
"lol" => "*lol*",
"angryfire" => "",
"good" => "",
"sekt" => "",
"kopfkratz" => "",
"gaehn" => "",
"lol1" => "",
"mock" => "",
"inlove" => "",
"kaffee" => "",
"sing" => "",
"tischhau" => "",
"wut" => "",
"teufel" => "",
"muhaha" => "",
"rotwerd" => "",
"sabba" => "",
"kaputtlach" => "",
"baeh" => ":-P",
"knie" => "",
"vogel" => "",
"amore" => "",
"burzeltag" => "",
"dudu" => "",
"cry4" => "",
"smoke" => "",
"klatsch" => "",
"teufelfinger" => "",
"bussi" => "",
"gg" => ":-]",
"hello" => "",
"gaga" => "",
"schwert" => "",
"hammer" => "",
"wall" => "",
"arsch" => "",
);

# test beautify STDIN:
#print &beautify(<>);
#exit(0);

my $cache = LWP::ConnCache->new;
$cache->capacity("http",3);
my $ua = LWP::UserAgent->new;
$ua->cookie_jar( {} );

sub wget($;$) {
	my ($request, $response, $success);

	my ($url,$content)=@_;

	$request = HTTP::Request->new(GET => "$url");
	if ($content) {
		$request->method("POST");
		$request->content($content);
	}

	$success=0;
	my $tries=0;
	while (!$success && $tries++<10) {
		$ua->agent('Mozilla/5.0');
		$ua->timeout(10);
		$ua->conn_cache($cache);
		$response = $ua->request($request);
		$success=$response->is_success;
	}
	return $response->content;
}

# set room
if ($ARGV[0]) {
	$chatroom=$ARGV[0];
}

my $urlpass=$chatpass;
$urlpass =~ s/(.)/{"%".sprintf("%02x",unpack("C",$1))}/ge;
print "chatpass: $chatpass, urlpass: $urlpass\n";
#exit 1;
my $mainwindow=&wget("http://$chatserver/$chatbaseurl/index.html","ssl=&ipaq=&room=$chatroom&language=Deutsch&flash=&name=$chatuser&passwd=$urlpass&sessionid=&");
die "could not load main window" unless $mainwindow;
if ($mainwindow =~ /sessionid=([a-zA-Z0-9]*)/msg) {
	$sessionid = $1;
	print "session: $sessionid\n";
	print "\n";
} else {
	print $mainwindow;
	print "=============\n no session id!\n";
	exit 1;
}

#print $response->content;

my $s = Net::HTTP->new(Host => "$chatserver") || die $@;
$s->write_request(GET => "/new/stream.html?sessionid=$sessionid", 'User-Agent' => "Mozilla/5.0");

my $sel = IO::Select->new($s);

READ_HEADER: {
							 die "Header timeout" unless $sel->can_read(10);
							 my($code, $mess, %h) = $s->read_response_headers(laxed => 1);
							 print "$code $mess\n";
							 redo READ_HEADER unless $code;
						 }
#my($code, $mess, %h) = $s->read_response_headers;

my $lastsent=time;
my ($buf,$oldbuf);
$oldbuf="";

if (! $ircproxy) {
	open LOG,">>$logfile" || die "$logfile";
	LOG->autoflush(1);

	while (1) {
		$rin = '';
		$rout = '';
		vec($rin, 0, 1) = 1;

# timeout after 10.0 seconds
		if (select($rout = $rin, undef, undef, .001)) {
			$msg=<STDIN>;
			chomp $msg;
		} else {
			$msg=undef;
			if (time > ($lastsent + $timeout)) {
				$msg="/w $chatuser $lastsent";
			}
		}
		if ($msg && $msg =~ m#/info (.*)$#) {
			&out(&info($1));
			$msg=undef;
		}
		if ($msg) {
			&wget("http://$chatserver/$chatbaseurl/input.html","sessionid=$sessionid&text=".escape($msg));
			$lastsent=time;
		}

		if ($sel->can_read(.001)) {
			my $n = $s->read_entity_body($buf, 1024);
			#my $n = sysread($s, $buf, 1024);
			my $buf1=$oldbuf.$buf;
			if ($buf1 =~ /<[^>]*$/si) {
				# otherwise the regex takes minutes to execute?!
				$buf1 =~ /(.*)(<[^>]*)$/si;
				$buf1 = $1;
				$oldbuf=$2;
			} elsif ($buf1 =~ /&\d*$/si) {
				$buf1 =~ /(.*)(&\d*)$/si;
				$buf1 = $1;
				$oldbuf=$2;
			} else {
				$oldbuf="";
			}

			while ($buf1 =~ s#^(.*?(?:<br/?>|<p>|</p>)\s+)(.*)#$2#is) {
				&out($1);
			}
			$oldbuf=$buf1.$oldbuf;

			die "read failed: $!" unless defined $n;
			last unless $n;
		}
		select(undef, undef, undef, .001);
	}
} else { # ircproxy
	$logfile=undef;

	while (1) {
		$rin = '';
		$rout = '';
		vec($rin, 0, 1) = 1;

# timeout after 0.1 seconds
		if (select($rout = $rin, undef, undef, .1)) {
			$msg=<STDIN>;
			chomp $msg;
		} else {
			$msg=undef;
			if (time > ($lastsent + $timeout)) {
				$msg="/w $chatuser $lastsent";
			}
		}
		if ($msg && $msg =~ m#/info (.*)$#) {
			&out_irc(&info($1));
			$msg=undef;
		}
		if ($msg) {
			&wget("http://$chatserver/$chatbaseurl/input.html","sessionid=$sessionid&text=$msg");
			$lastsent=time;
		}

		if ($sel->can_read(.1)) {
			my $n = $s->read_entity_body($buf, 1024);
			$buf=$oldbuf.$buf;
			if ($buf =~ /(.*)(<[^>]*)$/si) {
				$buf = $1;
				$oldbuf=$2;
			} elsif ($buf =~ /(.*)(&\d*)$/si) {
				$buf = $1;
				$oldbuf=$2;
			} else {
				$oldbuf="";
			}

			while ($buf =~ s#^(.*?<br/?>\s+)(.*)#$2#is) {
				&out_irc($1);
			}
			$oldbuf=$buf.$oldbuf;

			die "read failed: $!" unless defined $n;
			last unless $n;
		}
	}
}

sub out($) {
	my ($line)=@_;
	print beautify($line);
	print LOG $line if $logfile; 
}

sub out_irc($;$) {
	my ($line,$type)=@_;
	$line =~ s/^(\d\d:\d\d) ([^>( )]+) /$1 \x1b[1m$2\x1b[0m /mg;
	# caveat: > verschwindet
	$line =~ s/^(\d\d:\d\d) > (\w+) /$1 \x1b[1m$2\x1b[0m /mg;
	$line =~ s/^(\d\d:\d\d) \(([^\)]+)\)/$1 (\x1b[1m$2\x1b[0m)/mg;
	
	print beautify($line);
	print LOG $line if $logfile; 
}

sub info($) {
	my ($user)=@_;
	my ($infohtml,$infotxt,$url,$uid,$username,$age);

	$infotxt="";
	$infohtml=wget("http://www.$chatservice.at/pages/site/de/single_detail.php?username=$user");
# Singlenummer: <span class="profil_top_white_normal">807730</span><br>
	if ($infohtml !~ m#class=tab_single_detail_active#ms) {
		$infohtml=wget("http://www.$chatservice.at/pages/site/de/single_detail2.php?username=$user");
	}
	if ($infohtml =~ m#Singlenummer:(?:\s*<[^>]*>)*(\d+)<#ms) {
		$uid = "$1";
	}
	if ($infohtml =~ m#Username:(?:\s*<[^>]*>)*([^<]+)<#ms) {
		$infotxt .= "$1";
		# $username = "$1";
		# $username =~ s/, (\d+)//;
		# $age=$1;
	if ($infohtml =~ m#<li class="cat_(.)_white">\s*([^<]*)</li>#ms) {
		my ($num,$string)=($1,$2);
		if ($string) {
			$infotxt .= ", $2";
		} elsif ($num =~ /1/) {
			$infotxt .= ", Mann";
		} elsif ($num =~ /2/) {
			$infotxt .= ", Frau";
		} elsif ($num =~ /3/) {
			$infotxt .= ", Paar";
		}
			
	}
	if ($infohtml =~ m#<li class="status_white">\s*([^<]+)</li>#ms) {
		$infotxt .= ", $1";
	}
	if ($infohtml =~ m#<li class=country_(.)_white>\s*([^<]+)</li>#ms) {
		$infotxt .= ", $2";
		if ($1 =~ /1/) {
			$infotxt .= " (at)";
		} elsif ($1 =~ /2/) {
			$infotxt .= " (de)";
		} elsif ($1 =~ /3/) {
			$infotxt .= " (ch)";
		}
	}
	$infotxt .= "<br/>\n  ";
	}
	if ($infohtml =~ m#class=tab_single_detail_grey#ms) {
		$infotxt .= "_";
	} else {
		$infotxt .= "P";
	}
	if ($infohtml =~ m#class=tab_single_detail2_grey#ms) {
		$infotxt .= "_";
	} else {
		$infotxt .= "E";
	}
	if ($infohtml =~ m#class=tab_single_album_grey#ms) {
		$infotxt .= "_";
	} else {
		$infotxt .= "A";
	}
	if ($infohtml =~ m#class=tab_single_guest_grey#ms) {
		$infotxt .= "_";
	} else {
		$infotxt .= "G";
	}
	if ($infohtml =~ m#class=tab_single_contact_grey#ms) {
		$infotxt .= "_";
	} else {
		$infotxt .= "M";
	}
	if ($infohtml =~ m#class=tab_single_diary_grey#ms) {
		$infotxt .= "_";
	} else {
		$infotxt .= "D";
	}


	if ($infohtml =~ m#Profil seit:(?:\s*<[^>]*>)*([^<]+)<#s) {
		$infotxt .= ", seit $1";
	}
	if ($infohtml =~ m#zuletzt online:(?:\s*<[^>]*>)*([^<]+)<#s) {
		$infotxt .= ", zuletzt $1";
	}
	if ($infohtml =~ m#User ist online#s) {
		$infotxt .= " (jetzt online!)";
	}
	$infotxt .= "<br/>\n";
	if ($uid && $infohtml !~ m#class=tab_single_detail_grey#ms) {
		$url="http://www.$chatservice.at/pages/site/de/$uid.html";
	} else {
		$url="http://www.$chatservice.at/pages/site/de/single_detail2.php?username=$user";
	}
	$infotxt .= "  <a href=\"$url\">$url</a><br/>\n";
	# Profilanalyse:
	if ($infohtml =~ /chicken_error.png/s) {
		$infotxt .= "  error fetching profile<br/>\n";
	}
	if ($infohtml =~ m#(http://dyn.$chatservice.at/)(uploadcounter_\d+/)([^"]+)"#s) {
		my $img="$1$3";
		my $prev=$img;
		$prev =~ s/.jpg/_prev.jpg/;
		$infotxt .= "  <a href=\"$img\"><img src=\"$prev\"/>$img</a><br/>\n";
	} elsif ($infohtml =~ m#class=tab_single_detail_grey#ms) {
		my $pre;
		if ($uid =~ /^(\d\d\d)/) {
			$pre="$1/";
		} else {
			$pre="";
		}
		my $img="http://dyn.$chatservice.at/singleboerse/images/${pre}pic$uid.jpg";
		my $prev=$img;
		$prev =~ s/.jpg/_prev.jpg/;
		$infotxt .= "  <a href=\"$img\"><img src=\"$prev\"/>$img</a><br/>\n";
	}
	if ($uid && $infohtml !~ m#class=tab_single_detail_grey#ms) {
		my $counter=0;
		for my $i ("Gr..e", "Gewicht", "Haarfarbe", "Augenfarbe", "Statur", "Ausbildung", "Beruf", "Studienrichtungen", "Beziehungswunsch", "Sexuelle Vorlieben", "Kinder", "Ich bin") {
			if ($infohtml =~ m#<span class=profil_title>$i:\s*(?:&nbsp;)*\s*</span>(?:<br>)?((?:<span class=profil_normal>\s*(?:&nbsp;)*\s*[^<]+?\s*</span>\s*)+)#s) {
				my $value=$1;
				$value =~ s/<[^>]+>//g;
				$value =~ s/^\s*(.*?)\s*$/$1/g;
				if ($value !~ /^$|keine Angabe|^-&nbsp;kg\s*$/) {
					# if (($counter%3) == 0) 
					if ($i =~ /Gr..e|Ausbildung|Beziehungswunsch/) {
						$infotxt .= "  ";
					} else { 
						$infotxt .= ", ";
					}
					$counter++;
					if ($i =~ /Beziehungswunsch|Sexuelle Vorlieben|Kinder|Ich bin/) {
						$value =~ s/\b(\w)\w+/$1/g;
						$value =~ s/\b(\w) /$1/g;
					}
					if ($i !~ /Gr..e|Gewicht|Ich bin/) {
						my $p=$i;
						$p =~ s/farbe//;
						$p =~ s/uelle Vorlieben//;
						$p =~ s/eziehungs/-/;
						$infotxt .= "$p: $value";
					} else {
						$infotxt .= "$value";
					}
					# if (($counter%3) == 0) 
					if ($i =~ /Statur|Beruf|Ich bin/) {
						$infotxt .= "<br/>\n";
					}
				}
			}
		}
		if (($counter%3) != 0) {
			$infotxt .= "<br/>\n";
		}
	}
		

	return $infotxt;
}

sub beautify($) {
	my ($line)=@_;
	my $rep;

	$line =~ s/^$//sg;
	$line =~ s/\n//sg;
	$line =~ s/&nbsp;/ /sg;
	$line =~ s/<p\b[^>]*>/\n/sgi;
	$line =~ s/<br\b[^>]*>/\n/sgi;
	#<img src="/smilies/bye1.gif" border="0"/>
	while ($line =~ /<img[^>]+src="${smileypfad}([^"]*)$smileyext"[^>]*>/si) {
		$rep=$smileys{$1};
		if (!$rep || $rep =~ /^$/) {
			$rep="*$1*";
		}
		$line =~ s/<img[^>]*src="${smileypfad}([^"]*)$smileyext"[^>]*>/$rep/si;
	}
	$line =~ s/<[^>]*>//msgi;
	#$line=decode_entities($line);
	#while ($line =~ /\&\#(\d+);/msi) {
	#	$rep=pack("C",$1);
	#	$line =~ s/\&\#\d+;/$rep/msi;
	#}
	#$line =~ s/&lt;/</sg;
	#$line =~ s/&gt;/>/sg;
	#$line =~ s/&amp;/\&/sg;
	# caveat: > verschwindet
	$line =~ s/^(\d\d:\d\d) > (\w+) /$1\x1b[1m $2 \x1b[0m/mg;
	$line =~ s/^(\d\d:\d\d) \(([^\)]+)\)/$1 \x1b[1m($2)\x1b[0m/mg;
	$line =~ s/($highlight)/\a\x1b[7m$1\x1b[27m/isg;
	# ...
	$line =~ s/^(\d\d:\d\d) ([^>( )]+) /$1\x1b[1m $2 \x1b[0m/mg;
	
	return encode("utf-8",decode_entities(decode("iso-8859-1",$line)));
}