Hi,
I originally developed this to use in a scrabble game clone,
which can be played over a network.
This is just the tcp connection, and I've modified it to just run as
a chat server client.
It use Net::EasyTCP which supports various encryption options,
and will auto-negotiate the connection depending on what encryption you
have available. It supports Crypt::RSA (asymmetric public key) which is
the most secure, but there is a performance hit, waiting for keys to be
exchanged and setup; so I've disabled it. But feel free to test it out
yourself.
The symmetric encryption defaults to Crypt::Rijndael (amoung others),
which also needs Crypt::CBC to run. I know Rijndael has a compiled c
component, so I can't say if it will run on windows.
I made it simple, so it's easy to understand, and it could be customized
quite abit, like different colors for each user, file transfer, and
other little details. So consider this just a "proof of concept".
There is a server, which contains the user-password pairs, which must be
started first. Then the clients. You can start as many as you want, but
Net::EasyTCP probably has limits. I can run 4 at a time, with no
problem.
SERVER:
####################################################
#!/usr/bin/perl
use warnings;
use strict;
use Net::EasyTCP;
$|=1;
my $debug = 0; # set to 1 for verbose server messages
local $SIG{INT} = sub { close LOG;print "Exiting\n";exit 0;};
print "Hit control-c to stop server\n";
my @nocrypt = qw(Crypt::RSA); #too slow, but more secure
#my @nocompress = qw(Compress::LZF); #just testing
my $host = "localhost";
my $port = "2345";
my $portpassword = "tkscrabble";
my $logdir = 'logs';
my %okusers = (user1 => '1',
user2 => '2',
user3 => '3',
user4 => '4',
test => 'test',
joe => 'zzzz',
);
my %clients;
if (! -d $logdir) {
mkdir($logdir,0755) ;
print "Log directory created: $logdir\n" ;
}
my $logname = "port_$port-".&gettime.'.log'; #try to give a unique na
+me
open (LOG,">>$logdir/$logname")
or die "Couldn't open port $port log: $!";
my $server = new Net::EasyTCP(
host => "localhost",
mode => "server",
port => $port,
password => $portpassword, # if using asymmetric encryption,
# port password gives better security
donotencryptwith => \@nocrypt,
# donotencrypt => 1,
# donotcompresswith => \@nocompress,
# donotcompress => 1,
)
|| die "ERROR CREATING SERVER: $@\n";
$server->setcallback(
data => \&gotdata,
connect => \&connected,
disconnect => \&disconnected,
)
|| die "ERROR SETTING CALLBACKS: $@\n";
$server->start() || die "ERROR STARTING SERVER: $@\n";
####################################################
sub gotdata() {
my $client = shift;
print "client->$client\n" if $debug;
my $serial = $client->serial();
my $data = $client->data();
my $reply;
#logon
if(! defined $clients{$serial}{'username'}){
my $user = $data->{'user'};
print "user->$user\n" if $debug;
my $pass = $data->{'pass'};
print "pass->$pass\n" if $debug;
$reply = &process_user($user,$pass,$serial,$client);
print "$reply\n" if $debug;
$client->send($reply);
}
#logged in here
print " $serial->$data\n" if $debug;
print "$clients{$serial}{'username'}->$data\n" if $debug;
foreach my $sernum( keys %clients){
if(defined $clients{$sernum}{'socket'}){
$clients{$sernum}{'socket'}->send("$clients{$serial}{'username'}->$dat
+a\n")
|| die "ERROR SENDING TO CLIENT: $@\n";
}
}
if ($data eq "QUIT") {
$client->close() || die "ERROR CLOSING CLIENT: $@\n";
}
elsif ($data eq "DIE") {
$server->stop() || die "ERROR STOPPING SERVER: $@\n";
}
}
#####################################################
sub connected() {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just connected\n";
print LOG "Client $serial just connected at ",gettime(),"\n";
$client->send('LOGIN') || die "ERROR SENDING LOGIN TO CLIENT: $@\n";
}
###################################################
sub disconnected() {
my $client = shift;
my $serial = $client->serial();
print "$clients{$serial}{'username'} just disconnected\n";
print LOG "$clients{$serial}{'username'} just disconnected at
",&gettime,"\n";
foreach my $sernum( keys %clients){
if(defined $clients{$sernum}{'socket'}){
$clients{$sernum}{'socket'}->send("$clients{$serial}{'username'}->Has
Logged Out\n")
|| die "ERROR SENDING TO CLIENT: $@\n";
}
}
delete $clients{$serial}{'username'};
delete $clients{$serial}{'socket'};
delete $clients{$serial};
}
###########################################################
sub process_user{
my ($user,$pass,$serial,$client) = @_;
print "proceesing $user $pass\n" if $debug;
my $reply;
my $time = gettime();
if((! defined $okusers{$user}) or ($pass ne $okusers{$user}))
{ print LOG "BADPASSWORD $user $pass $time\n"; LOG->flush;
$reply = "ERROR1: user or password id bad\n";
return $reply;
}
$reply = "OK-SEND->$user";
print "$reply\n";
print LOG "$reply at $time\n"; LOG->flush;
$clients{$serial}{'username'} = $user;
$clients{$serial}{'socket'} = $client;
print "$reply\n" if $debug;
return $reply;
}
#####################################################
sub gettime{
my $date_string = localtime;
$date_string =~ tr/ /_/;
return $date_string;
}
######################################################3
__END__
CLIENT
#####################################################
#!/usr/bin/perl
use warnings;
use strict;
use Net::EasyTCP;
use Tk;
use Tk::ROText;
use IO::Select;
# create the socket
my $user = 'user1';
my $pass = 1;
my $host = "localhost";
my $port = "2345";
my $portpassword = "tkscrabble";
my %hash; #global used for sending data
my $sendmode = 0; #flag to switch between send and receive mode
my $client = new Net::EasyTCP(
mode => "client",
host => 'localhost',
port => $port,
password => $portpassword
) || die "ERROR CREATING CLIENT: $@\n";
my $encrypt = $client->encryption();
my $compress = $client->compression();
my $socket = $client->socket();
my $sel = new IO::Select($socket);
my $reply;
my $mw = new MainWindow(-background => 'lightsteelblue');
my $rotext = $mw->Scrolled('ROText', -scrollbars=>'ose',
-background => 'black',
-foreground => 'lightyellow',
)->pack;
&displayit($rotext ,"encryption method ->$encrypt\ncompression method
->$compress\n");
my $ent = $mw->Entry()->pack(qw/-fill x -pady 5/);
$mw->Button(-text =>'Disconnect',
-command =>sub{$client->close();Tk::exit },
-background => 'pink',
-activebackground => 'hotpink',
)->pack();
$mw ->bind('<Any-Enter>' => sub { $ent->Tk::focus });
$ent->bind('<Return>' => [\&broadcast, $client]);
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
if($reply eq 'LOGIN'){ &logon }
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
$mw->repeat(11, sub {
while($sel->can_read(.01)) {
my $reply = $client->receive();
&displayit($rotext, $reply);
}
});
MainLoop;
##############################################################
sub broadcast {
my ($ent, $client) = @_;
my $text = $ent->get;
$ent->delete(qw/0 end/);
$client->send($text);
}
##############################################################
sub displayit {
my ($rotext,$data) = @_;
$rotext->insert('end',$data);
$rotext->see('end');
}
###############################################################
sub logon{
# this section checks user and password
# it exits when an OK-SEND-> is received
while(1){
$hash{'user'} = $user;
$hash{'pass'} = $pass;
my $reply = &sendhash();
print "$reply\n";
if($reply =~ /^OK-SEND->(.*)/){last}
}
}
###############################################################
#################################################################
sub sendhash{
$client->send(\%hash) || die "ERROR SENDING: $@\n";
my $reply = $client->receive() || die "ERROR RECEIVING: $@\n";
return $reply;
}
################################################################
__END__
