HomeSearchFiles
User Control Panel
Advertisements

HELP US, HELP YOU!

TCP Server and Client, CPU Issues

 
Post new topic   Reply to topic    Bot Depot Forum Index -> Perl
View unanswered posts
Author Message
Cer
Upgraded Agent
Upgraded Agent


Joined: 03 Feb 2004
Posts: 3776
Location: Michigan
Reputation: 146.9
votes: 4
PostPosted: Sat Jan 07, 2006 1:52 am    Post subject: TCP Server and Client, CPU Issues Reply with quote
I'm running a TCP server for a chat room and therefore have made clients for it that follow the same protocol.

How the chat server works is:

There's a module RainbowBoi::Chat::Server, which takes a protocol string from the user, processes things by modifying files and stuff, and then returns a protocol-like string from the server (if applicable).

So therefore there is a CGI version too, which sends in the query string and prints out the results. The TCP server uses the same thing too but runs as a TCP, sending and receiving these strings over a socket.

The issue is: when I start up the TCP server, the CPU is fine. When I run two moderator bots that connect to this server, the CPU is still fine. And then I sign on with the chat client and it's still fine. But, when I close out of the chat client the CPU spikes up to 100% on the server process. When I end-task the server, the bot process spikes up to 100%.

I figured the problem might be that the server was holding on to dead sockets not knowing they were closed, and maybe doing something recursive with them. I tried programming something to time out old sockets every 15 seconds by sending 'PONG' (a protocol command) to them and closing the ones that fail to receive the message.

When I did this the first time, every now and then it would say "Can't call send on an undefined package" or something and crash (causing all the clients connected to spike up in CPU usage). So I put the entire thing in an eval, hoping it would close what sockets it could without crashing for what sockets it couldn't.

And this still didn't help.

Here are the codes if you wanna take a look:

TcpServer.pl (the TCP Server)
Quote:
#!/usr/bin/perl -w

use strict;
use warnings;
use IO::Socket;
use IO::Select;

use lib "./lib";
use RainbowBoi::Chat::Server;

# Load the server.
our $server = new RainbowBoi::Chat::Server (debug => 0);
require "subroutines.pl";

# Start the TCP Server.
our $sock = IO::Socket::INET->new (
LocalAddr => 'rainbowboi.com',
LocalPort => 7775,
Listen => 1,
Proto => 'tcp',
Reuse => 1,
) or die "Socket error: $!";
our $select = IO::Select->new ($sock);

print "Server started.\n";

my $users = {}; # Connections

# Set a timeout timer for 15 seconds.
our $timer = time() + 15;

while (1) {
# Loop for timeouts.
if (time() - $timer >= 0) {
$timer = time() + 15;

print "Checking timed-out sockets\n";

# Send a pong to every sock.
foreach my $socket (keys %{$users}) {
&reply ($socket,'PONG');
}
}

# Look for new events.
my @ready = $select->can_read (.1);
next unless(@ready);

# Go through each event.
foreach my $socket (@ready) {
# If the listening socket is ready...
if ($socket == $sock) {
my $new = $sock->accept();
$select->add ($new);
print $new->fileno . ": connected\n";

# Create data.
my $nid = $new->fileno;
$users->{$nid} = {
conn => 0,
logn => 0,
nick => '',
};

# Send a response.
&reply ($new,"TCPK");
}
else {
# Get their ID.
my $id = $socket->fileno;

# Read their request.
my $in = '';
$socket->recv ($in, 3072);
chomp $in;

my @lines = split(/\n/, $in);
foreach my $line (@lines) {
# Skip blank lines.
next if $line eq "";

print "C" . $socket->fileno . ": $line\n" unless $line =~ /^ping/i;
$line = "1::$line";

# Send it into the server.
my $response = $server->message ($line,$socket->peerhost);
&reply ($socket,$response);
}
}
}
}

sub reply {
my ($socket,$msg) = @_;

# Send it.
print "S: $msg\n" unless $msg =~ /^pong/i;
return unless (defined $socket || $socket == $sock);
eval {
$socket->send ("$msg\n") or do {
# Disconnected.
my $id = $socket->fileno;
delete $users->{$id};

$select->remove ($socket);
$socket->close();

print "\nRemoving socket $id (timed out)\n\n";
}
};
}


ChatBots.pl (the bot processes)
Code:
#!/usr/bin/perl -w

use strict;
use warnings;
use RainbowBoi::Chat::Client;

# Use Mojave's FloodCheck.
use FloodCheck;

##########################
## Bot Configurations   ##
##########################

# Sign-on settings. Set up each
# bot's user with its password.

my $conn = {
   RainbowBoi  => '*****',
   RoomControl => '*****',
};

# Set up the bot positions.
## friendly  = logs most conversation,
##             responds to triggers.
## moderator = runs FloodCheck, monitors
##             whispers
our $friendly  = 'RainbowBoi';
our $moderator = 'RoomControl';

# Small curse words lists (these should get warnings
# unless used too much)
our @swears = qw(shit bitch slut whore skank);

# Large swear words that will get you kicked.
our @curses = qw(fuck fck);

# Global hashref.
our $rb = {
   intro => 0,  # Show intro messages once.
   lobby => 0,  # Show lobby messages once.
   bots  => {}, # Bot data.
   who   => {}, # Who's Online
   users => {}, # Keep track of users.
   flood => '', # FloodCheck object.
};

# Set up the flood checker.
$rb->{flood} = new FloodCheck (
   message_total => 10,
   huge_size     => 250,
   large_size    => 100,
   range_size    => 4,
   rate_time     => 3,
   purge_min     => 1200,
);

# Sign on the bots.
foreach my $bot (keys %{$conn}) {
   $rb->{bots}->{$bot}->{client} = new RainbowBoi::Chat::Client(botname => $bot);

   # Set up handlers.
   $rb->{bots}->{$bot}->{client}->setHandler ('ACPT', \&on_acpt);
   $rb->{bots}->{$bot}->{client}->setHandler ('ENTR', \&on_entr);
   $rb->{bots}->{$bot}->{client}->setHandler ('INTR', \&on_intr);
   $rb->{bots}->{$bot}->{client}->setHandler ('HELO', \&on_helo);
   $rb->{bots}->{$bot}->{client}->setHandler ('LIST', \&on_list);
   $rb->{bots}->{$bot}->{client}->setHandler ('MESG', \&on_mesg);
   $rb->{bots}->{$bot}->{client}->setHandler ('EROR', \&on_eror);

   # Connect.
   $rb->{bots}->{$bot}->{client}->connect();
}

# Loop the bots.
while (1) {
   foreach my $bot (keys %{$rb->{bots}}) {
      $rb->{bots}->{$bot}->{client}->do_one_loop();
   }
}

sub on_acpt {
   my $self = shift;

   # Sign in.
   my $bot = $self->{botname};

   print "Connection accepted. Signing in $bot...\n";
   $self->signin ($bot, $conn->{$bot});
}

sub on_entr {
   my $self = shift;

   print "$self->{botname} login accepted.\n";
}

sub on_intr {
   my ($self,$level,$msg) = @_;

   $msg =~ s/<(.|\n)+?>//g;

   return if $rb->{intro} >= 2;
   $rb->{intro}++;

   print "$msg\n\n";
}

sub on_helo {
   my ($self,$time,@msgs) = @_;

   return if $rb->{lobby} >= 1;
   $rb->{lobby}++;

   foreach my $msg (@msgs) {
      print "[ChatServer] $msg\n";
   }

   print "\n";
}

sub on_list {
   my ($self,@who) = @_;

   # Got the wholist.
   foreach my $line (@who) {
      my ($nick,$level) = split(/=/, $line);
      $self->{who}->{$nick} = $level;
   }
}

sub on_mesg {
   my ($self,$time,$type,$level,$from,$to,$msg) = @_;

   my $bot = $self->{botname};

   if ($type eq 'client') {
      print "## [ChatClient] $msg\n" if $bot eq $friendly;
   }
   elsif ($type eq 'server') {
      print "## [ChatServer] $msg\n" if $bot eq $friendly;
   }
   elsif ($type eq 'private') {
      &commands ($from,$level,$msg);
      &flooders ($bot,$from,$msg);
      print "-- Private from $from to $to: $msg\n" if $bot eq $moderator;
   }
   elsif ($type eq 'action') {
      &commands ($from,$level,$msg);
      &flooders ($bot,$from,$msg);
      print "** $from $msg **\n" if $bot eq $friendly;
   }
   else {
      &commands ($from,$level,$msg);
      &flooders ($bot,$from,$msg);
      print "[$from] $msg\n" if $bot eq $friendly;
   }
}

sub on_eror {
   my ($self,$error) = @_;

   print "\nERROR: $error\n\n";
}

sub flooders {
   my ($bot,$user,$msg) = @_;
   $user =~ s/\s//g;

   # See if their data exists yet.
   if (!exists $rb->{users}->{$user}) {
      $rb->{users}->{$user} = {
         curse_small => 0, # Number of simple curse words.
         curse_major => 0, # Number of major curse words.
         kicks       => 0, # Number of kicks (5 = ban)
         warnings    => 0, # Number of warnings (3 = kick)
      };
   }

   # Only RoomControl should check these.
   return unless $bot =~ /$moderator/i;

   # Run FloodCheck.
   my $level = $rb->{flood}->check ($user,$msg);

   # Are they flooding?
   my $warn = 0;
   my $kick = 0;
   my $ban = 0;
   my $reason = 0;
   if ($level == 1) {
      $kick = 1;
      $reason = "for sending large messages";
   }
   elsif ($level == 2) {
      $kick = 1;
      $reason = "for spamming large messages";
   }
   elsif ($level == 3) {
      $warn = 1;
      $reason = "Stop repeating yourself or you will be kicked from the room";
   }
   elsif ($level == 4) {
      $kick = 1;
      $reason = "for repeating too much";
   }
   elsif ($level == 5) {
      $kick = 1;
      $reason = "for spamming";
   }

   # Are they swearing?
   if ($warn == 0 && $kick == 0 && $ban == 0) {
      foreach my $swear (@swears) {
         if ($msg =~ /\b$swear\b/i) {
            $warn = 1;
            $reason = "Please don't swear in this chat room";
         }
      }
      foreach my $curse (@curses) {
         if ($msg =~ /\b$curse\b/i) {
            $kick = 1;
            $reason = "Please don't swear in this chat room";
         }
      }
   }

   # What to do?
   if ($warn == 1) {
      # Just warn them.
      $rb->{users}->{$user}->{warnings}++;

      # More than 3 warnings?
      if ($rb->{users}->{$user}->{warnings} > 3) {
         # Kick them instead.
         $rb->{users}->{$user}->{warnings} = 0;
         $kick = 1;
      }
      else {
         $rb->{bots}->{$bot}->{client}->sendMessage ("/whisper $user $reason (warning $rb->{users}->{$user}->{warnings} of 3).");

         print "\nWarning $user for repeating\n\n";
      }
   }
   if ($kick == 1) {
      # Kick them.
      $rb->{users}->{$user}->{kicks}++;

      # Kicked too many times already?
      if ($rb->{users}->{$user}->{kicks} >= 5) {
         # Ban him instead.
         $ban = 1;
      }
      else {
         $rb->{bots}->{$bot}->{client}->sendMessage ("$user is being kicked from the room: $reason");
         $rb->{bots}->{$bot}->{client}->sendMessage ("/kick $user");

         print "\nKicked $user $reason\n\n";
      }
   }
   if ($ban == 1) {
      # Ban them.
      $rb->{users}->{$user}->{bans}++;

      $rb->{bots}->{$bot}->{client}->sendMessage ("$user is being banned from the room $reason");
      $rb->{bots}->{$bot}->{client}->sendMessage ("/ban $user");

      print "\nBanned $user $reason\n\n";
   }

   # If they were being friendly...
   if ($warn == 0 && $kick == 0 && $ban == 0) {
      # RainbowBoi should respond to triggers.

      if ($msg =~ /(hey|hello|hi) (room|everyone|everybody)/i) {
         $rb->{bots}->{$friendly}->{client}->sendMessage ("Hello $user. :)");
      }
   }

   # Return.
   return 1;
}

sub commands {
   my ($user,$level,$msg) = @_;

   # Only run commands by admins.
   return unless $level >= 4;

   if ($msg =~ /^\!exit/i) {
      # Sign the bots out.
      foreach my $bot (keys %{$rb->{bots}}) {
         $rb->{bots}->{$bot}->{client}->signout();
      }
   }
   elsif ($msg =~ /^\!restart/i) {
      # Restart the bots.
      foreach my $bot (keys %{$rb->{bots}}) {
         $rb->{bots}->{$bot}->{client}->signout();
      }

      system ("start Chatbots.bat");
      exit;
   }
}


RainbowBoi::Chat::Client (TCP chat client interface)
Code:
package RainbowBoi::Chat::Client;

use strict;
use warnings;
use IO::Socket;
use IO::Select;
use Digest::MD5 qw(md5_hex);

our $VERSION = '0.2';

sub new {
   my $proto = shift;
   my $class = ref($proto) || $proto || 'RainbowBoi::Chat::Client';

   my $self = {
      host    => 'rainbowboi.com',
      port    => 7775,
      debug   => 0,
      sock    => undef,
      select  => undef,
      refresh => 5, # 5 seconds
      nextping => 0,
      pong    => 0,
      tcpk    => 0,
      loop    => 0,
      lastmsg => 0,
      events  => {},
      nick    => '',
      pass    => '',
      session => '',
      who     => {},
      ignore  => {},
      @_,
   };

   bless ($self,$class);
   return $self;
}

sub send {
   my ($self,$data) = @_;

   # Send it.
   if (defined $self->{sock}) {
      print "C: $data\n" if ($self->{debug} == 1 && $data !~ /^ping/i);
      $self->{sock}->send ("$data\n");
   }
   else {
      warn "Could not send \"$data\" to RainbowBoi: connection not established!";
   }
}

sub setHandler {
   my ($self,$event,$code) = @_;

   # Set it.
   $self->{events}->{$event} = $code;
}

sub _event {
   my ($self,$event,@args) = @_;

   if (exists $self->{events}->{$event}) {
      return &{$self->{events}->{$event}} ($self,@args);
   }
   return 0;
}

sub connect {
   my $self = shift;

   # Connect.
   $self->{sock} = new IO::Socket::INET (
      PeerAddr => $self->{host},
      PeerPort => $self->{port},
      Proto    => 'tcp',
   ) or die "Connection Error: $!";

   $self->{select} = IO::Select->new ($self->{sock});
}

sub start {
   my ($self) = @_;

   while (1) {
      $self->do_one_loop or last;
   }
}

sub signin {
   my ($self,$name,$pass) = @_;

   $name = lc($name);

   # Encrypt the password.
   $pass = md5_hex ($pass);

   # Send a login request.
   $self->send ("LOGN|$name|$pass");
}

sub signout {
   my $self = shift;

   # Sign out.
   $self->send ("EXIT|$self->{session}");

   # Disconnect.
   $self->{sock}->close();
   $self->{select} = undef;
}

sub sendMessage {
   my ($self,$msg) = @_;

   # Send it.
   $self->send ("MESG|$self->{session}|$msg");
}

sub do_one_loop {
   my $self = shift;

   return unless defined $self->{select};

   if ($self->{loop} == 1) {
      if ($self->{nextping} == 0) {
         $self->{nextping} = time() + $self->{refresh};
      }

      if (time() - $self->{nextping} >= 0) {
         $self->send ("PING|$self->{session}|$self->{lastmsg}");
         $self->{nextping} = time() + $self->{refresh};
      }
   }

   # Loop with the server.
   my @ready = $self->{select}->can_read (.1);
   return unless(@ready);

   foreach my $socket (@ready) {
      my $resp;
      $self->{sock}->recv ($resp,3072,0);
      my @in = split(/\n/, $resp);

      # The server has sent something.
      foreach my $said (@in) {
         print "S: $said\n" if ($self->{debug} == 1 && $said !~ /^pong/i);

         my ($command,@args) = split(/\|/, $said);

         # Go through the commands.
         if ($command eq 'TCPK') {
            # Connection is ready.
            $self->{tcpk} = 1;
            $self->send ("CONN");
         }
         elsif ($command eq 'ACPT') {
            # CONN accepted.
            $self->_event ('ACPT');
         }
         elsif ($command eq 'ENTR') {
            # LOGN Accepted.
            $self->{session} = $args[0];
            $self->{nick}    = $args[1];
            $self->_event ('ENTR');
         }
         elsif ($command eq 'INTR') {
            # Intro message.
            $self->_event ('INTR',@args);
         }
         elsif ($command eq 'HELO') {
            # Lobby message.
            $self->_event ('HELO',@args);
            $self->{lastmsg} = $args[0] - 5;
            $self->{loop} = 1;
         }
         elsif ($command eq 'LIST') {
            # Who List.
            $self->_event ('LIST',@args);
         }
         elsif ($command eq 'MESG') {
            # A message.
            $self->{lastmsg} = $args[0];
            $self->_event ('MESG',@args);

            # Server?
            if ($args[1] eq 'server') {
               $self->send ('WHOL');
            }
         }
         elsif ($command eq 'PONG') {
            # We have a pong.
            $self->{pong} = time();
         }
         elsif ($command eq 'EROR') {
            # An error.
            $self->_event ('EROR',@args);
         }
         else {
            warn "Unknown SERVER Command $command";
         }
      }
   }

   return 1;
}


Protocol Specs: http://www.aichaos.com/chatbeta/protocol.txt

If you need to see Server.pm you'll have to PM me, the inner workings of it are a secret. Wink

If anybody can offer any pointers for how to not have it devour so much CPU reply here. Smile
_________________
Current Site (2008) http://www.cuvou.com/
Back to top
alienz
Almost An Agent
Almost An Agent


Joined: 22 Mar 2004
Posts: 1436
Location: Mars
Reputation: 55.7
PostPosted: Sat Jan 07, 2006 6:53 pm    Post subject: Reply with quote
Might want to consider using POE for this since it can handle unused sockets and errors.
_________________
Check out Botworld! A dev resource for things bot.
Downloads, articles, news, fourm and more.
http://botworld.marzopolis.com
Back to top
Cer
Upgraded Agent
Upgraded Agent


Joined: 03 Feb 2004
Posts: 3776
Location: Michigan
Reputation: 146.9
votes: 4
PostPosted: Wed Jan 11, 2006 3:09 am    Post subject: Reply with quote
I did lots of debugging and found out what is the problem (or one of the problems)...

For some reason, the server wasn't being able to find out that a client disconnected. Like the "send message or disconnect" wasn't working. But what I narrowed it down to was, the recv command (to receive data from the socket) would continue to work but always return nothing on closed sockets.

I was trying to make a timeout that would update the socket's active time variable on each message, and after disconnecting the value of time - the active time was always 0, so I narrowed it down to... the server thought it was getting messages and always resetting the active time.

But anyway, long story short, I added an "or do" to the recv function, so when it receives an empty message it would disconnect the client. And it works! The CPU no longer spikes up anymore.

Here's the bit of that code:

Code:
# Read their request.
my $in = '';
$socket->recv ($in, 3072) or do {
   $select->remove ($users->{$id}->{sock});
   $users->{$id}->{sock}->close();

   print "\nRemoving socket $id (sent empty data)\n\n";

   delete $users->{$id};
};
chomp $in;

_________________
Current Site (2008) http://www.cuvou.com/
Back to top
alienz
Almost An Agent
Almost An Agent


Joined: 22 Mar 2004
Posts: 1436
Location: Mars
Reputation: 55.7
PostPosted: Wed Jan 11, 2006 11:02 pm    Post subject: Reply with quote
Nice KISS solution. I still prefer POE for this type of stuff rather than completely writing everything using sockets.
_________________
Check out Botworld! A dev resource for things bot.
Downloads, articles, news, fourm and more.
http://botworld.marzopolis.com
Back to top
mattaustin
Sentinel
Sentinel


Joined: 19 Jul 2004
Posts: 556
Location: Los Angeles, CA
Reputation: 50.7
votes: 1
PostPosted: Thu Jan 12, 2006 4:09 pm    Post subject: Reply with quote
I agree, POE handles the sockets the best in perl and once you understand it its pritty simple.
Back to top
Cer
Upgraded Agent
Upgraded Agent


Joined: 03 Feb 2004
Posts: 3776
Location: Michigan
Reputation: 146.9
votes: 4
PostPosted: Fri Jan 13, 2006 7:46 pm    Post subject: Reply with quote
I looked into some POE stuff and wrote a server using POE::Wheel:: modules and it all works great so far. One problem though is that the put() method seems to add a weird symbol at the end of every message sent.

The compiled chat client writes this in the system messages box (a.k.a. STDOUT and STDERR captor)
Code:
Unknown SERVER Command []
 at /PerlApp/RainbowBoi/Chat/Client.pm line 222.


(the [] is a box symbol). The moderator bots (just your normal Perl DOS windows) warned "Unknown SERVER Command " but didn't show any weird symbol.

I remedied that by putting a \n at the end of every put command, since the client is programmed to take the server messages line-by-line. So it gets the data it needs and then warns about the unknown command.

Other than that it works great (although the remote IP is encoded, I saw an example on what to do to get it readible so that's not much a problem)

Here's my new code:
Code:
#!/usr/bin/perl -w

use strict;
use warnings;
use Data::Dumper;
use RainbowBoi::Chat::Server;
use POE qw(Wheel::SocketFactory Wheel::ReadWrite);

# Create the server object.
our $server = new RainbowBoi::Chat::Server (debug => 0);
require "subroutines.pl";

our $users = {}; # Connections

# Start the server.
POE::Session->create (
   inline_states => {
      _start => \&server_start,
      server_accepted => \&server_accepted,
      server_error    => \&server_error,
      client_input    => \&client_input,
      client_error    => \&client_error,
   },
);

POE::Kernel->run();
exit;

# Start the TCP server at port 7775
sub server_start {
   my $heap = $_[HEAP];

   $heap->{server} = POE::Wheel::SocketFactory->new (
      BindAddress  => 'rainbowboi.com',
      BindPort     => 7775,
      SuccessEvent => 'server_accepted',
      FailureEvent => 'server_error',
   );

   print "Server started.\n\n";
}

# Handle connections from clients.
sub server_accepted {
   my $client_socket = $_[ARG0];
   my $ipaddr        = $_[ARG1];

   my $wheel = POE::Wheel::ReadWrite->new (
      Handle     => $client_socket,
      InputEvent => 'client_input',
      ErrorEvent => 'client_error',
   );

   # Create this user's data.
   $users->{ $wheel->ID() } = {
      conn => 0,
      logn => 0,
      nick => undef,
      active => time() + 5,
      ip   => $ipaddr,
   };

   print ":: " . $wheel->ID() . " connected from $ipaddr\n";

   $wheel->put ("TCPK\n");

   $_[HEAP]->{client}->{ $wheel->ID() } = $wheel;
}

# Handle messages received from the clients.
sub client_input {
   my ($heap, $input, $wheel_id) = @_[HEAP, ARG0, ARG1];
   chomp $input;

   print "C$wheel_id: $input\n" unless $input =~ /^ping/i;

   # Get this user's IP.
   my $ip = $users->{$wheel_id}->{ip};

   # Send the message into the server.
   my $response = $server->message ($input, $ip);

   print "S: $response\n" unless $response =~ /^pong/i;

   # Send its reply.
   $heap->{client}->{$wheel_id}->put ("$response\n");
}

# Handle errors in the client socket.
sub client_error {
   my ($heap, $operation, $code, $error, $wheel) = @_[HEAP, ARG0..ARG3];
   warn "Wheel $wheel generated $operation error $code: $error\n";
   delete $users->{$wheel};
   delete $heap->{client}->{$wheel};
}

# Handle server errors
sub server_error {
   my ($operation,$code,$error,$wheel) = @_[ARG0..ARG3];
   warn "Wheel $wheel generated $operation error $code: $error\n";
   delete $_[HEAP]->{server};
}

_________________
Current Site (2008) http://www.cuvou.com/
Back to top
alienz
Almost An Agent
Almost An Agent


Joined: 22 Mar 2004
Posts: 1436
Location: Mars
Reputation: 55.7
PostPosted: Fri Jan 13, 2006 7:52 pm    Post subject: Reply with quote
Besides using the Wheels component, you can also create a simple chat server without it. Here's an example from the POE Cookbook:

http://poe.perl.org/?POE_Cookbook/Chat_Server
_________________
Check out Botworld! A dev resource for things bot.
Downloads, articles, news, fourm and more.
http://botworld.marzopolis.com
Back to top
Display posts from previous:   
Post new topic   Reply to topic    Bot Depot Forum Index -> Perl All times are GMT
Page 1 of 1

 



Protected by phpBB Security phpBB-TweakS
phpBB Security Has Blocked 9 Exploit Attempts.
Antispam Captcha Mod by phpbb-security.com
Powered by phpBB © 2001, 2005 phpBB Group