Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
PerlMonks  

Sockets-File-Upload with Net::EasyTCP

by zentara (Archbishop)
on Sep 17, 2002 at 22:47 UTC ( #198680=sourcecode: print w/ replies, xml ) Need Help??

Category: Networking
Author/Contact Info zentara
Description: This is a client server set of programs. The client can upload files to the server on a port of your choosing using Net::EasyTCP. It compresses and encrypts the transfer, has a "port-password" and checks user and password. It logs transfers and bad password attempts. The one thing I noticed with Net::EasyTCP, is that it defaults to RSA encryption if found, and is very slow. If you edit the EasyTCP.pm , and comment out the hash entry for RSA, it will switch to Rijndael, and is very fast. You can see where to add user-password pairs in %okusers.
#!/usr/bin/perl
#  this is the server
use warnings;
use strict;
use Net::EasyTCP;

$|=1;

local $SIG{INT} = sub { close LOG;print "Exiting\n";exit 0;};
print "Hit control-c to stop server\n";

my $host = "localhost";
my $port = "2345";
my $portpassword = "ztest";
my $maxsize = 1000000; #1 meg 
my $savedir = 'files';
my %okusers = (joe => "loco",
               zentara => "majormojo",
               test =>  "test" );



if (! -d $savedir) {
    mkdir($savedir,0755) ;
    print "Save directory created: $savedir\n" ;
}

open(LOG,">>$savedir/port$port.log") or die "Couldn't open port $port 
+log: $!";

my $server = new Net::EasyTCP(
    host  =>  "$host",
    mode  =>  "server",
    port  =>   "$port",
    password => "$portpassword",
    )
       || 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;
my $serial = $client->serial();
my $data = $client->data();

my $reply1 = undef;
my $reply;
my $user = $data->{'user'};
my $pass = $data->{'pass'};
my $filename = $data->{'filename'};
my $filesize = $data->{'filesize'};
my $filedata = $data->{'filedata'};
if((defined $filedata) and (length $filedata >= $maxsize)){
            print LOG "ERROR5: Large File trying to sneak in\n";
            $reply1 = "ERROR5: $filename is greater than $maxsize byte
+s\n";
            LOG->flush;
            }

if(! defined $filedata){$reply = &process_user($user,$pass)}
else {$reply = $reply1 || &process_file($user,$filename,$filesize,$fil
+edata)}


print "Client $serial sent: $data  echoing status-> $reply\n";

$client->send($reply) || 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 process_file{
my ($user,$filename,$filesize,$filedata) = @_;
my $reply;

if(-e "$savedir/$filename")
        { return $reply = "ERROR2: $filename already exists, please al
+ter name\n"}
if($filesize > $maxsize)
        { return $reply = "ERROR3: $filename is greater than $maxsize 
+bytes\n"}
if($filedata eq -1){return $reply = "OK-FILE->SEND\n"}

open(FILEIN,">$savedir/$filename") or 
          return $reply = "ERROR4: Could not create $filename: $!";
print FILEIN $filedata;
close FILEIN;

my $size = -s "$savedir/$filename";
$reply = "SUCCESS-> $filename $size bytes uploaded ";
my $time = localtime();
print LOG "$reply by $user at $time\n";
LOG->flush;
return "$reply\n";
}
########################################################### 
sub process_user{
my ($user,$pass) = @_;
my $reply;
my $time = localtime();

if((! defined $okusers{$user}) or ($pass ne $okusers{$user}))
                { print LOG "BADPASSWORD  $user  $pass  $time\n"; LOG-
+>flush;
                  return $reply = "ERROR1: user or password id bad\n";
                }
                
$reply = "OK-SEND->$user";
print LOG "$reply at $time\n"; LOG->flush;
return "$reply\n";
}

##################################################### 
sub connected() {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just connected\n";

my $msginit = "File->upload, max size = $maxsize bytes\n";
$client->send($msginit) || die "ERROR SENDING TO CLIENT: $@\n";
}
################################################### 
sub disconnected() {
my $client = shift;
my $serial = $client->serial();
print "Client $serial just disconnected\n";
LOG->flush;
}
################################################## 
#END SERVER
####################################################
####################################################
####################################################
#!/usr/bin/perl
# ########this is the client#########
use strict;
use warnings;
use Net::EasyTCP;

my $host = "localhost";
my $port = "2345";
my $portpassword = "ztest";

my $client = new Net::EasyTCP(
        mode => "client",
        host => "$host",
        port => "$port",
        password => "$portpassword",
#        donotcompress   => 1, 
#        donotencrypt     => 1, 
       )|| die "ERROR CREATING CLIENT: $@\n";

my $encrypt = $client->encryption();
my $compress = $client->compression();
print "encryption method ->$encrypt\ncompression method ->$compress\n"
+;

my $reply = $client->receive() || die "ERROR RECEIVING: $@\n";
print "$reply\n";
my ($maxsize) = $reply =~ /.* = (\d+) bytes/;

my %hash;     #global  
my $filename; #global  
my $filesize; #global 

# this section checks user and password 
# it exits when an OK-SEND-> is received 
while(1){
&getname();
&sendhash();
print "$reply\n";
if($reply =~ /^OK-SEND->(.*)/){last}
}

######user is OK now send files##################  

while (1){
   while (1){
      &getfile();
      $hash{'filedata'} = -1;
      &sendhash();
      print "$reply\n";
      if($reply !~ /^OK-FILE->SEND(.*)/){last}
      &readfile();
      &sendhash();
      print "uploading.....please wait\n";
      print "$reply\n";
      if($reply =~ /^SUCCESS->(.*)/){$hash{'filename'}='';$hash{'files
+ize'} = '';last}
           }
print "Send another file? (y)/n\n";
my $input =<STDIN>;
         if($input !~ /^[qn]/i){next}else{last}
}

exit 0;
################################################################# 
sub getname{
print "What is your name?\n";
$hash{'user'} = <STDIN>;
chop $hash{'user'};

print "What is your password?\n";
$hash{'pass'} = <STDIN>;
chop $hash{'pass'};
}
################################################################# 
sub getfile{
my $file;
my $ok =0;
while (1){
print "What file do you want to send?\n";
$file = <STDIN>;
chomp $file;
if (! -s $file) { warn "ERROR! Can't find or blank file $file\n";next}
if (-s $file > $maxsize){warn "ERROR! $file is bigger than $maxsize\n"
+;next}
if (-s $file){last}
}

$filesize = -s $file;
($filename) = ( $file =~ /([^\\\/]+)[\\\/]*$/gs );
$hash{'filename'} = $filename;
$hash{'filesize'} = $filesize;
}
################################################################# 
sub sendhash{
$client->send(\%hash) || die "ERROR SENDING: $@\n";
$reply = $client->receive() || die "ERROR RECEIVING: $@\n";
}
################################################################ 
sub readfile{
   local $/=undef;
   open(FILEOUT,"<$hash{'filename'}") or die "Couldn't open file: $!";
   $hash{'filedata'} = (<FILEOUT>);
   close FILEOUT;
}
################################################################## 

Comment on Sockets-File-Upload with Net::EasyTCP
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://198680]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (13)
As of 2014-08-29 16:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (281 votes), past polls