EasyTCP
view release on metacpan or search on metacpan
if (!$@) {
if ($_->[1] eq 'Crypt::CBC') {
$hasCBC = 1;
}
elsif (($hasCBC && $_->[2]) || !$_->[2]) {
push(@{ $_ENCRYPT_AVAILABLE{_order} }, $_->[0]);
$_ENCRYPT_AVAILABLE{ $_->[0] }{name} = $_->[1];
$_ENCRYPT_AVAILABLE{ $_->[0] }{cbc} = $_->[2];
$_ENCRYPT_AVAILABLE{ $_->[0] }{mergewithpassword} = $_->[3];
$_ENCRYPT_AVAILABLE{ $_->[0] }{version} = $version;
}
}
}
#
# Now we check the misc array for existing modules
#
foreach (@_misc_modules) {
$@ = undef;
eval {
eval("require $_->[1];") || die "$_->[1] not found\n";
$version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n";
};
if (!$@) {
push(@{ $_MISC_AVAILABLE{_order} }, $_->[0]);
$_MISC_AVAILABLE{ $_->[0] }{name} = $_->[1];
$_MISC_AVAILABLE{ $_->[0] }{version} = $version;
}
}
}
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
$VERSION = '0.26';
$PACKETSIZE = 4096;
#
# POD DOCUMENTATION:
#
=head1 NAME
Net::EasyTCP - Easily create secure, bandwidth-friendly TCP/IP clients and servers
=head1 FEATURES
=over 4
=item *
One easy module to create both clients and servers
=item *
Object Oriented interface
=item *
Event-based callbacks in server mode
=item *
Internal protocol to take care of all the common transport problems
=item *
Transparent encryption
=item *
Transparent compression
=back
=head1 SYNOPSIS
=over 4
=item SERVER EXAMPLE:
use Net::EasyTCP;
#
# Create the server object
#
$server = new Net::EasyTCP(
mode => "server",
port => 2345,
)
|| die "ERROR CREATING SERVER: $@\n";
#
# Tell it about the callbacks to call
# on known events
#
$server->setcallback(
data => \&gotdata,
connect => \&connected,
disconnect => \&disconnected,
)
|| die "ERROR SETTING CALLBACKS: $@\n";
#
# Start the server
#
$server->start() || die "ERROR STARTING SERVER: $@\n";
#
# This sub gets called when a client sends us data
#
sub gotdata {
my $client = shift;
my $serial = $client->serial();
my $data = $client->data();
print "Client $serial sent me some data, sending it right back to them again\n";
$client->send($data) || 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";
}
}
#
# This sub gets called when a new client connects
#
sub connected {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just connected\n";
}
#
# This sub gets called when an existing client disconnects
#
sub disconnected {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just disconnected\n";
}
=item CLIENT EXAMPLE:
use Net::EasyTCP;
#
# Create a new client and connect to a server
#
$client = new Net::EasyTCP(
mode => "client",
host => 'localhost',
port => 2345,
=item donotcompress
Set to 1 to forcefully disable L<compression|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found.
(Optional)
=item donotcompresswith
Set to a scalar or an arrayref of compression module(s) you'd like to avoid compressing with. For example, if you do not want to use Compress::LZF, you can do so by utilizing this option.
(Optional)
=item donotencrypt
Set to 1 to forcefully disable L<encryption|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found.
(Optional)
=item donotencryptwith
Set to a scalar or an arrayref of encryption module(s) you'd like to avoid encrypting with. For example, Crypt::RSA takes a long time to initialize keys and encrypt/decrypt, so you can avoid using it by utilizing this option.
(Optional)
=item host
Must be set to the hostname/IP address to connect to.
(Mandatory when mode is "client")
=item mode
Must be set to either "client" or "server" according to the type of object you want returned.
(Mandatory)
=item password
Defines a password to use for the connection. When mode is "server" this password will be required from clients before the full connection is accepted . When mode is "client" this is the password that the server connecting to requires.
Also, when encryption using a symmetric encryption module is used, this password is included as part of the secret "key" for encrypting the data.
(Optional)
=item port
Must be set to the port the client connects to (if mode is "client") or to the port to listen to (if mode is "server"). If you're writing a client+server pair, they must both use the same port number.
(Mandatory)
=item timeout
Set to an integer (seconds) that a client attempting to establish a TCP/IP connection to a server will timeout after. If not supplied, the default is 30 seconds. (Optional and acceptable only when mode is "client")
=item welcome
If someone uses an interactive telnet program to telnet to the server, they will see this welcome message.
(Optional and acceptable only when mode is "server")
=back
=back
=head1 METHODS
B<[C] = Available to objects created as mode "client">
B<[H] = Available to "hybrid" client objects, as in "the server-side client objects created when a new client connects". These are the objects passed to your server's callbacks. Such hybrid clients behave almost exactly like a normal "client" object...
B<[S] = Available to objects created as mode "server">
=over 4
=item addclientip(@array)
B<[S]> Adds an IP address (or IP addresses) to the list of allowed clients to a server. If this is done, the server will not accept connections from clients not in it's list.
The compliment of this function is deleteclientip() .
=item callback(%hash)
See setcallback()
=item clients()
B<[S]> Returns all the clients currently connected to the server. If called in array context will return an array of client objects. If called in scalar context will return the number of clients connected.
=item close()
B<[C][H]> Instructs a client object to close it's connection with a server.
=item compression()
B<[C][H]> Returns the name of the module used as the compression module for this connection, undef if no compression occurs.
=item data()
B<[H]> Retrieves the previously-retrieved data associated with a hybrid client object. This method is typically used from inside the callback sub associated with the "data" event, since the callback sub is passed nothing more than a client object.
=item deleteclientip(@array)
B<[S]> Deletes an IP address (or IP addresses) from the list of allowed clients to a server. The IP address (or IP addresses) supplied will no longer be able to connect to the server.
The compliment of this function is addclientip() .
=item disconnect()
See close()
=item do_one_loop()
B<[S]> Instructs a server object to "do one loop" and return ASAP. This method needs to be called VERY frequently for a server object to function as expected (either through some sort of loop inside your program if you need to do other things beside...
=item encryption()
B<[C][H]> Returns the name of the module used as the encryption module for this connection, undef if no encryption occurs.
=item mode()
B<[C][H][S]> Identifies the mode of the object. Returns either "client" or "server"
=item receive($timeout)
B<[C]> Receives data sent to the client by a server and returns it. It will block until data is received or until a certain timeout of inactivity (no data transferring) has occurred.
It accepts an optional parameter, a timeout value in seconds. If none is supplied it will default to 300.
=item remoteip()
B<[C][H]> Returns the IP address of the host on the other end of the connection.
=item remoteport()
B<[C][H]> Returns the port of the host on the other end of the connection.
=item running()
B<[S]> Returns true if the server is running (started), false if it is not.
=item send($data)
B<[C][H]> Sends data to a server. It can be used on client objects you create with the new() constructor, clients objects returned by the clients() method, or with client objects passed to your callback subs by a running server.
It accepts one parameter, and that is the data to send. The data can be a simple scalar or a reference to something more complex.
=item serial()
B<[H]> Retrieves the serial number of a client object, This is a simple integer that allows your callback subs to easily differentiate between different clients.
=item setcallback(%hash)
B<[S]> Tells the server which subroutines to call when specific events happen. For example when a client sends the server data, the server calls the "data" callback sub.
setcallback() expects to be passed a hash. Each key in the hash is the callback type identifier, and the value is a reference to a sub to call once that callback type event occurs.
Valid keys in that hash are:
=over 4
=item connect
Called when a new client connects to the server
=item data
Called when an existing client sends data to the server
=item disconnect
Called when an existing client disconnects
=back
Whenever a callback sub is called, it is passed a single parameter, a CLIENT OBJECT. The callback code may then use any of the methods available to client objects to do whatever it wants to do (Read data sent from the client, reply to the client, clo...
=item socket()
B<[C][H]> Returns the handle of the socket (actually an L<IO::Socket|IO::Socket> object) associated with the supplied object. This is useful if you're interested in using L<IO::Select|IO::Select> or select() and want to add a client object's socket ...
Note that eventhough there's nothing stopping you from reading and writing directly to the socket handle you retrieve via this method, you should never do this since doing so would definately corrupt the internal protocol and may render your connecti...
=item start(subref)
B<[S]> Starts a server and does NOT return until the server is stopped via the stop() method. This method is a simple while() wrapper around the do_one_loop() method and should be used if your entire program is dedicated to being a server, and does ...
If you need to concurrently do other things when the server is running, then you can supply to start() the optional reference to a subroutine (very similar to the callback() method). If that is supplied, it will be called every loop. This is very s...
=item stop()
B<[S]> Instructs a running server to stop and returns immediately (does not wait for the server to actually stop, which may be a few seconds later). To check if the server is still running or not use the running() method.
=back
=head1 COMPRESSION AND ENCRYPTION
Clients and servers written using this class will automatically compress and/or encrypt the transferred data if the appropriate modules are found.
Compression will be automatically enabled if one (or more) of: L<Compress::Zlib|Compress::Zlib> or L<Compress::LZF|Compress::LZF> are installed on both the client and the server.
As-symmetric encryption will be automatically enabled if L<Crypt::RSA|Crypt::RSA> is installed on both the client and the server.
Symmetric encryption will be automatically enabled if one (or more) of: L<Crypt::Rijndael|Crypt::Rijndael>* or L<Crypt::RC6|Crypt::RC6>* or L<Crypt::Blowfish|Crypt::Blowfish>* or L<Crypt::DES_EDE3|Crypt::DES_EDE3>* or L<Crypt::DES|Crypt::DES>* or L<C...
Strong randomization will be automatically enabled if L<Crypt::Random|Crypt::Random> is installed; otherwise perl's internal rand() is used to generate random keys.
Preference to the compression/encryption method used is determind by availablity checking following the order in which they are presented in the above lists.
Note that during the negotiation upon connection, servers and clients written using Net::EasyTCP version lower than 0.20 communicated the version of the selected encryption/compression modules. If a version mismatch is found, the client reported a c...
To find out which module(s) have been negotiated for use you can use the compression() and encryption() methods.
* Note that for this class's purposes, L<Crypt::CBC|Crypt::CBC> is a requirement to use any of the encryption modules with a * next to it's name in the above list. So eventhough you may have these modules installed on both the client and the server,...
* Note that the nature of symmetric cryptography dictates sharing the secret keys somehow. It is therefore highly recommend to use an As-symmetric cryptography module (such as Crypt::RSA) for serious encryption needs; as a determined hacker might fi...
* Note that if symmetric cryptography is used, then it is highly recommended to also use the "password" feature on your servers and clients; since then the "password" will, aside from authentication, be also used in the "secret key" to encrypt the d...
If the above modules are installed but you want to forcefully disable compression or encryption, supply the "donotcompress" and/or "donotencrypt" keys to the new() constructor. If you would like to forcefully disable the use of only some modules, su...
=head1 RETURN VALUES AND ERRORS
The constructor and all methods return something that evaluates to true when successful, and to false when not successful.
There are a couple of exceptions to the above rule and they are the following methods:
=over 4
=item *
clients()
=item *
data()
=back
The above methods may return something that evaluates to false (such as an empty string, an empty array, or the string "0") eventhough there was no error. In that case check if the returned value is defined or not, using the defined() Perl function.
If not successful, the variable $@ will contain a description of the error that occurred.
=head1 NOTES
=over 4
=item Incompatability with Net::EasyTCP version 0.01
Version 0.02 and later have had their internal protocol modified to a fairly large degree. This has made compatability with version 0.01 impossible. If you're going to use version 0.02 or later (highly recommended), then you will need to make sure ...
=item Internal Protocol
This class implements a miniature protocol when it sends and receives data between it's clients and servers. This means that a server created using this class cannot properly communicate with a normal client of any protocol (pop3/smtp/etc..) unless ...
In other words, if you write a server using this class, write the client using this class also, and vice versa.
=item Delays
This class does not use the fork() method whatsoever. This means that all it's input/output and multi-socket handling is done via select().
This leads to the following limitation: When a server calls one of your callback subs, it waits for it to return and therefore cannot do anything else. If your callback sub takes 5 minutes to return, then the server will not be able to do anything ...
In other words, make the code in your callbacks' subs' minimal and strive to make it return as fast as possible.
=item Deadlocks
As with any client-server scenario, make sure you engineer how they're going to talk to each other, and the order they're going to talk to each other in, quite carefully. If both ends of the connection are waiting for the other end to say something,...
=back
=head1 AUTHOR
Mina Naguib
http://www.topfx.com
mnaguib@cpan.org
=head1 SEE ALSO
Perl(1), L<IO::Socket>, L<IO::Select>, L<Compress::Zlib>, L<Compress::LZF>, L<Crypt::RSA>, L<Crypt::CBC>, L<Crypt::Rijndael>, L<Crypt::RC6>, L<Crypt::Blowfish>, L<Crypt::DES_EDE3>, L<Crypt::DES>, L<Crypt::Twofish2>, L<Crypt::Twofish>, L<Crypt::TEA>, ...
=head1 COPYRIGHT
Copyright (C) 2001-2003 Mina Naguib. All rights reserved. Use is subject to the Perl license.
=cut
#
# The main constructor. This calls either _new_client or _new_server depending on the supplied mode
#
sub new {
my $class = shift;
my %para = @_;
# Let's lowercase all keys in %para
foreach (keys %para) {
if ($_ ne lc($_)) {
$para{ lc($_) } = $para{$_};
delete $para{$_};
}
}
if ($para{mode} =~ /^c/i) {
return _new_client($class, %para);
}
elsif ($para{mode} =~ /^s/i) {
return _new_server($class, %para);
}
else {
$@ = "Supplied mode '$para{mode}' unacceptable. Must be either 'client' or 'server'";
return undef;
}
}
#
# Make callback() a synonim to setcallback()
#
sub callback {
return setcallback(@_);
}
#
# This method adds an ip address(es) to the list of valid IPs a server can accept connections
# from.
#
sub addclientip {
my $self = shift;
my @ips = @_;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method addclientip()";
return undef;
}
foreach (@ips) {
$self->{_clientip}{$_} = 1;
}
return 1;
}
#
# This method does the opposite of addclient(), it removes an ip address(es) from the list
# of valid IPs a server can accept connections from.
#
sub deleteclientip {
my $self = shift;
my @ips = @_;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method deleteclientip()";
return undef;
}
foreach (@ips) {
delete $self->{_clientip}{$_};
}
return 1;
}
#
#
# This method modifies the _callback_XYZ in a server object. These are the routines
# the server calls when an event (data, connect, disconnect) happens
#
sub setcallback {
my $self = shift;
my %para = @_;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method setcallback()";
return undef;
}
foreach (keys %para) {
if (ref($para{$_}) ne "CODE") {
$@ = "Callback $_ $para{$_} does not exist";
return 0;
}
$self->{_callbacks}->{$_} = $para{$_};
}
return 1;
}
#
# This method starts the server and does not return until stop() is called.
# All other behavior is delegated to do_one_loop()
#
sub start {
my $self = shift;
my $callback = shift;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method start()";
return undef;
}
$self->{_running} = 1;
$self->{_requeststop} = 0;
#
# Let's loop until we're stopped:
#
while (!$self->{_requeststop}) {
$self->do_one_loop() || return undef;
if ($callback && ref($callback) eq "CODE") {
&{$callback}($self);
}
}
#
# If we reach here the server's been stopped
#
$self->{_running} = 0;
$self->{_requeststop} = 0;
return 1;
}
#
# This method does "one loop" of server work and returns ASAP
# It should be called very frequently, either through a while() loop in the program
# or through the start() method
#
# It accepts new clients, accepts data from them, and fires off any callback events as necessary
#
sub do_one_loop {
my $self = shift;
my @ready;
my $clientsock;
my $tempdata;
my $serverclient;
my $realdata;
my $result;
my $negotiatingtimeout = 45;
my $peername;
my $remoteport;
my $remoteip;
if ($self->{_mode} ne "server") {
$@ = "$self->{_mode} cannot use method do_one_loop()";
return undef;
}
#
# The SERVER SOCKET is ready for accepting a new client
#
$clientsock = $self->{_sock}->accept();
if (!$clientsock) {
$@ = "Error while accepting new connection: $!";
return undef;
}
#
# We get remote IP and port, we'll need them to see if client is allowed or not
#
$peername = getpeername($clientsock) or next;
($remoteport, $remoteip) = sockaddr_in($peername) or next;
$remoteip = inet_ntoa($remoteip) or next;
#
# We create a new client object and
# We see if client is allowed to connect to us
#
if (scalar(keys %{ $self->{_clientip} }) && !$self->{_clientip}{$remoteip}) {
#
# Client's IP is not allowed to connect to us
#
close($clientsock);
}
else {
#
# We add it to our SELECTOR pool :
#
$self->{_selector}->add($clientsock);
#
# We create a new client object:
#
$self->{_clients}->{$clientsock} = _new_client(
$self,
"_sock" => $clientsock,
"_remoteport" => $remoteport,
"_remoteip" => $remoteip
);
#
# We initialize some client variables:
#
$self->{_clients}->{$clientsock}->{_serial} = ++$_SERIAL;
$self->{_clients}->{$clientsock}->{_compatabilityscalar} = _genrandstring(129);
$self->{_clients}->{$clientsock}->{_compatabilityreference} = _gencompatabilityreference($self->{_clients}->{$clientsock}->{_compatabilityscalar});
#
# And we make it inherit some stuff from the server :
#
$self->{_clients}->{$clientsock}->{_donotencrypt} = $self->{_donotencrypt};
$self->{_clients}->{$clientsock}->{_donotencryptwith} = $self->{_donotencryptwith};
$self->{_clients}->{$clientsock}->{_donotcompress} = $self->{_donotcompress};
$self->{_clients}->{$clientsock}->{_donotcompresswith} = $self->{_donotcompresswith};
$self->{_clients}->{$clientsock}->{_password} = $self->{_password};
$self->{_clients}->{$clientsock}->{_callbacks} = $self->{_callbacks};
$self->{_clients}->{$clientsock}->{_welcome} = $self->{_welcome};
$self->{_clients}->{$clientsock}->{_selector} = $self->{_selector};
}
}
else {
#
# One of the CLIENT sockets are ready
#
$result = sysread($_, $tempdata, $PACKETSIZE);
$serverclient = $self->{_clients}->{$_};
if (!defined $result) {
#
# Error somewhere during reading from that client
#
_callback($serverclient, "disconnect");
$serverclient->close();
delete $self->{_clients}->{$_};
}
elsif ($result == 0) {
#
# Client closed connection
#
_callback($serverclient, "disconnect");
$serverclient->close();
delete $self->{_clients}->{$_};
}
else {
#
# Client sent us some good data (not necessarily a full packet)
#
$serverclient->{_databuffer} .= $tempdata;
#
# Extract as many data buckets as possible out of the buffer
#
_extractdata($serverclient);
#
# Process all this client's data buckets
#
foreach (@{ $serverclient->{_databucket} }) {
if ($_->{realdata}) {
#
# This bucket is normal data
#
_callback($serverclient, "data");
}
else {
#
# This bucket is internal data
#
_parseinternaldata($serverclient);
}
}
# This takes any string and returns it in ascii format
#
sub _bin2asc {
my $data = shift;
$data =~ s/(.)/ '%' . sprintf('%02x',ord($1)) /ges;
$data = uc($data);
return $data;
}
#
# This does the opposite of _bin2asc
#
sub _asc2bin {
my $data = shift;
$data =~ s/\%([0-9A-F]{2})/ sprintf("%c",hex($1)) /ges;
return $data;
}
#
# This does very very primitive 2-way encryption & decryption (kinda like ROT13.. works both ways)
# Takes a client and a string, returns the enc/dec/rypted string
#
# This encryption is used to protect the encrypted password and the public key transmitted over the wire
# It's a last resort of security in case none of the encryption modules were found
#
sub _munge {
my $client = shift || return undef;
my $data = shift;
my ($c, $t);
#
# Munge's tricky because is existed on and off in different versions
#
if (defined $data && ($client->{_version} == 0.07 || $client->{_version} == 0.08 || $client->{_version} >= 0.15)) {
#
# Peer supports munge
#
for (0 .. length($data) - 1) {
$c = substr($data, $_, 1);
$t = vec($c, 0, 4);
vec($c, 0, 4) = vec($c, 1, 4);
vec($c, 1, 4) = $t;
substr($data, $_, 1) = $c;
}
$data = reverse($data);
}
else {
# Our peer doesn't munge, so we won't either
}
return $data;
}
#
# This takes a client object and a callback keyword and calls back the associated sub if possible
#
sub _callback {
my $client = shift;
my $type = shift;
if (!$client->{_negotiating} && $client->{_callbacks}->{$type}) {
&{ $client->{_callbacks}->{$type} }($client);
}
}
#
# This sub takes a scalar key
# Returns a reference to a compatability compex object made up of repeating
# the scalar in different combinations
#
sub _gencompatabilityreference {
my $key = shift;
return [
$key,
{
$key => $key,
$key => $key,
},
[ $key, { $key => $key, }, $key, ],
];
}
#
# This takes in an encryption key id and an optional "forcompat" boolean flag
# Generates a keypair (public, private) and returns them according to the type of encryption specified
# Returns undef on error
# The 2 returned keys are guaranteed to be: 1. Scalars and 2. Null-character-free. weather by their nature, or serialization or asci-fi-cation
# If "forcompat" is not specified and there are already a keypair for the specified module stored globally,
# it will return that instead of generating new ones.
# If "forcompat" is supplied, you're guaranteed to receive a new key that wasn't given out in the past to
# non-compat requests. It may be a repeat of a previous "forcompat" pair. However, the strength of that key
# could be possibly reduced. Such keys are safe to reveal the private portion of publicly, as during the
# compatability negotiation phase, however such keys must NEVER be used to encrypt any real data, as they
# are no longer secret.
#
sub _genkey {
my $modulekey = shift;
my $forcompat = shift;
my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name};
my $key1 = undef;
my $key2 = undef;
my $temp;
$@ = undef;
if (!$forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey}) {
$key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey};
$key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey};
}
elsif ($forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey}) {
$key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey};
$key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey};
}
elsif ($module eq 'Crypt::RSA') {
eval {
$temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for key generation: $! $@\n";
($key1, $key2) = $temp->keygen(
Size => 512,
Verbosity => 0,
)
or die "Failed to create RSA keypair: " . $temp->errstr() . "\n";
};
if ($key1 && $key2) {
$key1 = _bin2asc(nfreeze($key1));
( run in 0.891 second using v1.01-cache-2.11-cpan-39bf76dae61 )