#!/usr/bin/perl

# Chat
# by Tim Morgan
# http://timmorgan.info/miniprojects/#chat

# This application is released without any warranty. I am not responsible for any damage it may cause.
# You may freely modify and distribute this application. I prefer you leave my name in this file.

# Please see install.txt for installation instructions.

%SETTINGS = (
	maxUsers => 10 ,
);
%MSG = (
	invalidNick     => "Tu apodo no es válido; solo puede incluir letras y números" ,
	maxUsers        => "El chat ha alcanzado el máximo número de usuarios simultáneos ." ,
	alreadyLoggedIn => "Tu apodo está en uso, inténtalo con otro. Si has perdido la conexión espera 10 segundos y vuelve a intentarlo." ,
);

use DomRS ;

$ROOT = $ENV{ DOCUMENT_ROOT } ;
$SCRDIR = $ENV{ SCRIPT_NAME } ;
$SCRDIR =~ s/http\:\/\/[^\/]*//i ;
$SCRDIR =~ s/chat\.cgi//i ;
$ROOT .= $SCRDIR ;

$RSCall = new DomRS() ;

# determine the needed/requested action...

# who's online? for use outside of chat app
# as seen on timmorgan.info homepage
if( $RSCall->{ query0 } eq "whosonline" ) {
	my @userList = logUser() ;
	$RSCall->returnData( @userList ) ;

# login
} elsif( $RSCall->{ query0 } eq "login" ) {
	login() ;

# logout
} elsif( $RSCall->{ query0 } eq "logout" ) {
	logout() ;

# hear
} elsif( $RSCall->{ query0 } eq "hear" ) {
	hear() ;

# say
} elsif( $RSCall->{ query0 } eq "say" ) {
	say() ;

# initialize
} elsif( !$RSCall->{ validQuery } ) {
	authenticate() ;
	printChatArea() ;

}

exit() ;

# sub routines - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

# prints the main HTML template and whatever content is passed
sub printHTML {
	print "content-type: text/html\n\n" ;
	my $content = shift ;
	open( TMPL, $ROOT . "templates/blank.html" ) ;
	while( <TMPL> ) {
		print $_ ;
		print $content if( /<!\-\-BODY\-\->/ ) ;
	}
	close( TMPL ) ;
}

# prints the login page
sub authenticate {
	$nickname = getCookie( "nickname" ) ;
	$userID = getCookie( "userID" ) ;
	if( !$nickname || !$userID || !checkUserID( $nickname, $userID ) ) {
		open( GETNICK, $ROOT . "templates/login.html" ) ;
		printHTML( join( "", <GETNICK> ) ) ;
		close( GETNICK ) ;
		exit() ;
	}
}

# authenticates the userID and nickname
sub checkUserID {
	my $nick = shift ;
	my $id = shift ;
	my @userInfo ;
	open( LOGFILE, $ROOT . "data/log.cgi" ) ;
	foreach( <LOGFILE> ) {
		@userInfo = split( /\s\|\s/ ) ;
		return 1 if $userInfo[0] eq $nick && $userInfo[2] == $id ;
	}
	close( LOGFILE ) ;
	return 0 ;
}

sub setUserID {
	my $nick = shift ;
	my $id = rand( 10000 ) ;
	open( LOGOUTPUT, ">>" . $ROOT . "data/log.cgi" ) ;
	print LOGOUTPUT $nick . " | " . time() . " | " . $id . "\n" ;
	close( LOGOUTPUT ) ;
	return $id ;
}

# determines if the requested nickname is currently in use and valid
# and responds to the client accordingly
sub login {
	my $checkNick = $RSCall->{ query1 } ;
	my @users = logUser() ;
	my $userOnline ;
	if( $checkNick !~ /^[\w\s]+$/ ) {
		$RSCall->returnData( "error", $MSG{ invalidNick } ) ;
		exit() ;
	}
	if( @users >= $SETTINGS{maxUsers} ) {
		$RSCall->returnData( "error", $MSG{ maxUsers } ) ;
		exit() ;
	}
	foreach $userOnline ( @users ) {
		if( "\U$userOnline" eq "\U$checkNick" ) {
			$RSCall->returnData( "error", $MSG{ alreadyLoggedIn } ) ;
			exit() ;
		}
	}
	$RSCall->returnData( "success", $checkNick, setUserID( $checkNick ) ) ;
	exit() ;
}

# prints the main chat window
sub printChatArea {
	open( CHATAREA, $ROOT . "templates/chat.html" ) ;
	printHTML( join( "", <CHATAREA> ) ) ;
	close( CHATAREA ) ;
	exit() ;
}

# records an incoming message
sub say {
	open( CHAT, ">>$ROOT" . "data/chat.cgi" ) ;
	my $nick = $RSCall->{ query1 } ;
	my $msg = $RSCall->{ query2 } ;
	my $listener = $RSCall->{ query3 } ;
	my $data = $RSCall->{ sessionId } . "-" . $nick . " ~~~ " . $msg . " ~~~ " . $listener ;
	print CHAT $data . "\n" ;
	close( CHAT ) ;
	$RSCall->returnData() ;
	exit() ;
}

# sends back new messages to a client requesting them
# (the client sends the sessionId of the last message it has;
# the server then sends all messages recorded since then)
sub hear {
	my $nick = $RSCall->{ query1 } ;
	my $id = $RSCall->{ query2 } ;
	if( !checkUserID( $nick, $id ) ) {
#		$RSCall->returnData( "bootuser" ) ;
		exit() ;
	}
	my $lastMsg = $RSCall->{ query3 } ;
	my $newStuff = 0 ;
	my @returnData = ();
	my $line ;
	open( CHAT, $ROOT . "data/chat.cgi" ) ;
	while( <CHAT> ) {
		$line = $_ ;
		$line =~ s/\n$// ;
		my $s = (split( / ~~~ /, $line ))[0] ;
		# find the last message the client knows about
		if( !$newStuff && $s eq $lastMsg ) {
			$newStuff = 1 ;
			next ;
		}
		next if !$newStuff ;
		my $listener = (split( / ~~~ /, $line ))[2] ;
		next if( $listener ne "!everyone" && $listener ne $nick ) ;

		# collect all new messages
		push @returnData, $line ;
	}
	close( CHAT ) ;
	push @returnData, $line if !$lastMsg || $lastMsg eq '' ;

	# no new messages -- send list of online users instead
	# (it makes sense to piggyback this operation on the "hear"
	# operation to save us from having to make another client-server
	# communication process)
	if( @returnData == 0 || $returnData[ 0 ] eq '' ) {
		my @usersOnline = logUser( $nick ) ;
		my $numUsersOnline = @usersOnline ;
		$RSCall->returnData( "usersonline", $numUsersOnline, @usersOnline ) ;

	# new messages found -- send them to the client
	} else {
		$RSCall->returnData( "hear", @returnData ) ;
	}
	exit() ;
}

# returns the list of online users
# if a nickname is given, updates that person on the list
sub logUser() {
	my $username = shift ;

	open( LOGFILE, $ROOT . "data/log.cgi" ) ;
	my( $user, $timestamp, @usersOnline, $id ) ;
	while( <LOGFILE> ) {
		last if( $_ eq "" || $_ eq "\n" ) ;
		s/\n$// ;
		( $user, $timestamp, $id ) = split( /\s*\|\s*/ ) ;
		$timestamp = time() if( $username && $username eq $user ) ;
		next if( time() - $timestamp > 60 ) ;
		push @usersOnline, {
			username  => $user,
			timestamp => $timestamp,
			id        => $id,
		};
	}
	close( LOGFILE ) ;

	open( LOGFILE, ">" . $ROOT . "data/log.cgi" ) ;
	my $useronline ;
	foreach $useronline ( @usersOnline ) {
		print LOGFILE $useronline->{username} . " | " . $useronline->{timestamp} . " | " . $useronline->{id} . "\n" ;
	}
	close( LOGFILE ) ;

	my @u ;
	foreach ( @usersOnline ) {
		push @u, $_->{username} ;
	}

	return @u if wantarray ;
	foreach( @u ) {
		$_ = "<div class='username'>" . $_ . "</div>" ;
	}
	return join( "<br />", @u ) ;
}

# removes the user from the list of online users;
# sends a special message back to the client signaling it to delete its nickname cookie
sub logout {
	my $nick = $RSCall->{query1} ;
	my $id = $RSCall->{query2} ;
	exit() if !checkUserID( $nick, $id ) ;
	my @userInfo = ();
	open( INLOG, $ROOT . "data/log.cgi" ) ;
	while( <INLOG> ) {
		push( @userInfo, $_ ) if( (split( /\s\|\s/ ))[0] ne $nick ) ;
	}
	close( INLOG ) ;
	open( OUTLOG, ">" . $ROOT . "data/log.cgi" ) ;
	foreach( @userInfo ) {
		print OUTLOG $_ ;
	}
	close( OUTLOG ) ;
	$RSCall->returnData( "bootuser" ) ;
	exit() ;
}

# retrieve a cookie
sub getCookie {
	my $requestedCookie = shift ;
	my @rawCookies ;
	if( $ENV{ HTTP_COOKIE } =~ /;/ ) {
		@rawCookies = split( /;\s/, $ENV{ HTTP_COOKIE } ) ;
	} else {
		@rawCookies = ( $ENV{ HTTP_COOKIE } ) ;
	}
	my %cookies ;
	my( $key, $val ) ;
	foreach( @rawCookies ) {
		( $key, $val ) = split( /\=/ ) ;
		$cookies{ decodeURI($key) } = decodeURI($val) ;
	}
	return $cookies{ $requestedCookie } ;
}

sub decodeURI
{
	my $str = shift ;
	if( @_ && wantarray ) {
		my @str = @_ ;
		return map { s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg } $str, @str ;
	}
	$str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg ;
	return $str ;
}