"Fossies" - the Fresh Open Source Software Archive

Member "unix/tentacle_server" (15 Sep 2021, 49580 Bytes) of package /linux/misc/pandorafms_agent_unix-7.0NG.757.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/bin/perl
    2 ##########################################################################
    3 # Tentacle Server
    4 # See https://pandorafms.com/docs/ for protocol description.
    5 # Tentacle have IANA assigned port tpc/41121 as official port.
    6 ##########################################################################
    7 # Copyright (c) 2007-2008  Ramon Novoa  <rnovoa@artica.es>
    8 # Copyright (c) 2005-2010 Artica Soluciones Tecnologicas S.L
    9 #
   10 # tentacle_server.pl    Tentacle Server. See https://pandorafms.com/docs/ for
   11 #                       protocol description.
   12 #
   13 # This program is free software; you can redistribute it and/or modify
   14 # it under the terms of the GNU General Public License as published by
   15 # the Free Software Foundation; version 2 of the License.
   16 # 
   17 # This program is distributed in the hope that it will be useful,
   18 # but WITHOUT ANY WARRANTY; without even the implied warranty of
   19 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   20 # GNU General Public License for more details.
   21 # You should have received a copy of the GNU General Public License
   22 # along with this program; if not, write to the Free Software
   23 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
   24 ##########################################################################
   25 
   26 package tentacle::server;
   27 =head1 NAME
   28 
   29 tentacle_server - Tentacle Server
   30 
   31 =head1 VERSION
   32 
   33 Version 0.6.1
   34 
   35 =head1 USAGE
   36 
   37 tentacle_server B<< -s F<storage_directory> >> [I<options>]
   38 
   39 =head1 DESCRIPTION
   40 
   41 B<tentacle_server(1)> is a server for B<tentacle>, a B<client/server> file transfer protocol that aims to be:
   42 
   43 =over
   44 
   45 =item    * Secure by design.
   46 
   47 =item    * Easy to use.
   48 
   49 =item    * Versatile and cross-platform. 
   50 
   51 =back 
   52 
   53 Tentacle was created to replace more complex tools like SCP and FTP for simple file transfer/retrieval, and switch from authentication mechanisms like .netrc, interactive logins and SSH keys to X.509 certificates. Simple password authentication over a SSL secured connection is supported too.
   54 
   55 The client and server (B<TCP port 41121>) are designed to be run from the command line or called from a shell script, and B<no configuration files are needed>. 
   56 
   57 =cut
   58 
   59 use strict;
   60 use warnings;
   61 use Getopt::Std;
   62 use IO::Select;
   63 use IO::Compress::Zip qw(zip $ZipError);
   64 use IO::Uncompress::Unzip qw(unzip $UnzipError);
   65 use threads;
   66 use Thread::Semaphore;
   67 use POSIX ":sys_wait_h";
   68 use Time::HiRes qw(usleep);
   69 use Scalar::Util qw(refaddr);
   70 use POSIX qw(strftime);
   71 
   72 # Constants for Win32 services.
   73 use constant WIN32_SERVICE_STOPPED => 0x01;
   74 use constant WIN32_SERVICE_RUNNING => 0x04;
   75 
   76 my $t_libwrap_installed = eval { require Authen::Libwrap } ? 1 : 0;
   77 
   78 if ($t_libwrap_installed) {
   79     Authen::Libwrap->import( qw( hosts_ctl STRING_UNKNOWN ) );
   80 }
   81 
   82 # Log errors, 1 enabled, 0 disabled
   83 my $t_log = 0;
   84 
   85 # Log information, 1 enabled, 0 enabled
   86 my $t_log_hard = 0;
   87 
   88 my $SOCKET_MODULE;
   89 if ($^O eq 'MSWin32') {
   90     # Only support INET on windows
   91     require IO::Socket::INET;
   92     $SOCKET_MODULE = 'IO::Socket::INET';
   93 } else {
   94     $SOCKET_MODULE =
   95         eval { require IO::Socket::INET6 } ? 'IO::Socket::INET6'
   96           : eval { require IO::Socket::INET }  ? 'IO::Socket::INET'
   97           : die $@;
   98 }
   99 
  100 # Service name for Win32.
  101 my $SERVICE_NAME="Tentacle Server";
  102 
  103 # Service parameters.
  104 my $SERVICE_PARAMS=join(' ', @ARGV);
  105 
  106 # Program version
  107 our $VERSION = '0.6.2';
  108 
  109 # IPv4 address to listen on
  110 my @t_addresses = ('0', '0.0.0.0');
  111 
  112 # Block size for socket read/write operations in bytes
  113 my $t_block_size = 1024;
  114 
  115 # Client socket
  116 my $t_client_socket;
  117 
  118 # Run as daemon, 1 true, 0 false
  119 my $t_daemon = 0;
  120 
  121 # Storage directory
  122 my $t_directory = '';
  123 
  124 # Filters
  125 my @t_filters;
  126 
  127 # Enable (1) or disable (0) insecure mode
  128 my $t_insecure = 0;
  129 
  130 # String containing quoted invalid file name characters
  131 my $t_invalid_chars = '\?\[\]\/\\\=\+\<\>\:\;\'\,\*\~';
  132 
  133 # Maximum number of simultaneous connections
  134 my $t_max_conn = 10;
  135 
  136 # Maximum file size allowed by the server in bytes
  137 my $t_max_size = 2000000;
  138 
  139 # File overwrite, 1 enabled, 0 disabled
  140 my $t_overwrite = 0;
  141 
  142 # Port to listen on
  143 my $t_port = 41121;
  144 
  145 # Server password
  146 my $t_pwd = '';
  147 
  148 # Do not output error messages, 1 enabled, 0 disabled
  149 my $t_quiet = 0;
  150 
  151 # Number of retries for socket read/write operations
  152 my $t_retries = 3;
  153 
  154 # Select handler
  155 my $t_select;
  156 
  157 # Semaphore
  158 my $t_sem :shared;
  159 
  160 # Server socket
  161 my @t_server_sockets;
  162 
  163 # Server select handler
  164 my $t_server_select;
  165 
  166 # Use SSL, 1 true, 0 false
  167 my $t_ssl = 0;
  168 
  169 # SSL ca certificate file
  170 my $t_ssl_ca = '';
  171 
  172 # SSL certificate file
  173 my $t_ssl_cert = '';
  174 
  175 # SSL private key file
  176 my $t_ssl_key = '';
  177 
  178 # SSL private key password
  179 my $t_ssl_pwd = '';
  180 
  181 # Timeout for socket read/write operations in seconds
  182 my $t_timeout = 1;
  183 
  184 # Address to proxy client requests to
  185 my $t_proxy_ip = undef;
  186 
  187 # Port to proxy client requests to
  188 my $t_proxy_port = 41121;
  189 
  190 # Proxy socket
  191 my $t_proxy_socket;
  192 
  193 # Proxy selected handler
  194 my $t_proxy_select;
  195 
  196 # Use libwrap, 1 true, 0 false
  197 my $t_use_libwrap = 0;
  198 
  199 # Program name for libwrap
  200 my $t_program_name = $0;
  201 $t_program_name =~ s/.*\///g;
  202 
  203 # Log file
  204 my $log_file = undef;
  205 
  206 ################################################################################
  207 ## SUB print_help
  208 ## Print help screen.
  209 ################################################################################
  210 sub print_help {
  211     $" = ',';
  212 
  213     print ("Usage: $0 -s <storage directory> [options]\n\n");
  214     print ("Tentacle server v$VERSION. See https://pandorafms.com/docs/ for protocol description.\n\n");
  215     print ("Options:\n");
  216     print ("\t-a ip_addresses\tIP addresses to listen on (default @t_addresses).\n");
  217     print ("\t               \t(Multiple addresses separated by comma can be defined.)\n");
  218     print ("\t-c number\tMaximum number of simultaneous connections (default $t_max_conn).\n");
  219     print ("\t-d\t\tRun as daemon.\n");
  220     print ("\t-e cert\t\tOpenSSL certificate file. Enables SSL.\n");
  221     print ("\t-f ca_cert\tVerify that the peer certificate is signed by a ca.\n");
  222     print ("\t-F config_file\tConfiguration file full path.\n");
  223     print ("\t-h\t\tShow help.\n");
  224     print ("\t-I\t\tEnable insecure operations (file listing and moving).\n");
  225     print ("\t-i\t\tFilters.\n");
  226     print ("\t-k key\t\tOpenSSL private key file.\n");
  227     print ("\t-l log_file\t\tFile to write logs.\n");
  228     print ("\t-m size\t\tMaximum file size in bytes (default ${t_max_size}b).\n");
  229     print ("\t-o\t\tEnable file overwrite.\n");
  230     print ("\t-p port\t\tPort to listen on (default $t_port).\n");
  231     print ("\t-q\t\tQuiet. Do now print error messages.\n");
  232     print ("\t-r number\tNumber of retries for network opertions (default $t_retries).\n");
  233     print ("\t-S (install|uninstall|run) Manage the win32 service.\n");
  234     print ("\t-t time\t\tTime-out for network operations in seconds (default ${t_timeout}s).\n");
  235     print ("\t-v\t\tBe verbose (display errors).\n");
  236     print ("\t-V\t\tBe verbose on hard way (display errors and other info).\n");
  237     print ("\t-w\t\tPrompt for OpenSSL private key password.\n");
  238     print ("\t-x pwd\t\tServer password.\n");
  239     print ("\t-b ip_address\tProxy requests to the given address.\n");
  240     print ("\t-g port\t\tProxy requests to the given port.\n");
  241     print ("\t-T\t\tEnable tcpwrappers support.\n");
  242     print ("\t  \t\t(To use this option, 'Authen::Libwrap' should be installed.)\n\n");
  243 }
  244 
  245 ################################################################################
  246 ## SUB daemonize
  247 ## Turn the current process into a daemon.
  248 ################################################################################
  249 sub daemonize {
  250     my $pid;
  251 
  252     require POSIX;
  253 
  254     chdir ('/') || error ("Cannot chdir to /: $!.");
  255     umask 0;
  256 
  257     open (STDIN, '/dev/null') || error ("Cannot read /dev/null: $!.");
  258 
  259     # Do not be verbose when running as a daemon
  260     open (STDOUT, '>/dev/null') || error ("Cannot write to /dev/null: $!.");
  261     open (STDERR, '>/dev/null') || error ("Cannot write to /dev/null: $!.");
  262 
  263     # Fork
  264     $pid = fork ();
  265     if (! defined ($pid)) {
  266         error ("Cannot fork: $!.");
  267     }
  268 
  269     # Parent
  270     if ($pid != 0) {
  271         exit;
  272     }
  273 
  274     # Child
  275     POSIX::setsid () || error ("Cannot start a new session: $!.");
  276 }
  277 
  278 ################################################################################
  279 ## SUB parse_options
  280 ## Parse command line options and initialize global variables.
  281 ################################################################################
  282 sub parse_options {
  283     my %opts;
  284     my $CONF = {};
  285     my $token_value;
  286     my $tmp;
  287     my @t_addresses_tmp;
  288 
  289     # Get options
  290     if (getopts ('a:b:c:de:f:F:g:hIi:k:l:m:op:qr:s:S:t:TvVwx:', \%opts) == 0 || defined ($opts{'h'})) {
  291         print_help ();
  292         exit 1;
  293     }
  294 
  295     # The Win32 service must be installed/uninstalled without checking other parameters.
  296     if (defined ($opts{'S'})) {
  297         my $service_action = $opts{'S'};
  298         if ($^O ne 'MSWin32') {
  299             error ("Windows services are only available on Win32.");
  300         } else {
  301             eval "use Win32::Daemon";
  302             die($@) if ($@);
  303 
  304             if ($service_action eq 'install') {
  305                 install_service();
  306             } elsif ($service_action eq 'uninstall') {
  307                 uninstall_service();
  308             }
  309         }
  310     }
  311 
  312     # Configuration file
  313     if (defined($opts{'F'})) {
  314         parse_config_file($opts{'F'}, $CONF);
  315     }
  316 
  317     # Address
  318     $token_value = get_config_value($opts{'a'}, $CONF->{'addresses'});
  319     if (defined ($token_value)) {
  320         @t_addresses = ();
  321         @t_addresses_tmp = split(/,/, $token_value);
  322         
  323         foreach my $t_address (@t_addresses_tmp) {
  324             $t_address =~ s/^ *(.*?) *$/$1/;
  325             if (($t_address ne '0') && 
  326                 ($t_address !~ /^[a-zA-Z\.]+$/ && ($t_address  !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
  327                     || $1 < 0 || $1 > 255 || $2 < 0 || $2 > 255
  328                     || $3 < 0 || $3 > 255 || $4 < 0 || $4 > 255)) &&
  329                 ($t_address !~ /^[0-9a-f:]+$/o)) {
  330                     error ("Address $t_address is not valid.");
  331             }
  332             push @t_addresses, $t_address;
  333         }
  334     }
  335     
  336     # Maximum simultaneous connections
  337     $token_value = get_config_value($opts{'c'}, $CONF->{'max_connections'});
  338     if (defined ($token_value)) {
  339         $t_max_conn = $token_value;
  340         if ($t_max_conn !~ /^\d+$/ || $t_max_conn < 1) {
  341             error ("Invalid number of maximum simultaneous connections.");
  342         }
  343     }
  344 
  345     # Run as daemon
  346     $token_value = get_config_value($opts{'d'}, $CONF->{'daemon'}, 1);
  347     if (defined ($token_value)) {
  348         if ($^ eq 'MSWin32') {
  349             error ("-d flag not available for this OS.");
  350         }
  351 
  352         $t_daemon = 1;
  353     }
  354 
  355     # Enable SSL
  356     $token_value = get_config_value($opts{'e'}, $CONF->{'ssl_cert'});
  357     if (defined ($token_value)) {
  358 
  359         require IO::Socket::SSL;
  360 
  361         $t_ssl_cert = $token_value;
  362         if (! -f $t_ssl_cert) {
  363             error ("File $t_ssl_cert does not exist.");
  364         }
  365 
  366         $t_ssl = 1;
  367     }
  368 
  369     # Verify peer certificate
  370     $token_value = get_config_value($opts{'f'}, $CONF->{'ssl_ca'});
  371     if (defined ($token_value)) {
  372         $t_ssl_ca = $token_value;
  373         if (! -f $t_ssl_ca) {
  374             error ("File $t_ssl_ca does not exist.");
  375         }
  376     }
  377 
  378     # Insecure mode
  379     $token_value = get_config_value($opts{'I'}, $CONF->{'insecure'}, 1);
  380     if (defined ($token_value)) {
  381         $t_insecure = 1;
  382     }
  383 
  384     # Filters (regexp:dir;regexp:dir...)
  385     $token_value = get_config_value($opts{'i'}, $CONF->{'filters'});
  386     if (defined ($token_value)) {
  387         my @filters = split (';', $token_value);
  388         foreach my $filter (@filters) {
  389             my ($regexp, $dir) = split (':', $filter);
  390             next unless defined ($regexp) && defined ($dir);
  391 
  392             # Remove any trailing /
  393             my $char = chop ($dir);
  394             $dir .= $char if ($char) ne '/';
  395 
  396             push(@t_filters, [$regexp, $dir]);
  397         }
  398     }
  399 
  400     # SSL private key file
  401     $token_value = get_config_value($opts{'k'}, $CONF->{'ssl_key'});
  402     if (defined ($token_value)) {
  403         $t_ssl_key = $token_value;
  404         if (! -f $t_ssl_key) {
  405             error ("File $t_ssl_key does not exist.");
  406         }
  407     }
  408 
  409     # Maximum file size
  410     $token_value = get_config_value($opts{'m'}, $CONF->{'max_size'});
  411     if (defined ($token_value)) {
  412         $t_max_size = $token_value;
  413         if ($t_max_size !~ /^\d+$/ || $t_max_size < 1) {
  414             error ("Invalid maximum file size.");
  415         }
  416     }
  417 
  418     # File overwrite
  419     $token_value = get_config_value($opts{'o'}, $CONF->{'overwrite'}, 1);
  420     if (defined ($token_value)) {
  421         $t_overwrite = 1;
  422     }
  423 
  424     # Port
  425     $token_value = get_config_value($opts{'p'}, $CONF->{'port'});
  426     if (defined ($token_value)) {
  427         $t_port = $token_value;
  428         if ($t_port !~ /^\d+$/ || $t_port < 1 || $t_port > 65535) {
  429             error ("Port $t_port is not valid.");
  430         }
  431     }
  432 
  433     # Quiet mode
  434     $token_value = get_config_value($opts{'q'}, $CONF->{'quiet'}, 1);
  435     if (defined ($token_value)) {
  436         $t_quiet = 1;
  437     }
  438 
  439     # Retries
  440     $token_value = get_config_value($opts{'r'}, $CONF->{'retries'});
  441     if (defined ($token_value)) {
  442         $t_retries = $token_value;
  443         if ($t_retries !~ /^\d+$/ || $t_retries < 1) {
  444             error ("Invalid number of retries for network operations.");
  445         }
  446     }
  447 
  448     # Storage directory
  449     $token_value = get_config_value($opts{'s'}, $CONF->{'directory'});
  450     if (defined ($token_value)) {
  451 
  452         $t_directory = $token_value;
  453         
  454         # Check that directory exists
  455         if (! -d $t_directory) {
  456             error ("Directory $t_directory does not exist.");
  457         }
  458 
  459         # Check directory permissions
  460         if (! -w $t_directory) {
  461             error ("Cannot write to directory $t_directory.");
  462         }
  463 
  464         # Remove the trailing / if present
  465         $tmp = chop ($t_directory);
  466         if ($tmp ne '/') {
  467             $t_directory .= $tmp;
  468         }
  469     }
  470     else {
  471         $token_value = get_config_value($opts{'b'}, $CONF->{'proxy_ip'});
  472         if (! defined($token_value)) {
  473             print_help ();
  474             exit 1;
  475         }
  476     }
  477 
  478     # Timeout
  479     $token_value = get_config_value($opts{'t'}, $CONF->{'timeout'});
  480     if (defined ($token_value)) {
  481         $t_timeout = $token_value;
  482         if ($t_timeout !~ /^\d+$/ || $t_timeout < 1) {
  483             error ("Invalid timeout for network operations.");
  484         }
  485     }
  486 
  487     # Read verbose from config file
  488     if (defined($CONF->{'verbose'})) {
  489         if ($CONF->{'verbose'} eq "1") {
  490             $t_log = 1;
  491         } elsif ($CONF->{'verbose'} eq "2") {
  492             $t_log = 1;
  493             $t_log_hard = 1;
  494         }
  495     }
  496     # Be verbose
  497     if (defined ($opts{'v'})) {
  498         $t_log = 1;
  499         $t_log_hard = 0;
  500     }
  501     # Be verbose hard
  502     if (defined ($opts{'V'})) {
  503         $t_log = 1;
  504         $t_log_hard = 1;
  505     }
  506 
  507     # SSL private key password
  508     $token_value = get_config_value($opts{'w'}, $CONF->{'ssl_password'}, 1);
  509     if (defined ($token_value)) {
  510         $t_ssl_pwd = ask_passwd ("Enter private key file password: ", "Enter private key file password again for confirmation: ");
  511     }
  512 
  513     # Server password
  514     $token_value = get_config_value($opts{'x'}, $CONF->{'password'});
  515     if (defined ($token_value)) {
  516         $t_pwd = $token_value;
  517     }
  518     
  519     #Proxy IP address
  520     $token_value = get_config_value($opts{'b'}, $CONF->{'proxy_ip'});
  521     if (defined ($token_value)) {
  522         $t_proxy_ip = $token_value;
  523         if ($t_proxy_ip !~ /^[a-zA-Z\.]+$/ && ($t_proxy_ip  !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
  524             || $1 < 0 || $1 > 255 || $2 < 0 || $2 > 255
  525             || $3 < 0 || $3 > 255 || $4 < 0 || $4 > 255) &&
  526             $t_proxy_ip !~ /^[0-9a-f:]+$/o) {
  527             error ("Proxy address $t_proxy_ip is not valid.");
  528         }       
  529     }
  530     
  531     # Proxy Port
  532     $token_value = get_config_value($opts{'g'}, $CONF->{'proxy_port'});
  533     if (defined ($token_value)) {
  534         $t_proxy_port = $token_value;
  535         if ($t_proxy_port !~ /^\d+$/ || $t_proxy_port < 1 || $t_proxy_port > 65535) {
  536             error ("Proxy port $t_port is not valid.");
  537         }
  538     }   
  539 
  540     # TCP wrappers support
  541     $token_value = get_config_value($opts{'T'}, $CONF->{'use_libwrap'}, 1);
  542     if (defined ($token_value)) {
  543         if ($t_libwrap_installed) {
  544             $t_use_libwrap = 1;
  545         } else {
  546             error ("Authen::Libwrap is not installed.");
  547         }
  548     }
  549 
  550     # Win32 service management
  551     if (defined ($opts{'S'})) {
  552         my $service_action = $opts{'S'};
  553         if ($^O ne 'MSWin32') {
  554             error ("Windows services are only available on Win32.");
  555         } else {
  556             eval "use Win32::Daemon";
  557             die($@) if ($@);
  558 
  559             if ($service_action eq 'run') {
  560                 Win32::Daemon::RegisterCallbacks({
  561                     start       =>  \&callback_start,
  562                     running     =>  \&callback_running,
  563                     stop        =>  \&callback_stop,
  564                 });
  565                 Win32::Daemon::StartService();
  566                 exit 0;
  567             } else {
  568                 error("Unknown action: $service_action");
  569             }
  570         }
  571     }
  572     
  573     # Get the config file
  574     $token_value = get_config_value($opts{'l'}, $CONF->{'log_file'});
  575     if (defined ($token_value)) {
  576         $log_file = $token_value;
  577     }
  578 
  579     # No command lines config values
  580 
  581     # Get the block size
  582     if (defined ($CONF->{'block_size'})) {
  583         if ($t_port !~ /^\d+$/ || $t_port < 1) {
  584             error ("Invalid block size: " . $CONF->{'block_size'} . ".");
  585         }
  586         $t_block_size = $CONF->{'block_size'};
  587     }
  588 
  589     # Configuration file invalid chars
  590     if (defined ($CONF->{'invalid_chars'})) {
  591         $t_invalid_chars = $CONF->{'invalid_chars'};
  592     }
  593 }
  594 
  595 ################################################################################
  596 ## SUB parse_config_file
  597 ## Get all options from a config file.
  598 ################################################################################
  599 sub parse_config_file {
  600     my ($config_file, $CONF) = @_;
  601 
  602     # File should be writable
  603     if (! -r $config_file) {
  604         print "Configuration file $config_file is not readable.\n";
  605         return;
  606     }
  607 
  608     # Open the file
  609     my $FH;
  610     if (! open ($FH, "< $config_file")) {
  611         print "Cannot open configuration file $config_file.\n";
  612         return;
  613     }
  614 
  615     # Read the file and only get the well formed lines
  616     while (<$FH>) {
  617         my $buffer_line = $_;
  618         if ($buffer_line =~ /^[a-zA-Z]/){ # begins with letters
  619             if ($buffer_line =~ m/([\w\-\_\.]+)\s+(.*)/){
  620                 $CONF->{$1} = $2 unless $2 eq "";
  621             }
  622         }
  623     }
  624 
  625     close ($FH);
  626     return;
  627 }
  628 
  629 ################################################################################
  630 ## SUB parse_config_file
  631 ## Search in command line options and config hash from configuration file
  632 ## to get a value (command line is a priority)
  633 ################################################################################
  634 sub get_config_value {
  635     my ($cmd_value, $conf_value, $bool) = @_;
  636     $bool = 0 unless defined($bool);
  637 
  638     return $cmd_value if defined($cmd_value);
  639     # The boolean type value is 1 or undef (0 should be translated like undefP)
  640     if ($bool && defined($conf_value)) {
  641         return undef if ($conf_value ne "1");
  642     }
  643     return $conf_value;
  644 }
  645 
  646 ################################################################################
  647 ## SUB start_proxy
  648 ## Open the proxy server socket.
  649 ################################################################################
  650 sub start_proxy {
  651 
  652     # Connect to server
  653     $t_proxy_socket = $SOCKET_MODULE->new (
  654         PeerAddr => $t_proxy_ip,
  655         PeerPort => $t_proxy_port,
  656     );
  657 
  658     if (! defined ($t_proxy_socket)) {
  659         error ("Cannot connect to $t_proxy_ip on port $t_proxy_port: $!.");
  660     }
  661     
  662     # Create proxy selector
  663     $t_proxy_select = IO::Select->new ();
  664     $t_proxy_select->add ($t_proxy_socket);
  665     
  666 }
  667 
  668 ################################################################################
  669 ## SUB start_server
  670 ## Open the server socket.
  671 ################################################################################
  672 sub start_server {
  673 
  674     my $t_server_socket;
  675 
  676     foreach my $t_address (@t_addresses) {
  677 
  678         $t_server_socket = $SOCKET_MODULE->new (
  679             Listen    => $t_max_conn,
  680             LocalAddr => $t_address,
  681             LocalPort => $t_port,
  682             Proto     => 'tcp',
  683             ReuseAddr     => 1,
  684         );
  685 
  686         if (! defined ($t_server_socket)) {
  687             print_log ("Cannot open socket for address $t_address on port $t_port: $!.");
  688             next;
  689         }
  690 
  691         print_log ("Server listening on $t_address port $t_port (press <ctr-c> to stop)");
  692     
  693         # Say message if tentacle proxy is enable
  694         if (defined ($t_proxy_ip)) {
  695             print_log ("Proxy Mode enable, data will be sent to $t_proxy_ip port $t_proxy_port");   
  696         }
  697     
  698         push @t_server_sockets, $t_server_socket;
  699     }
  700 
  701     if (!@t_server_sockets) {
  702         error ("Cannot open socket for all addresses on port $t_port: $!.");
  703     }
  704     
  705     $t_server_select = IO::Select->new();
  706     foreach my $t_server_socket (@t_server_sockets){
  707         $t_server_select->add($t_server_socket);
  708     }
  709 }
  710 
  711 ################################################################################
  712 ## SUB send_data_proxy
  713 ## Send data to proxy socket.
  714 ################################################################################
  715 sub send_data_proxy {
  716     my $data = $_[0];
  717     my $block_size;
  718     my $retries = 0;
  719     my $size;
  720     my $total = 0;
  721     my $written;
  722 
  723     $size = length ($data);
  724 
  725     while (1) {
  726 
  727         # Try to write data to the socket
  728         if ($t_proxy_select->can_write ($t_timeout)) {
  729 
  730             $block_size = ($size - $total) > $t_block_size ? $t_block_size : ($size - $total);
  731             $written = syswrite ($t_proxy_socket, $data, $size - $total, $total);
  732 
  733             # Write error
  734             if (! defined ($written)) {
  735                 error ("Connection error from " . $t_proxy_socket->sockhost () . ": $!.");
  736             }
  737             
  738             # EOF
  739             if ($written == 0) {
  740                 error ("Connection from " . $t_proxy_socket->sockhost () . " unexpectedly closed.");
  741             }
  742     
  743             $total += $written;
  744 
  745             # Check if all data was written
  746             if ($total == $size) {
  747                 return;
  748             }
  749         }
  750         # Retry
  751         else {
  752             $retries++;
  753             if ($retries > $t_retries) {
  754                 error ("Connection from " . $t_proxy_socket->sockhost () . " timed out.");
  755             }
  756         }
  757     }
  758 }
  759 
  760 ################################################################################
  761 ## SUB close_proxy
  762 ## Close the proxy socket.
  763 ################################################################################
  764 sub close_proxy {
  765     $t_proxy_socket->shutdown (2);
  766     $t_proxy_socket->close ();
  767 }
  768 
  769 ################################################################################
  770 ## SUB stop_server
  771 ## Close the server socket.
  772 ################################################################################
  773 sub stop_server {
  774 
  775     foreach my $t_server_socket (@t_server_sockets) {
  776         $t_server_socket->shutdown (2);
  777         $t_server_socket->close ();
  778     }
  779     print_log ("Server going down");
  780     
  781     exit 0;
  782 }
  783 
  784 ################################################################################
  785 ## SUB start_ssl
  786 ## Convert the client socket to an IO::Socket::SSL socket.
  787 ################################################################################
  788 sub start_ssl {
  789     my $err;
  790 
  791     if ($t_ssl_ca eq '') {
  792         IO::Socket::SSL->start_SSL (
  793             $t_client_socket,
  794             SSL_cert_file => $t_ssl_cert,
  795             SSL_key_file => $t_ssl_key,
  796             SSL_passwd_cb => sub {return $t_ssl_pwd},
  797             SSL_server => 1,
  798             # Verify peer
  799             SSL_verify_mode => 0x01,
  800         );
  801     }
  802     else {
  803         IO::Socket::SSL->start_SSL (
  804             $t_client_socket,
  805             SSL_ca_file => $t_ssl_ca,
  806             SSL_cert_file => $t_ssl_cert,
  807             SSL_key_file => $t_ssl_key,
  808             SSL_passwd_cb => sub {return $t_ssl_pwd},
  809             SSL_server => 1,
  810             # Fail verification if no peer certificate exists
  811             SSL_verify_mode => 0x03,
  812         );
  813     }
  814 
  815     $err = IO::Socket::SSL::errstr ();
  816     if ($err ne '') {
  817         error ($err);
  818     }
  819 
  820     print_log ("SSL started for " . $t_client_socket->sockhost ());
  821 }
  822 
  823 ################################################################################
  824 ## SUB accept_connections
  825 ## Manage incoming connections.
  826 ################################################################################
  827 sub accept_connections {
  828     my $pid;
  829     my $t_server_socket;
  830 
  831     # Ignore SIGPIPE
  832     $SIG{PIPE} = 'IGNORE';
  833 
  834     # Start server
  835     start_server ();
  836 
  837     # Initialize semaphore
  838     $t_sem = Thread::Semaphore->new ($t_max_conn);
  839 
  840     while (1) {
  841         my @ready = $t_server_select->can_read;
  842         foreach $t_server_socket (@ready) {
  843 
  844             # Accept connection
  845             $t_client_socket = $t_server_socket->accept ();
  846 
  847             if (! defined ($t_client_socket)) {
  848                 next if ($! ne ''); # EINTR
  849                 error ("accept: $!.");
  850             }
  851 
  852             print_info ("Client connected from " . $t_client_socket->peerhost ());
  853 
  854             if ($t_use_libwrap && (! hosts_ctl($t_program_name, $t_client_socket))) {
  855                 print_log ("Connection from " . $t_client_socket->peerhost() . " is closed by tcpwrappers.");
  856                 $t_client_socket->shutdown (2);
  857                 $t_client_socket->close();
  858             }
  859             else {
  860 
  861                 # Create a new thread and serve the client
  862                 $t_sem->down();
  863                 my $thr = threads->create(\&serve_client);
  864                 if (! defined ($thr)) {
  865                     error ("Error creating thread: $!.");
  866                 }
  867                 $thr->detach();
  868                 $t_client_socket->close ();
  869             }
  870         }
  871 
  872         usleep (1000);
  873     }
  874 }
  875 
  876 ################################################################################
  877 ## SUB serve_client
  878 ## Serve a connected client.
  879 ################################################################################
  880 sub serve_client() {
  881 
  882     eval {      
  883         # Add client socket to select queue
  884         $t_select = IO::Select->new ();
  885         $t_select->add ($t_client_socket);
  886             
  887         # Start SSL
  888         if ($t_ssl == 1) {
  889             start_ssl ();
  890         }
  891     
  892         # Authenticate client
  893         if ($t_pwd ne '') {
  894             auth_pwd ();
  895         }
  896     
  897         # Check if proxy mode is enable
  898         if (defined ($t_proxy_ip)) {
  899             serve_proxy_connection ();  
  900         } else {
  901             serve_connection ();
  902         }
  903     };
  904 
  905     $t_client_socket->shutdown (2);
  906     $t_client_socket->close ();
  907     $t_sem->up();
  908 }
  909 
  910 ################################################################################
  911 ## SUB serve_proxy_connection
  912 ## Actuate as a proxy between its client and other tentacle server.
  913 ################################################################################
  914 sub serve_proxy_connection {
  915     
  916     # We are a proxy! Start a connection to the Tentacle Server.
  917     start_proxy();
  918 
  919     # Forward data between the client and the server.
  920     eval {
  921         my $select = IO::Select->new ();
  922         $select->add($t_proxy_socket);
  923         $select->add($t_client_socket);
  924         while (my @ready = $select->can_read()) {
  925             foreach my $socket (@ready) {
  926                 if (refaddr($socket) == refaddr($t_client_socket)) {
  927                     my ($read, $data) = recv_data($t_block_size);
  928                     return unless defined($data);
  929                     send_data_proxy($data);
  930                 }
  931                 else {
  932                     my ($read, $data) = recv_data_proxy($t_block_size);
  933                     return unless defined($data);
  934                     send_data($data);
  935                 }
  936             }
  937         }
  938     };
  939 
  940     # Close the connection to the Tentacle Server.
  941     close_proxy();
  942 }
  943 
  944 ################################################################################
  945 ## SUB serve_connection
  946 ## Read and process commands from the client.
  947 ################################################################################
  948 sub serve_connection {
  949     my $command;
  950 
  951     # Read commands
  952     while ($command = recv_command ($t_block_size)) {
  953         
  954         # Client wants to send a file
  955         if ($command =~ /^SEND <(.*)> SIZE (\d+)$/) {
  956             print_info ("Request to send file '$1' size ${2}b from " . $t_client_socket->sockhost ());
  957             recv_file ($1, $2);
  958         }
  959         # Client wants to receive a file
  960         elsif ($command =~ /^RECV <(.*)>$/) {
  961             print_info ("Request to receive file '$1' from " . $t_client_socket->sockhost ());
  962             send_file ($1);
  963         }
  964         elsif ($command =~ /^ZSEND <(.*)> SIZE (\d+)$/) {
  965             print_info ("Request to send compressed file '$1' size ${2}b from " . $t_client_socket->sockhost ());
  966             zrecv_file ($1, $2);
  967         }
  968         # Client wants to receive a file
  969         elsif ($command =~ /^ZRECV <(.*)>$/) {
  970             print_info ("Request to receive compressed file '$1' from " . $t_client_socket->sockhost ());
  971             zsend_file ($1);
  972         }
  973         # Quit
  974         elsif ($command =~ /^QUIT$/) {
  975             print_info ("Connection closed from " . $t_client_socket->sockhost ());
  976             last;
  977         }
  978         # File listing.
  979         elsif ($command =~ /^LS <(.*)>$/) {
  980             if ($t_insecure == 0) {
  981                 print_info ("Insecure mode disabled. Rejected request to list files matched by filter $1 from " . $t_client_socket->sockhost ());
  982                 last;
  983             }
  984 
  985             print_info ("Request to list files matched by filter $1 from " . $t_client_socket->sockhost ());
  986             send_file_list ($1);
  987         }
  988         # Client wants to move a file
  989         elsif ($command =~ /^MV <(.*)>$/) {
  990             if ($t_insecure == 0) {
  991                 print_info ("Insecure mode disabled. Rejected request to move file $1 from " . $t_client_socket->sockhost ());
  992                 last;
  993             }
  994 
  995             print_info ("Request to move file '$1' from " . $t_client_socket->sockhost ());
  996             move_file ($1);
  997         }
  998         # Unknown command
  999         else {
 1000             print_log ("Unknown command '$command' from " . $t_client_socket->sockhost ());
 1001             last;
 1002         }
 1003     }
 1004 }
 1005 
 1006 ################################################################################
 1007 ## SUB auth_pwd
 1008 ## Authenticate client with server password.
 1009 ################################################################################
 1010 sub auth_pwd {
 1011     my $client_digest;
 1012     my $command;
 1013     my $pwd_digest;
 1014 
 1015     require Digest::MD5;
 1016     
 1017     # Wait for password
 1018     $command = recv_command ($t_block_size);
 1019     if ($command !~ /^PASS (.*)$/) {
 1020         error ("Client " . $t_client_socket->sockhost () . " did not authenticate.");
 1021     }
 1022     
 1023     $client_digest = $1;
 1024     $pwd_digest = Digest::MD5::md5 ($t_pwd);
 1025     $pwd_digest = Digest::MD5::md5_hex ($pwd_digest);
 1026 
 1027     if ($client_digest ne $pwd_digest) {
 1028         error ("Invalid password from " . $t_client_socket->sockhost () . ".");
 1029     }
 1030 
 1031     print_log ("Client " . $t_client_socket->sockhost () . " authenticated");
 1032     send_data ("PASS OK\n");
 1033 }
 1034 
 1035 ################################################################################
 1036 ## SUB recv_file
 1037 ## Receive a file of size $_[1] and save it in $t_directory as $_[0].
 1038 ################################################################################
 1039 sub recv_file {
 1040     my $base_name = $_[0];
 1041     my $data = '';
 1042     my $file;
 1043     my $size = $_[1];
 1044 
 1045     # Check file name
 1046     if ($base_name =~ /[$t_invalid_chars]/) {
 1047         print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " has an invalid file name");
 1048         send_data ("SEND ERR (invalid file name)\n");
 1049         return;
 1050     }
 1051 
 1052     # Check file size, empty files are not allowed
 1053     if ($size < 1 || $size > $t_max_size) {
 1054         print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " is too big");
 1055         send_data ("SEND ERR (file is too big)\n");
 1056         return;
 1057     }
 1058     
 1059     # Apply filters
 1060     $file = "$t_directory/" . apply_filters ($base_name) . $base_name;
 1061 
 1062     # Check if file exists
 1063     if (-f $file && $t_overwrite == 0) {
 1064         print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " already exists");
 1065         send_data ("SEND ERR (file already exists)\n");
 1066         return;
 1067     }
 1068 
 1069     send_data ("SEND OK\n");
 1070 
 1071     # Receive file
 1072     $data = recv_data_block ($size);
 1073 
 1074     # Write it to disk
 1075     open (FILE, "> $file") || error ("Cannot open file '$file' for writing.");
 1076     binmode (FILE);
 1077     print (FILE $data);
 1078     close (FILE);
 1079 
 1080     send_data ("SEND OK\n");
 1081     print_info ("Received file '$base_name' size ${size}b from " . $t_client_socket->sockhost ());
 1082 }
 1083 
 1084 ################################################################################
 1085 ## SUB zrecv_file
 1086 ## Receive a compressed file of size $_[1] and save it in $t_directory as $_[0].
 1087 ################################################################################
 1088 sub zrecv_file {
 1089     my $base_name = $_[0];
 1090     my $data = '';
 1091     my $file;
 1092     my $size = $_[1];
 1093     my $zdata = '';
 1094 
 1095     # Check file name
 1096     if ($base_name =~ /[$t_invalid_chars]/) {
 1097         print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " has an invalid file name");
 1098         send_data ("ZSEND ERR (invalid file name)\n");
 1099         return;
 1100     }
 1101 
 1102     # Check file size, empty files are not allowed
 1103     if ($size < 1 || $size > $t_max_size) {
 1104         print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " is too big");
 1105         send_data ("ZSEND ERR (file is too big)\n");
 1106         return;
 1107     }
 1108     
 1109     # Apply filters
 1110     $file = "$t_directory/" . apply_filters ($base_name) . $base_name;
 1111 
 1112     # Check if file exists
 1113     if (-f $file && $t_overwrite == 0) {
 1114         print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " already exists");
 1115         send_data ("ZSEND ERR (file already exists)\n");
 1116         return;
 1117     }
 1118 
 1119     send_data ("ZSEND OK\n");
 1120 
 1121     # Receive file
 1122     $zdata = recv_data_block ($size);
 1123     if (!unzip(\$zdata => \$data)) {
 1124         print_log ("Uncompress error: $UnzipError");
 1125         send_data ("ZSEND ERR\n");
 1126         return;
 1127     }
 1128 
 1129     # Write it to disk
 1130     open (FILE, "> $file") || error ("Cannot open file '$file' for writing.");
 1131     binmode (FILE);
 1132     print (FILE $data);
 1133     close (FILE);
 1134 
 1135     send_data ("ZSEND OK\n");
 1136     print_info ("Received compressed file '$base_name' size ${size}b from " . $t_client_socket->sockhost ());
 1137 }
 1138 
 1139 ################################################################################
 1140 ## SUB send_file
 1141 ## Send a file to the client
 1142 ################################################################################
 1143 sub send_file {
 1144     my $base_name = $_[0];
 1145     my $data = '';
 1146     my $file;
 1147     my $response;
 1148     my $size;
 1149 
 1150     # Check file name
 1151     if ($base_name =~ /[$t_invalid_chars]/) {
 1152         print_log ("Requested file '$base_name' from " . $t_client_socket->sockhost () . " has an invalid file name");
 1153         send_data ("RECV ERR (file has an invalid file name)\n");
 1154         return;
 1155     }
 1156     
 1157     # Apply filters
 1158     $file = "$t_directory/" . apply_filters ($base_name) . $base_name;
 1159 
 1160     # Check if file exists
 1161     if (! -f $file) {
 1162         print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " does not exist");
 1163         send_data ("RECV ERR (file does not exist)\n");
 1164         return;
 1165     }
 1166 
 1167     $size = -s $file;
 1168     send_data ("RECV SIZE $size\n");
 1169     
 1170     # Wait for client response
 1171     $response = recv_command ($t_block_size);
 1172     if ($response ne "RECV OK") {
 1173         print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " not sent");
 1174         return;
 1175     }
 1176 
 1177     # Send the file
 1178     open (FILE, $file) || error ("Cannot open file '$file' for reading.");
 1179     binmode (FILE);
 1180     {
 1181         local $/ = undef;
 1182         $data = <FILE>;
 1183     }
 1184 
 1185     send_data ($data);
 1186     close (FILE);
 1187 
 1188     print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " sent");
 1189 }
 1190 
 1191 ################################################################################
 1192 ## SUB zsend_file
 1193 ## Send a file to the client
 1194 ################################################################################
 1195 sub zsend_file {
 1196     my $base_name = $_[0];
 1197     my $data = '';
 1198     my $file;
 1199     my $response;
 1200     my $size;
 1201 
 1202     # Check file name
 1203     if ($base_name =~ /[$t_invalid_chars]/) {
 1204         print_log ("Requested compressed file '$base_name' from " . $t_client_socket->sockhost () . " has an invalid file name");
 1205         send_data ("ZRECV ERR (file has an invalid file name)\n");
 1206         return;
 1207     }
 1208     
 1209     # Apply filters
 1210     $file = "$t_directory/" . apply_filters ($base_name) . $base_name;
 1211 
 1212     # Check if file exists
 1213     if (! -f $file) {
 1214         print_log ("Requested compressed '$file' from " . $t_client_socket->sockhost () . " does not exist");
 1215         send_data ("ZRECV ERR (file does not exist)\n");
 1216         return;
 1217     }
 1218 
 1219     # Read the file and compress its contents
 1220     if (! zip($file => \$data)) {
 1221         send_data ("QUIT\n");
 1222         error ("Compression error: $ZipError");
 1223         return;
 1224     }
 1225 
 1226     $size = length($data);
 1227     send_data ("ZRECV SIZE $size\n");
 1228     
 1229     # Wait for client response
 1230     $response = recv_command ($t_block_size);
 1231     if ($response ne "ZRECV OK") {
 1232         print_log ("Requested compressed '$file' from " . $t_client_socket->sockhost () . " not sent");
 1233         return;
 1234     }
 1235 
 1236     # Send the file
 1237     send_data ($data);
 1238 
 1239     print_log ("Requested compressed '$file' from " . $t_client_socket->sockhost () . " sent");
 1240 }
 1241 
 1242 ################################################################################
 1243 # Common functions
 1244 ################################################################################
 1245 
 1246 ################################################################################
 1247 ## SUB print_log
 1248 ## Print log messages.
 1249 ################################################################################
 1250 sub print_log($) {
 1251 
 1252     my ($msg) = @_;
 1253     
 1254     return unless ($t_log == 1);
 1255     
 1256     my $fh = *STDOUT;
 1257     if (defined($log_file)) {
 1258         open($fh, ">>", $log_file) || die("Starting log failed: $!.\n");
 1259     }
 1260 
 1261     print ($fh strftime ("%Y-%m-%d %H:%M:%S", localtime()) . "[log]$msg.\n");
 1262 
 1263     close ($fh) if (defined($log_file));
 1264 
 1265 }
 1266 
 1267 ################################################################################
 1268 ## SUB print_log
 1269 ## Print log messages.
 1270 ################################################################################
 1271 sub print_info($) {
 1272 
 1273     my ($msg) = @_;
 1274     
 1275     return unless ($t_log_hard == 1);
 1276     
 1277     my $fh = *STDOUT;
 1278     if (defined($log_file)) {
 1279         open($fh, ">>", $log_file) || die("Starting log failed: $!.\n");
 1280     }
 1281 
 1282     print ($fh strftime ("%Y-%m-%d %H:%M:%S", localtime()) . "[info]$msg.\n");
 1283 
 1284     close ($fh) if (defined($log_file));
 1285 
 1286 }
 1287 
 1288 ################################################################################
 1289 ## SUB error
 1290 ## Print an error and exit the program.
 1291 ################################################################################
 1292 sub error {
 1293 
 1294     my ($msg) = @_;
 1295     
 1296     return unless ($t_quiet == 0);
 1297 
 1298     my $fh = *STDERR;
 1299     if (defined($log_file)) {
 1300         open($fh, ">>", $log_file) || die("$!\n");
 1301     }
 1302 
 1303     print ($fh strftime ("%Y-%m-%d %H:%M:%S", localtime()) . "[err]$msg\n");
 1304 
 1305     close ($fh) if (defined($log_file));
 1306 
 1307     die("\n");
 1308 }
 1309 
 1310 ################################################################################
 1311 ## SUB move_file
 1312 ## Send a file to the client and delete it
 1313 ################################################################################
 1314 sub move_file {
 1315     my $base_name = $_[0];
 1316     my $data = '';
 1317     my $file;
 1318     my $response;
 1319     my $size;
 1320 
 1321     # Check file name
 1322     if ($base_name =~ /[$t_invalid_chars]/) {
 1323         print_log ("Requested file '$base_name' from " . $t_client_socket->sockhost () . " has an invalid file name");
 1324         send_data ("MV ERR\n");
 1325         return;
 1326     }
 1327     
 1328     # Apply filters
 1329     $file = "$t_directory/" . apply_filters ($base_name) . $base_name;
 1330 
 1331     # Check if file exists
 1332     if (! -f $file) {
 1333         print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " does not exist");
 1334         send_data ("MV ERR\n");
 1335         return;
 1336     }
 1337 
 1338     $size = -s $file;
 1339     send_data ("MV SIZE $size\n");
 1340     
 1341     # Wait for client response
 1342     $response = recv_command ($t_block_size);
 1343     if ($response ne "MV OK") {
 1344         print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " not sent");
 1345         return;
 1346     }
 1347 
 1348     # Send the file
 1349     open (FILE, $file) || error ("Cannot open file '$file' for reading.");
 1350     binmode (FILE);
 1351 
 1352     while ($data = <FILE>) {
 1353         send_data ($data);
 1354     }
 1355 
 1356     close (FILE);
 1357     unlink($file);
 1358 
 1359     print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " sent and deleted");
 1360 }
 1361 
 1362 ################################################################################
 1363 ## SUB send_file_list
 1364 ## Send a list of files to the client after applying the given filter.
 1365 ################################################################################
 1366 sub send_file_list {
 1367     my $filter = $_[0];
 1368     my $data = '';
 1369     my $dir;
 1370     my $dh;
 1371     my $response;
 1372     my $size;
 1373 
 1374     # Check file name
 1375     if ($filter =~ /[$t_invalid_chars]/) {
 1376         print_log ("Invalid file listing filter '$filter' from " . $t_client_socket->sockhost ());
 1377         send_data ("LS ERR\n");
 1378         return;
 1379     }
 1380     
 1381     # Apply filters
 1382     $dir = "$t_directory/" . apply_filters ($filter);
 1383 
 1384     # Open the directory.
 1385     if (! opendir ($dh, $dir)) {
 1386         print_log ("Error opening directory $dir as requested from " . $t_client_socket->sockhost () . ": $!");
 1387         send_data ("LS ERR\n");
 1388         return;
 1389     }
 1390 
 1391     # List files.
 1392     while (my $file = readdir ($dh)) {
 1393         next if ($file =~ /[$t_invalid_chars]/); # Only list files valid for Tentacle.
 1394         $data .= "$file\n";
 1395     }
 1396     closedir $dh;
 1397 
 1398     $size = length ($data);
 1399     send_data ("LS SIZE $size\n");
 1400     
 1401     # Wait for client response
 1402     $response = recv_command ($t_block_size);
 1403     if ($response ne "LS OK") {
 1404         print_log ("Requested directory listing from " . $t_client_socket->sockhost () . " not sent");
 1405         return;
 1406     }
 1407 
 1408     send_data ($data);
 1409 
 1410     print_log ("Requested directory listing from " . $t_client_socket->sockhost () . " sent");
 1411 }
 1412 
 1413 ################################################################################
 1414 ## SUB recv_data_proxy
 1415 ## Recv data from proxy socket.
 1416 ################################################################################
 1417 sub recv_data_proxy {
 1418     my $data;
 1419     my $read;
 1420     my $retries = 0;
 1421     my $size = $_[0];
 1422 
 1423     while (1) {
 1424 
 1425         # Try to read data from the socket
 1426         if ($t_proxy_select->can_read ($t_timeout)) {
 1427             
 1428             # Read at most $size bytes
 1429             $read = sysread ($t_proxy_socket, $data, $size);
 1430 
 1431             # Read error
 1432             if (! defined ($read)) {
 1433                 error ("Read error from " . $t_proxy_socket->sockhost () . ": $!.");
 1434             }
 1435     
 1436             # EOF
 1437             if ($read == 0) {
 1438                 error ("Connection from " . $t_proxy_socket->sockhost () . " unexpectedly closed.");
 1439             }
 1440     
 1441             return ($read, $data);
 1442         }
 1443 
 1444         # Retry
 1445         $retries++;
 1446 
 1447         # But check for error conditions first
 1448         if ($retries > $t_retries) {
 1449             error ("Connection from " . $t_proxy_socket->sockhost () . " timed out.");
 1450         }
 1451     }
 1452 }
 1453 ################################################################################
 1454 ## SUB recv_data
 1455 ## Read data from the client socket. Returns the number of bytes read and the
 1456 ## string of bytes as a two element array.
 1457 ################################################################################
 1458 sub recv_data {
 1459     my $data;
 1460     my $read;
 1461     my $retries = 0;
 1462     my $size = $_[0];
 1463 
 1464     while (1) {
 1465 
 1466         # Try to read data from the socket
 1467         if ($t_select->can_read ($t_timeout)) {
 1468             
 1469             # Read at most $size bytes
 1470             $read = sysread ($t_client_socket, $data, $size);
 1471 
 1472             # Read error
 1473             if (! defined ($read)) {
 1474                 error ("Read error from " . $t_client_socket->sockhost () . ": $!.");
 1475             }
 1476     
 1477             # EOF
 1478             if ($read == 0) {
 1479                 error ("Connection from " . $t_client_socket->sockhost () . " unexpectedly closed.");
 1480             }
 1481     
 1482             return ($read, $data);
 1483         }
 1484 
 1485         # Retry
 1486         $retries++;
 1487 
 1488         # But check for error conditions first
 1489         if ($retries > $t_retries) {
 1490             error ("Connection from " . $t_client_socket->sockhost () . " timed out.");
 1491         }
 1492     }
 1493 }
 1494 
 1495 ################################################################################
 1496 ## SUB send_data
 1497 ## Write data to the client socket.
 1498 ################################################################################
 1499 sub send_data {
 1500     my $data = $_[0];
 1501     my $block_size;
 1502     my $retries = 0;
 1503     my $size;
 1504     my $total = 0;
 1505     my $written;
 1506 
 1507     $size = length ($data);
 1508 
 1509     while (1) {
 1510 
 1511         # Try to write data to the socket
 1512         if ($t_select->can_write ($t_timeout)) {
 1513 
 1514             $block_size = ($size - $total) > $t_block_size ? $t_block_size : ($size - $total);
 1515             $written = syswrite ($t_client_socket, $data, $block_size, $total);
 1516 
 1517             # Write error
 1518             if (! defined ($written)) {
 1519                 error ("Connection error from " . $t_client_socket->sockhost () . ": $!.");
 1520             }
 1521             
 1522             # EOF
 1523             if ($written == 0) {
 1524                 error ("Connection from " . $t_client_socket->sockhost () . " unexpectedly closed.");
 1525             }
 1526     
 1527             $total += $written;
 1528 
 1529             # Check if all data was written
 1530             if ($total == $size) {
 1531                 return;
 1532             }
 1533         }
 1534         # Retry
 1535         else {
 1536             $retries++;
 1537             if ($retries > $t_retries) {
 1538                 error ("Connection from " . $t_client_socket->sockhost () . " timed out.");
 1539             }
 1540         }
 1541     }
 1542 }
 1543 
 1544 ################################################################################
 1545 ## SUB recv_command
 1546 ## Read a command from the client, ended by a new line character.
 1547 ################################################################################
 1548 sub recv_command {
 1549     my $buffer;
 1550     my $char;
 1551     my $command = '';
 1552     my $read;
 1553     my $total = 0;
 1554 
 1555     while (1) {
 1556         
 1557         ($read, $buffer) = recv_data ($t_block_size);
 1558         $command .= $buffer;
 1559         $total += $read;
 1560 
 1561         # Check if the command is complete
 1562         $char = chop ($command);
 1563         if ($char eq "\n") {
 1564             return $command;
 1565         }
 1566     
 1567         $command .= $char;
 1568 
 1569         # Avoid overflow
 1570         if ($total > $t_block_size) {
 1571             error ("Received too much data from " . $t_client_socket->sockhost () . ".");
 1572         }
 1573     }
 1574 }
 1575 
 1576 ################################################################################
 1577 ## SUB recv_data_block
 1578 ## Read $_[0] bytes of data from the client.
 1579 ################################################################################
 1580 sub recv_data_block {
 1581     my $buffer = '';
 1582     my $data = '';
 1583     my $read;
 1584     my $size = $_[0];
 1585     my $total = 0;
 1586 
 1587     while (1) {
 1588 
 1589         ($read, $buffer) = recv_data ($size - $total);
 1590         $data .= $buffer;
 1591         $total += $read;
 1592 
 1593         # Check if all data has been read
 1594         if ($total == $size) {
 1595             return $data;
 1596         }
 1597     }
 1598 }
 1599 
 1600 ################################################################################
 1601 ## SUB ask_passwd
 1602 ## Asks the user for a password.
 1603 ################################################################################
 1604 sub ask_passwd {
 1605     my $msg1 = $_[0];
 1606     my $msg2 = $_[1];
 1607     my $pwd1;
 1608     my $pwd2;
 1609 
 1610     require Term::ReadKey;
 1611 
 1612     # Disable keyboard echo
 1613     Term::ReadKey::ReadMode('noecho');
 1614     
 1615     # Promt for password
 1616     print ($msg1);
 1617     $pwd1 = Term::ReadKey::ReadLine(0);
 1618     print ("\n$msg2");
 1619     $pwd2 = Term::ReadKey::ReadLine(0);
 1620     print ("\n");
 1621 
 1622     # Restore original settings
 1623     Term::ReadKey::ReadMode('restore');
 1624 
 1625     if ($pwd1 ne $pwd2) {
 1626         print ("Error: passwords do not match.\n");
 1627         exit 1;
 1628     }
 1629 
 1630     # Remove the trailing new line character
 1631     chop $pwd1;
 1632 
 1633     return $pwd1;
 1634 }
 1635 
 1636 ################################################################################
 1637 ## SUB apply_filters
 1638 ## Applies filters to the given file.
 1639 ################################################################################
 1640 sub apply_filters ($) {
 1641     my ($file_name) = @_;
 1642 
 1643     foreach my $filter (@t_filters) {
 1644         my ($regexp, $dir) = @{$filter};
 1645         if ($file_name =~ /$regexp/) {
 1646             print_log ("File '$file_name' matches filter '$regexp' (changing to directory '$dir')");
 1647             return $dir . '/';
 1648         }
 1649     }
 1650 
 1651     return '';
 1652 }
 1653 
 1654 ################################################################################
 1655 ## SUB install_service
 1656 ## Install the Windows service.
 1657 ################################################################################
 1658 sub install_service() {
 1659 
 1660     my $service_path = $0;
 1661     my $service_params = $SERVICE_PARAMS;
 1662 
 1663     # Change the service parameter from 'install' to 'run'.
 1664     $service_params =~ s/\-S\s+\S+/\-S run/;
 1665 
 1666     my %service_hash = (
 1667         machine =>  '',
 1668         name    =>  'TENTACLESRV',
 1669         display =>  $SERVICE_NAME,
 1670         path    =>  $service_path,
 1671         user    =>  '',
 1672         pwd  =>  '',
 1673         description => 'Tentacle Server http://sourceforge.net/projects/tentacled/',
 1674         parameters => $service_params
 1675     );
 1676     
 1677     if (Win32::Daemon::CreateService(\%service_hash)) {
 1678         print "Successfully added.\n";
 1679         exit 0;
 1680     } else {
 1681         print "Failed to add service: " . Win32::FormatMessage(Win32::Daemon::GetLastError()) . "\n";
 1682         exit 1;
 1683     }
 1684 }
 1685 
 1686 ################################################################################
 1687 ## SUB uninstall_service
 1688 ## Install the Windows service.
 1689 ################################################################################
 1690 sub uninstall_service() {
 1691     if (Win32::Daemon::DeleteService('', 'TENTACLESRV')) {
 1692         print "Successfully deleted.\n";
 1693         exit 0;
 1694     } else {
 1695         print "Failed to delete service: " . Win32::FormatMessage(Win32::Daemon::GetLastError()) . "\n";
 1696         exit 1;
 1697     }
 1698 }
 1699 
 1700 ################################################################################
 1701 ## SUB callback_running
 1702 ## Windows service callback function for the running event.
 1703 ################################################################################
 1704 sub callback_running {
 1705 
 1706     if (Win32::Daemon::State() == WIN32_SERVICE_RUNNING) {
 1707     }
 1708 }
 1709 
 1710 ################################################################################
 1711 ## SUB callback_start
 1712 ## Windows service callback function for the start event.
 1713 ################################################################################
 1714 sub callback_start {
 1715 
 1716     # Accept_connections ();
 1717     my $thr = threads->create(\&accept_connections);
 1718     if (!defined($thr)) {
 1719         Win32::Daemon::State(WIN32_SERVICE_STOPPED);
 1720         Win32::Daemon::StopService();
 1721         return;
 1722     }
 1723     $thr->detach();
 1724 
 1725     Win32::Daemon::State(WIN32_SERVICE_RUNNING);
 1726 }
 1727 
 1728 ################################################################################
 1729 ## SUB callback_stop
 1730 ## Windows service callback function for the stop event.
 1731 ################################################################################
 1732 sub callback_stop {
 1733 
 1734     foreach my $t_server_socket (@t_server_sockets) {
 1735         $t_server_socket->shutdown (2);
 1736         $t_server_socket->close ();
 1737     }
 1738 
 1739     Win32::Daemon::State(WIN32_SERVICE_STOPPED);
 1740     Win32::Daemon::StopService();
 1741 }
 1742 
 1743 ################################################################################
 1744 # Main
 1745 ################################################################################
 1746 
 1747 # Never run as root
 1748 if ($> == 0 && $^O ne 'MSWin32') {
 1749     print ("Error: for safety reasons $0 cannot be run with root privileges.\n");
 1750     exit 1;
 1751 }
 1752 
 1753 # Parse command line options
 1754 parse_options ();
 1755 
 1756 # Check command line arguments
 1757 if ($#ARGV != -1) {
 1758     print_help ();
 1759     exit 1;
 1760 }
 1761 
 1762 # Show IPv6 status
 1763 if ($SOCKET_MODULE eq 'IO::Socket::INET') {
 1764     print_log ("IO::Socket::INET6 is not found. IPv6 is disabled.");
 1765 }
 1766 
 1767 # Run as daemon?
 1768 if ($t_daemon == 1 && $^O ne 'MSWin32') {
 1769     daemonize ();
 1770 }
 1771 
 1772 # Handle ctr-c
 1773 if ($^O eq 'MSWin32') {
 1774     no warnings;
 1775     $SIG{INT2} = \&stop_server;
 1776     use warnings;
 1777 }
 1778 else {
 1779     $SIG{INT} = \&stop_server;
 1780 }
 1781 
 1782 # Accept connections
 1783 accept_connections();
 1784 
 1785 __END__
 1786 
 1787 =head1 REQUIRED ARGUMENTES
 1788 
 1789 =over 
 1790 
 1791 =item B<< -s F<storage_directory> >>    Root directory to store the files received by the server
 1792 
 1793 =back 
 1794 
 1795 =head1 OPTIONS
 1796 
 1797 =over
 1798 
 1799 =item   I<-a ip_address>    Address to B<listen> on (default I<0.0.0.0>).
 1800 
 1801 =item   I<-c number>        B<Maximum> number of simultaneous B<connections> (default I<10>).
 1802 
 1803 =item   I<-d>           Run as B<daemon>.
 1804 
 1805 =item   I<-e cert>      B<OpenSSL certificate> file. Enables SSL.
 1806 
 1807 =item   I<-f ca_cert>   Verify that the peer certificate is signed by a B<CA>.
 1808 
 1809 =item   I<-h>           Show B<help>.
 1810 
 1811 =item   I<-i>           B<Filters>.
 1812 
 1813 =item   I<-k key>       B<OpenSSL private key> file.
 1814 
 1815 =item   I<-m size>      B<Maximum file size> in bytes (default I<2000000b>).
 1816 
 1817 =item   I<-o>           Enable file B<overwrite>.
 1818 
 1819 =item   I<-p port>      B<Port to listen> on (default I<41121>).
 1820 
 1821 =item   I<-q>           B<Quiet>. Do now print error messages.
 1822 
 1823 =item   I<-r number>        B<Number of retries> for network opertions (default I<3>).
 1824 
 1825 =item   I<-t time>      B<Time-out> for network operations in B<seconds> (default I<1s>).
 1826 
 1827 =item   I<-v>           Be B<verbose>.
 1828 
 1829 =item   I<-w>           Prompt for B<OpenSSL private key password>.
 1830 
 1831 =item   I<-x> pwd       B<Server password>.
 1832 
 1833 =back
 1834 
 1835 =head1 EXIT STATUS
 1836 
 1837 =over 
 1838 
 1839 =item 0 on Success
 1840 
 1841 =item 1 on Error
 1842 
 1843 =back 
 1844 
 1845 =head1 CONFIGURATION
 1846 
 1847 Tentacle doesn't use any configurationf files, all the configuration is done by the options passed when it's started.
 1848 
 1849 =head1 DEPENDENCIES
 1850 
 1851 L<Getopt::Std>, L<IO::Select>, L<IO::Socket::INET>, L<Thread::Semaphore>, L<POSIX> 
 1852 
 1853 
 1854 =head1 LICENSE
 1855 
 1856 This is released under the GNU Lesser General Public License.
 1857 
 1858 =head1 SEE ALSO
 1859 
 1860 L<Getopt::Std>, L<IO::Select>, L<IO::Socket::INET>, L<Thread::Semaphore>, L<POSIX> 
 1861 
 1862 Protocol description and more info at: L<< https://pandorafms.com/docs/index.php?title=Pandora:Documentation_en:Tentacle >>
 1863 
 1864 =head1 COPYRIGHT
 1865 
 1866 Copyright (c) 2005-2010 Artica Soluciones Tecnologicas S.L
 1867 
 1868 =cut
 1869