#!/usr/bin/perl -w
# Tiny chat server for pulia.
#
# TODO: 
# - Cleanup. Most messaging functions are almost identical except for silly
#   argument syntax!
# - Nick change (code is broken)
# - PING (ORLY?/ORLY!)
#
use strict;
use IO::Socket;
use IO::Select;
use constant MAX_CHUNK_SIZE => 4096;

my $MaxConnections      = 30;
my $AllowRemoteClients  = 1;  # Handle clients from remote hosts?
my $Connections = 0;

# Internal
my %UserList = (
    Server => 0,
);

my %Latency = (
    Server => 0,
);

my %Topic = (
    topic => 'There is no topic.',
    user  => 'Server',
);

my @Types = qw(Orly? Orly! Topic Message Quit);

my $ORLY = 'http://imatt.us/mt/archives/orly.JPG';

# Init listener socket
my $Sock = new IO::Socket::INET(
    LocalHost => 'liz.pulia.nu',
    LocalPort => '7070',
    Proto     => 'tcp',
    Listen    => $MaxConnections,
    ReuseAddr => 1,
);

die "Could not create socket: $!\n" unless $Sock;

#sub setLatency {
#    my ($User, $ReportedTime) = @_;
#    my $Time = time();
#}

# Must be called with a registered socket
sub getUserFromSock {
    my $Socket = shift;
    my($User, $Sock) = ();
    while (($User, $Sock) = each %UserList){
	return $User if $Sock == $Socket;
    }
    return 'Server';
}

sub addUser {
    my ($User, $Socket) = @_;
    $UserList{$User} = $Socket;
    dLog("Added \"$User\" on $Socket.");
}

sub dLog {
    my $HumanTime = localtime(time());
    print "$HumanTime: @_\n";
}

sub delUser {
    my $User = shift;
    dLog("Delete \"$User\" on $UserList{$User}.");
    delete $UserList{$User};
}

sub validType {
    my $Type = shift;
    foreach (@Types){
	return 1 if "$_" eq "$Type";
    }
    return 0;
}

sub registeredUser {
    my $User = shift;
    foreach (keys(%UserList)){
	return 1 if "$_" eq "$User";
    }
    return 0;
}

## Messaging functions
sub privateMessage {
    my ($Sender, $Recipient, $Message) = @_;
    $Message=~s/[\n|\r]//gs; # XXX Hack
    my $FD = $UserList{$Recipient};
    return if $FD == 0; # Message is to server
    print $FD "Message $Sender:$Message\n";
}

sub privateTopic {
    my ($Recipient, $Sender, $Topic) = @_;
    my $FD = $UserList{$Recipient};
    next if $FD == 0; # Message is to server
    print $FD "Topic $Sender:$Topic\n";
}

sub broadcastRename {
    my($Old, $New) = @_;
    foreach my $Recipient (keys(%UserList)){
	if("$Recipient" ne "$New"){
	    my $FD = $UserList{$Recipient};
	    print $FD "User $Old:$New\n";
	}
    }
}
sub broadcastMessage {
    my($Sender, $Message) = @_;
    foreach my $Recipient (keys(%UserList)){
	if("$Recipient" ne "$Sender"){
	    privateMessage($Sender, $Recipient, $Message);
	}
    }
}

sub broadcastTopic {
    my ($Sender, $Topic) = @_;
    foreach my $Recipient (keys(%UserList)){
	if("$Recipient" ne "$Sender"){
	    my $FD = $UserList{$Recipient};
	    next if $FD == 0; # Message is to server
	    print $FD "Topic $Sender $Topic\n";
	}
    }
}

sub broadcastUsers {
    my $List = join(' ', @_);
    foreach my $User (keys(%UserList)){
	my $FD = $UserList{$User};
	print $FD "Users $List\n" if $FD != 0;
    }
}

sub getUserList {
    my @List;
    push(@List, $_) for keys(%UserList);
    return @List;
}

sub setTopic {
    my($User, $Topic) = @_;
    %Topic = ();
    $Topic{$User} = $Topic;
}

sub handleData {
    my ($Socket, $Data) = @_;
    my @Chunks = split("\n", $Data);
    foreach my $Chunk (@Chunks){

	# Is it too big?
	if(length($Chunk) > MAX_CHUNK_SIZE){
	    dLog("Chunk from $Socket exceeds" . MAX_CHUNK_SIZE . "!");
	    print $Socket "Message Server:$ORLY\n";
	    next;
	}

	chop($Chunk);

	my $MessageOffset = index($Chunk, ':');

	# This is the stupid part of the spec.. Sorry.
	if($MessageOffset == -1){ # Can only be user/topic
	    my ($Type, $Request) = split(' ', $Chunk, 2);

	    if(substr(lc($Type), 0, 4) eq "help"){
		dLog("Sent help to $Socket");
		print $Socket "TYPEs: @Types\nASSISTs: User Topic\n";
	    }

	    if("$Type" ne "User" && "$Type" ne "Topic"){
		dLog("(bad syntax) Garbage on $Socket.");
		print $Socket "Message Server:$ORLY\n";
		next;
	    }

	    if("$Type" eq "User"){ # Nick set/rename
		if(!registeredUser($Request) && getUserFromSock($Socket) eq 'Server'){ # The nick is free
		    dLog("Accept \"$Request\" on $Socket from ".$Socket->peerhost.".");
		    addUser($Request, $Socket);
		    broadcastUsers(getUserList());
		}else{ # Someone else has it.
		    my $CurrentName = getUserFromSock($Socket);
		    if("$CurrentName" eq "$Request" || registeredUser($Request)){
			dLog("current=\"$CurrentName\", request=\"$Request\"");
			dLog("Deny $Socket request - \"$Request\" already taken.");
			print $Socket "Message Server:Already registered.\n";
		    }else{ # Rename
			dLog("Rename \"$CurrentName\" to \"$Request\".");
			delUser($CurrentName);
			addUser($Request, $Socket);
			broadcastRename($CurrentName, $Request);
		    }
		}
	    }elsif("$Type" eq "Topic"){ # Topic GET request
		
		my $Sender = getUserFromSock($Socket);
		
		if("$Sender" eq "Server"){ # Not a registered user.
		    dLog("Topic set from unregistered socket $Socket.");
		    print $Socket "Message Server:Not registered.\n";
		    next;
		}

		if(registeredUser($Sender)){ # Send topic
		    dLog("Topic requested by \"$Sender\" on $Socket.");
		    privateTopic($Sender, $Topic{'User'}, $Topic{'Topic'});
		}
	    }
	    next;
	}elsif($MessageOffset < 5){ 
	   dLog("Garbage on $Socket.");
	    next
	}

	my $Sender = getUserFromSock($Socket);
	if("$Sender" eq "Server"){ # Invalid sender
	    dLog("Unregistered user on $Socket");
	    # print $Socket "Message Server:Please register.\n";
	    next;
	}

	my $RawHeader = substr($Chunk, 0, $MessageOffset);
	my $Message   = substr($Chunk, $MessageOffset + 1);
	my @Header    = split(' ', $RawHeader, 2);

	if(@Header != 2){ # This can't be valid
	    dLog("(Nonvalid header) Garbage on $Socket.");
	    print $Socket "Message Server:Invalid header\n";
	    next;
	}

	my ($Type, $Recipient) = @Header;

	if(!validType($Type)){ # Not a valid type
	    dLog("(Invalid type \"$Type\") Garbage on $Socket.");
	    print $Socket "Message Server unknown:Invalid type.\n";
	    next;
	}

	if(!registeredUser($Recipient)){ # Not a valid recipient
	    dLog("Invalid recipient \"$Recipient\" for message from \"$Sender\".");
	    print $Socket "Message Server:Invalid recipient.";
	    next;
	}

	# Everything seems ok. Handle complete request.
#	if("$Type" eq "Orly?"){       # Ping request
#	    print $Socket "Orly! $Sender:" . time() . "\n";
#	}elsif("$Type" eq "Orly!"){   # Ping response from Server request
#	    setLatency($Sender, $Message);
#	}elsif("$Type" eq "Topic"){   # Topic set requesrt
	if("$Type" eq "Topic"){   # Topic set requesrt
	    broadcastTopic($Sender, $Message);
	}elsif("$Type" eq "Message"){ # Message send
	    if("$Recipient" eq "Server"){ # Broadcast
		broadcastMessage($Sender, $Message);
	    }else{
		privateMessage($Sender, $Recipient, $Message);
	    }
	}elsif("$Type" eq "Quit"){
	    if("$Recipient" eq "Server"){ # Meh. Proto is proto.
		return 0; 
	    }else{
		dLog("Broken quit request from \"$Sender\".");
		print $Socket "Message Server:Invalid request.\n";
	    }
	}
    }

    return 1;
}


$Sock->autoflush(1);

my $Handles = new IO::Select();
$Handles->add($Sock);

print "Ready.\n";

while(1){
    my ($New) = IO::Select->select($Handles, undef, undef, 0);

    foreach my $Socket (@$New){
	if($Socket == $Sock){ # Accept connection
	    my $Client = $Sock->accept();
	    if(!$AllowRemoteClients && $Client->sockhost() ne '127.0.0.1'){
		close($Client);
		dLog("Disconnect $Socket - remote client.");
		next;
	    }
	    $Client->autoflush(1);
	    $Handles->add($Client);
	    $Connections++;
	    dLog("Connect $Client from " . $Client->peerhost);
	}else{                # Handle request
	    my $Buffer = <$Socket>;
	    if($Buffer){      # Handle data
		unless(handleData($Socket, $Buffer)){
		    $Connections--;
		    delUser(getUserFromSock($Socket));
		    $Handles->remove($Socket);
		    close($Socket);
		    broadcastUsers(getUserList());
		    dLog("Disconnect $Socket.");
		}
	    }else{            # Connection closed
		dLog("Disconnect $Socket.");
		my $User = getUserFromSock($Socket);
		print "USER=\"$User\"\n";
		if("$User" eq "Server"){
		    dLog("User<->Socket mapping FAILURE!");
		}else{
		    delUser($User);
		    broadcastUsers(getUserList());
		}
		print "DEBUG: Users: " . getUserList() . "\n";
		$Handles->remove($Socket);
		close($Socket);
		$Connections--;
	    }
	}
    }
}