rendered paste body#!/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--;
}
}
}
}