1#!/usr/bin/perl 2########################################################################## 3# Tentacle Server 4# See http://www.openideas.info/wiki 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 http://www.openideas.info/wiki 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 26package tentacle::server; 27=head1 NAME 28 29tentacle_server - Tentacle Server 30 31=head1 VERSION 32 33Version 0.5.0 34 35=head1 USAGE 36 37tentacle_server B<< -s F<storage_directory> >> [I<options>] 38 39=head1 DESCRIPTION 40 41B<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 53Tentacle 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 55The 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 59use strict; 60use warnings; 61use Getopt::Std; 62use IO::Select; 63use threads; 64use Thread::Semaphore; 65use POSIX ":sys_wait_h"; 66use Time::HiRes qw(usleep); 67use Scalar::Util qw(refaddr); 68 69# Constants for Win32 services. 70use constant WIN32_SERVICE_STOPPED => 0x01; 71use constant WIN32_SERVICE_RUNNING => 0x04; 72 73my $t_libwrap_installed = eval { require Authen::Libwrap } ? 1 : 0; 74 75if ($t_libwrap_installed) { 76 Authen::Libwrap->import( qw( hosts_ctl STRING_UNKNOWN ) ); 77} 78 79# Log messages, 1 enabled, 0 disabled 80my $t_log = 0; 81 82my $SOCKET_MODULE = 83 eval { require IO::Socket::INET6 } ? 'IO::Socket::INET6' 84 : eval { require IO::Socket::INET } ? 'IO::Socket::INET' 85 : die $@; 86 87# Service name for Win32. 88my $SERVICE_NAME="Tentacle Server"; 89 90# Service parameters. 91my $SERVICE_PARAMS=join(' ', @ARGV); 92 93# Program version 94our $VERSION = '0.5.0'; 95 96# IPv4 address to listen on 97my @t_addresses = ('0', '0.0.0.0'); 98 99# Block size for socket read/write operations in bytes 100my $t_block_size = 1024; 101 102# Client socket 103my $t_client_socket; 104 105# Run as daemon, 1 true, 0 false 106my $t_daemon = 0; 107 108# Storage directory 109my $t_directory = ''; 110 111# Filters 112my @t_filters; 113 114# String containing quoted invalid file name characters 115my $t_invalid_chars = '\?\[\]\/\\\=\+\<\>\:\;\'\,\*\~'; 116 117# Maximum number of simultaneous connections 118my $t_max_conn = 10; 119 120# Maximum file size allowed by the server in bytes 121my $t_max_size = 2000000; 122 123# File overwrite, 1 enabled, 0 disabled 124my $t_overwrite = 0; 125 126# Port to listen on 127my $t_port = 41121; 128 129# Server password 130my $t_pwd = ''; 131 132# Do not output error messages, 1 enabled, 0 disabled 133my $t_quiet = 0; 134 135# Number of retries for socket read/write operations 136my $t_retries = 3; 137 138# Select handler 139my $t_select; 140 141# Semaphore 142my $t_sem :shared; 143 144# Server socket 145my @t_server_sockets; 146 147# Server select handler 148my $t_server_select; 149 150# Use SSL, 1 true, 0 false 151my $t_ssl = 0; 152 153# SSL ca certificate file 154my $t_ssl_ca = ''; 155 156# SSL certificate file 157my $t_ssl_cert = ''; 158 159# SSL private key file 160my $t_ssl_key = ''; 161 162# SSL private key password 163my $t_ssl_pwd = ''; 164 165# Timeout for socket read/write operations in seconds 166my $t_timeout = 1; 167 168# Address to proxy client requests to 169my $t_proxy_ip = undef; 170 171# Port to proxy client requests to 172my $t_proxy_port = 41121; 173 174# Proxy socket 175my $t_proxy_socket; 176 177# Proxy selected handler 178my $t_proxy_select; 179 180# Use libwrap, 1 true, 0 false 181my $t_use_libwrap = 0; 182 183# Program name for libwrap 184my $t_program_name = $0; 185$t_program_name =~ s/.*\///g; 186 187################################################################################ 188## SUB print_help 189## Print help screen. 190################################################################################ 191sub print_help { 192 $" = ','; 193 194 print ("Usage: $0 -s <storage directory> [options]\n\n"); 195 print ("Tentacle server v$VERSION. See http://www.openideas.info/wiki for protocol description.\n\n"); 196 print ("Options:\n"); 197 print ("\t-a ip_addresses\tIP addresses to listen on (default @t_addresses).\n"); 198 print ("\t \t(Multiple addresses separated by comma can be defined.)\n"); 199 print ("\t-c number\tMaximum number of simultaneous connections (default $t_max_conn).\n"); 200 print ("\t-d\t\tRun as daemon.\n"); 201 print ("\t-e cert\t\tOpenSSL certificate file. Enables SSL.\n"); 202 print ("\t-f ca_cert\tVerify that the peer certificate is signed by a ca.\n"); 203 print ("\t-h\t\tShow help.\n"); 204 print ("\t-i\t\tFilters.\n"); 205 print ("\t-k key\t\tOpenSSL private key file.\n"); 206 print ("\t-m size\t\tMaximum file size in bytes (default ${t_max_size}b).\n"); 207 print ("\t-o\t\tEnable file overwrite.\n"); 208 print ("\t-p port\t\tPort to listen on (default $t_port).\n"); 209 print ("\t-q\t\tQuiet. Do now print error messages.\n"); 210 print ("\t-r number\tNumber of retries for network opertions (default $t_retries).\n"); 211 print ("\t-S (install|uninstall|run) Manage the win32 service.\n"); 212 print ("\t-t time\t\tTime-out for network operations in seconds (default ${t_timeout}s).\n"); 213 print ("\t-v\t\tBe verbose.\n"); 214 print ("\t-w\t\tPrompt for OpenSSL private key password.\n"); 215 print ("\t-x pwd\t\tServer password.\n"); 216 print ("\t-b ip_address\tProxy requests to the given address.\n"); 217 print ("\t-g port\t\tProxy requests to the given port.\n"); 218 print ("\t-T\t\tEnable tcpwrappers support.\n"); 219 print ("\t \t\t(To use this option, 'Authen::Libwrap' should be installed.)\n\n"); 220} 221 222################################################################################ 223## SUB daemonize 224## Turn the current process into a daemon. 225################################################################################ 226sub daemonize { 227 my $pid; 228 229 require POSIX; 230 231 chdir ('/') || error ("Cannot chdir to /: $!."); 232 umask 0; 233 234 open (STDIN, '/dev/null') || error ("Cannot read /dev/null: $!."); 235 236 # Do not be verbose when running as a daemon 237 open (STDOUT, '>/dev/null') || error ("Cannot write to /dev/null: $!."); 238 open (STDERR, '>/dev/null') || error ("Cannot write to /dev/null: $!."); 239 240 # Fork 241 $pid = fork (); 242 if (! defined ($pid)) { 243 error ("Cannot fork: $!."); 244 } 245 246 # Parent 247 if ($pid != 0) { 248 exit; 249 } 250 251 # Child 252 POSIX::setsid () || error ("Cannot start a new session: $!."); 253} 254 255################################################################################ 256## SUB parse_options 257## Parse command line options and initialize global variables. 258################################################################################ 259sub parse_options { 260 my %opts; 261 my $tmp; 262 my @t_addresses_tmp; 263 264 # Get options 265 if (getopts ('a:b:c:de:f:g:hi:k:m:op:qr:s:S:t:Tvwx:', \%opts) == 0 || defined ($opts{'h'})) { 266 print_help (); 267 exit 1; 268 } 269 270 # The Win32 service must be installed/uninstalled without checking other parameters. 271 if (defined ($opts{'S'})) { 272 my $service_action = $opts{'S'}; 273 if ($^O ne 'MSWin32') { 274 error ("Windows services are only available on Win32."); 275 } else { 276 eval "use Win32::Daemon"; 277 die($@) if ($@); 278 279 if ($service_action eq 'install') { 280 install_service(); 281 } elsif ($service_action eq 'uninstall') { 282 uninstall_service(); 283 } 284 } 285 } 286 287 # Address 288 if (defined ($opts{'a'})) { 289 @t_addresses = (); 290 @t_addresses_tmp = split(/,/, $opts{'a'}); 291 292 foreach my $t_address (@t_addresses_tmp) { 293 $t_address =~ s/^ *(.*?) *$/$1/; 294 if (($t_address ne '0') && 295 ($t_address !~ /^[a-zA-Z\.]+$/ && ($t_address !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ 296 || $1 < 0 || $1 > 255 || $2 < 0 || $2 > 255 297 || $3 < 0 || $3 > 255 || $4 < 0 || $4 > 255)) && 298 ($t_address !~ /^[0-9a-f:]+$/o)) { 299 error ("Address $t_address is not valid."); 300 } 301 push @t_addresses, $t_address; 302 } 303 } 304 305 # Maximum simultaneous connections 306 if (defined ($opts{'c'})) { 307 $t_max_conn = $opts{'c'}; 308 if ($t_max_conn !~ /^\d+$/ || $t_max_conn < 1) { 309 error ("Invalid number of maximum simultaneous connections."); 310 } 311 } 312 313 # Run as daemon 314 if (defined ($opts{'d'})) { 315 if ($^ eq 'MSWin32') { 316 error ("-d flag not available for this OS."); 317 } 318 319 $t_daemon = 1; 320 } 321 322 # Enable SSL 323 if (defined ($opts{'e'})) { 324 325 require IO::Socket::SSL; 326 327 $t_ssl_cert = $opts{'e'}; 328 if (! -f $t_ssl_cert) { 329 error ("File $t_ssl_cert does not exist."); 330 } 331 332 $t_ssl = 1; 333 } 334 335 # Verify peer certificate 336 if (defined ($opts{'f'})) { 337 $t_ssl_ca = $opts{'f'}; 338 if (! -f $t_ssl_ca) { 339 error ("File $t_ssl_ca does not exist."); 340 } 341 } 342 343 # Filters (regexp:dir;regexp:dir...) 344 if (defined ($opts{'i'})) { 345 my @filters = split (';', $opts{'i'}); 346 foreach my $filter (@filters) { 347 my ($regexp, $dir) = split (':', $filter); 348 next unless defined ($regexp) && defined ($dir); 349 350 # Remove any trailing / 351 my $char = chop ($dir); 352 $dir .= $char if ($char) ne '/'; 353 354 push(@t_filters, [$regexp, $dir]); 355 } 356 } 357 358 # SSL private key file 359 if (defined ($opts{'k'})) { 360 $t_ssl_key = $opts{'k'}; 361 if (! -f $t_ssl_key) { 362 error ("File $t_ssl_key does not exist."); 363 } 364 } 365 366 # Maximum file size 367 if (defined ($opts{'m'})) { 368 $t_max_size = $opts{'m'}; 369 if ($t_max_size !~ /^\d+$/ || $t_max_size < 1) { 370 error ("Invalid maximum file size."); 371 } 372 } 373 374 # File overwrite 375 if (defined ($opts{'o'})) { 376 $t_overwrite = 1; 377 } 378 379 # Port 380 if (defined ($opts{'p'})) { 381 $t_port = $opts{'p'}; 382 if ($t_port !~ /^\d+$/ || $t_port < 1 || $t_port > 65535) { 383 error ("Port $t_port is not valid."); 384 } 385 } 386 387 # Quiet mode 388 if (defined ($opts{'q'})) { 389 $t_quiet = 1; 390 } 391 392 # Retries 393 if (defined ($opts{'r'})) { 394 $t_retries = $opts{'r'}; 395 if ($t_retries !~ /^\d+$/ || $t_retries < 1) { 396 error ("Invalid number of retries for network operations."); 397 } 398 } 399 400 # Storage directory 401 if (defined ($opts{'s'})) { 402 403 $t_directory = $opts{'s'}; 404 405 # Check that directory exists 406 if (! -d $t_directory) { 407 error ("Directory $t_directory does not exist."); 408 } 409 410 # Check directory permissions 411 if (! -w $t_directory) { 412 error ("Cannot write to directory $t_directory."); 413 } 414 415 # Remove the trailing / if present 416 $tmp = chop ($t_directory); 417 if ($tmp ne '/') { 418 $t_directory .= $tmp; 419 } 420 } 421 else { 422 if (! defined($opts{'b'})) { 423 print_help (); 424 exit 1; 425 } 426 } 427 428 # Timeout 429 if (defined ($opts{'t'})) { 430 $t_timeout = $opts{'t'}; 431 if ($t_timeout !~ /^\d+$/ || $t_timeout < 1) { 432 error ("Invalid timeout for network operations."); 433 } 434 } 435 436 # Be verbose 437 if (defined ($opts{'v'})) { 438 $t_log = 1; 439 } 440 441 # SSL private key password 442 if (defined ($opts{'w'})) { 443 $t_ssl_pwd = ask_passwd ("Enter private key file password: ", "Enter private key file password again for confirmation: "); 444 } 445 446 # Server password 447 if (defined ($opts{'x'})) { 448 $t_pwd = $opts{'x'}; 449 } 450 451 #Proxy IP address 452 if (defined ($opts{'b'})) { 453 $t_proxy_ip = $opts{'b'}; 454 if ($t_proxy_ip !~ /^[a-zA-Z\.]+$/ && ($t_proxy_ip !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ 455 || $1 < 0 || $1 > 255 || $2 < 0 || $2 > 255 456 || $3 < 0 || $3 > 255 || $4 < 0 || $4 > 255) && 457 $t_proxy_ip !~ /^[0-9a-f:]+$/o) { 458 error ("Proxy address $t_proxy_ip is not valid."); 459 } 460 } 461 462 # Proxy Port 463 if (defined ($opts{'g'})) { 464 $t_proxy_port = $opts{'g'}; 465 if ($t_proxy_port !~ /^\d+$/ || $t_proxy_port < 1 || $t_proxy_port > 65535) { 466 error ("Proxy port $t_port is not valid."); 467 } 468 } 469 470 # TCP wrappers support 471 if (defined ($opts{'T'})) { 472 if ($t_libwrap_installed) { 473 $t_use_libwrap = 1; 474 } else { 475 error ("Authen::Libwrap is not installed."); 476 } 477 } 478 479 # Win32 service management 480 if (defined ($opts{'S'})) { 481 my $service_action = $opts{'S'}; 482 if ($^O ne 'MSWin32') { 483 error ("Windows services are only available on Win32."); 484 } else { 485 eval "use Win32::Daemon"; 486 die($@) if ($@); 487 488 if ($service_action eq 'run') { 489 Win32::Daemon::RegisterCallbacks({ 490 start => \&callback_start, 491 running => \&callback_running, 492 stop => \&callback_stop, 493 }); 494 Win32::Daemon::StartService(); 495 exit 0; 496 } else { 497 error("Unknown action: $service_action"); 498 } 499 } 500 } 501} 502 503################################################################################ 504## SUB start_proxy 505## Open the proxy server socket. 506################################################################################ 507sub start_proxy { 508 509 # Connect to server 510 $t_proxy_socket = $SOCKET_MODULE->new ( 511 PeerAddr => $t_proxy_ip, 512 PeerPort => $t_proxy_port, 513 ); 514 515 if (! defined ($t_proxy_socket)) { 516 error ("Cannot connect to $t_proxy_ip on port $t_proxy_port: $!."); 517 } 518 519 # Create proxy selector 520 $t_proxy_select = IO::Select->new (); 521 $t_proxy_select->add ($t_proxy_socket); 522 523} 524 525################################################################################ 526## SUB start_server 527## Open the server socket. 528################################################################################ 529sub start_server { 530 531 my $t_server_socket; 532 533 foreach my $t_address (@t_addresses) { 534 535 $t_server_socket = $SOCKET_MODULE->new ( 536 Listen => $t_max_conn, 537 LocalAddr => $t_address, 538 LocalPort => $t_port, 539 Proto => 'tcp', 540 ReuseAddr => 1, 541 ); 542 543 if (! defined ($t_server_socket)) { 544 print_log ("Cannot open socket for address $t_address on port $t_port: $!."); 545 next; 546 } 547 548 print_log ("Server listening on $t_address port $t_port (press <ctr-c> to stop)"); 549 550 # Say message if tentacle proxy is enable 551 if (defined ($t_proxy_ip)) { 552 print_log ("Proxy Mode enable, data will be sent to $t_proxy_ip port $t_proxy_port"); 553 } 554 555 push @t_server_sockets, $t_server_socket; 556 } 557 558 if (!@t_server_sockets) { 559 error ("Cannot open socket for all addresses on port $t_port: $!."); 560 } 561 562 $t_server_select = IO::Select->new(); 563 foreach my $t_server_socket (@t_server_sockets){ 564 $t_server_select->add($t_server_socket); 565 } 566} 567 568################################################################################ 569## SUB send_data_proxy 570## Send data to proxy socket. 571################################################################################ 572sub send_data_proxy { 573 my $data = $_[0]; 574 my $retries = 0; 575 my $size; 576 my $total = 0; 577 my $written; 578 579 $size = length ($data); 580 581 while (1) { 582 583 # Try to write data to the socket 584 if ($t_proxy_select->can_write ($t_timeout)) { 585 586 $written = syswrite ($t_proxy_socket, $data, $size - $total, $total); 587 588 # Write error 589 if (! defined ($written)) { 590 error ("Connection error from " . $t_proxy_socket->sockhost () . ": $!."); 591 } 592 593 # EOF 594 if ($written == 0) { 595 error ("Connection from " . $t_proxy_socket->sockhost () . " unexpectedly closed."); 596 } 597 598 } 599 600 $total += $written; 601 602 # Check if all data was written 603 if ($total == $size) { 604 return; 605 } 606 607 # Retry 608 $retries++; 609 610 # But check for error conditions first 611 if ($retries > $t_retries) { 612 error ("Connection from " . $t_proxy_socket->sockhost () . " timed out."); 613 } 614 } 615} 616 617################################################################################ 618## SUB close_proxy 619## Close the proxy socket. 620################################################################################ 621sub close_proxy { 622 $t_proxy_socket->shutdown (2); 623 $t_proxy_socket->close (); 624} 625 626################################################################################ 627## SUB stop_server 628## Close the server socket. 629################################################################################ 630sub stop_server { 631 632 foreach my $t_server_socket (@t_server_sockets) { 633 $t_server_socket->shutdown (2); 634 $t_server_socket->close (); 635 } 636 print_log ("Server going down"); 637 638 exit 0; 639} 640 641################################################################################ 642## SUB start_ssl 643## Convert the client socket to an IO::Socket::SSL socket. 644################################################################################ 645sub start_ssl { 646 my $err; 647 648 if ($t_ssl_ca eq '') { 649 IO::Socket::SSL->start_SSL ( 650 $t_client_socket, 651 SSL_cert_file => $t_ssl_cert, 652 SSL_key_file => $t_ssl_key, 653 SSL_passwd_cb => sub {return $t_ssl_pwd}, 654 SSL_server => 1, 655 # Verify peer 656 SSL_verify_mode => 0x01, 657 ); 658 } 659 else { 660 IO::Socket::SSL->start_SSL ( 661 $t_client_socket, 662 SSL_ca_file => $t_ssl_ca, 663 SSL_cert_file => $t_ssl_cert, 664 SSL_key_file => $t_ssl_key, 665 SSL_passwd_cb => sub {return $t_ssl_pwd}, 666 SSL_server => 1, 667 # Fail verification if no peer certificate exists 668 SSL_verify_mode => 0x03, 669 ); 670 } 671 672 $err = IO::Socket::SSL::errstr (); 673 if ($err ne '') { 674 error ($err); 675 } 676 677 print_log ("SSL started for " . $t_client_socket->sockhost ()); 678} 679 680################################################################################ 681## SUB accept_connections 682## Manage incoming connections. 683################################################################################ 684sub accept_connections { 685 my $pid; 686 my $t_server_socket; 687 688 # Ignore SIGPIPE 689 $SIG{PIPE} = 'IGNORE'; 690 691 # Start server 692 start_server (); 693 694 # Initialize semaphore 695 $t_sem = Thread::Semaphore->new ($t_max_conn); 696 697 while (1) { 698 my @ready = $t_server_select->can_read; 699 foreach $t_server_socket (@ready) { 700 701 # Accept connection 702 $t_client_socket = $t_server_socket->accept (); 703 704 if (! defined ($t_client_socket)) { 705 next if ($! ne ''); # EINTR 706 error ("accept: $!."); 707 } 708 709 print_log ("Client connected from " . $t_client_socket->peerhost ()); 710 711 if ($t_use_libwrap && (! hosts_ctl($t_program_name, $t_client_socket))) { 712 print_log ("Connection from " . $t_client_socket->peerhost() . " is closed by tcpwrappers."); 713 $t_client_socket->shutdown (2); 714 $t_client_socket->close(); 715 } 716 else { 717 718 # Create a new thread and serve the client 719 $t_sem->down(); 720 my $thr = threads->create(\&serve_client); 721 if (! defined ($thr)) { 722 error ("Error creating thread: $!."); 723 } 724 $thr->detach(); 725 $t_client_socket->close (); 726 } 727 } 728 729 usleep (1000); 730 } 731} 732 733################################################################################ 734## SUB serve_client 735## Serve a connected client. 736################################################################################ 737sub serve_client() { 738 739 eval { 740 # Add client socket to select queue 741 $t_select = IO::Select->new (); 742 $t_select->add ($t_client_socket); 743 744 # Start SSL 745 if ($t_ssl == 1) { 746 start_ssl (); 747 } 748 749 # Authenticate client 750 if ($t_pwd ne '') { 751 auth_pwd (); 752 } 753 754 # Check if proxy mode is enable 755 if (defined ($t_proxy_ip)) { 756 serve_proxy_connection (); 757 } else { 758 serve_connection (); 759 } 760 }; 761 762 $t_client_socket->shutdown (2); 763 $t_client_socket->close (); 764 $t_sem->up(); 765} 766 767################################################################################ 768## SUB serve_proxy_connection 769## Actuate as a proxy between its client and other tentacle server. 770################################################################################ 771sub serve_proxy_connection { 772 773 # We are a proxy! Start a connection to the Tentacle Server. 774 start_proxy(); 775 776 # Forward data between the client and the server. 777 eval { 778 my $select = IO::Select->new (); 779 $select->add($t_proxy_socket); 780 $select->add($t_client_socket); 781 while (my @ready = $select->can_read()) { 782 foreach my $socket (@ready) { 783 if (refaddr($socket) == refaddr($t_client_socket)) { 784 my ($read, $data) = recv_data($t_block_size); 785 return unless defined($data); 786 send_data_proxy($data); 787 } 788 else { 789 my ($read, $data) = recv_data_proxy($t_block_size); 790 return unless defined($data); 791 send_data($data); 792 } 793 } 794 } 795 }; 796 797 # Close the connection to the Tentacle Server. 798 close_proxy(); 799} 800 801################################################################################ 802## SUB serve_connection 803## Read and process commands from the client. 804################################################################################ 805sub serve_connection { 806 my $command; 807 808 # Read commands 809 while ($command = recv_command ($t_block_size)) { 810 811 # Client wants to send a file 812 if ($command =~ /^SEND <(.*)> SIZE (\d+)$/) { 813 print_log ("Request to send file '$1' size ${2}b from " . $t_client_socket->sockhost ()); 814 recv_file ($1, $2); 815 } 816 # Client wants to receive a file 817 elsif ($command =~ /^RECV <(.*)>$/) { 818 print_log ("Request to receive file '$1' from " . $t_client_socket->sockhost ()); 819 send_file ($1); 820 } 821 # Quit 822 elsif ($command =~ /^QUIT$/) { 823 print_log ("Connection closed from " . $t_client_socket->sockhost ()); 824 last; 825 } 826 # Unknown command 827 else { 828 print_log ("Unknown command '$command' from " . $t_client_socket->sockhost ()); 829 last; 830 } 831 } 832} 833 834################################################################################ 835## SUB auth_pwd 836## Authenticate client with server password. 837################################################################################ 838sub auth_pwd { 839 my $client_digest; 840 my $command; 841 my $pwd_digest; 842 843 require Digest::MD5; 844 845 # Wait for password 846 $command = recv_command ($t_block_size); 847 if ($command !~ /^PASS (.*)$/) { 848 error ("Client " . $t_client_socket->sockhost () . " did not authenticate."); 849 } 850 851 $client_digest = $1; 852 $pwd_digest = Digest::MD5::md5 ($t_pwd); 853 $pwd_digest = Digest::MD5::md5_hex ($pwd_digest); 854 855 if ($client_digest ne $pwd_digest) { 856 error ("Invalid password from " . $t_client_socket->sockhost () . "."); 857 } 858 859 print_log ("Client " . $t_client_socket->sockhost () . " authenticated"); 860 send_data ("PASS OK\n"); 861} 862 863################################################################################ 864## SUB recv_file 865## Receive a file of size $_[1] and save it in $t_directory as $_[0]. 866################################################################################ 867sub recv_file { 868 my $base_name = $_[0]; 869 my $data = ''; 870 my $file; 871 my $size = $_[1]; 872 873 # Check file name 874 if ($base_name =~ /[$t_invalid_chars]/) { 875 print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " has an invalid file name"); 876 send_data ("SEND ERR\n"); 877 return; 878 } 879 880 # Check file size, empty files are not allowed 881 if ($size < 1 || $size > $t_max_size) { 882 print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " is too big"); 883 send_data ("SEND ERR\n"); 884 return; 885 } 886 887 # Apply filters 888 $file = "$t_directory/" . apply_filters ($base_name) . $base_name; 889 890 # Check if file exists 891 if (-f $file && $t_overwrite == 0) { 892 print_log ("File '$base_name' size ${size}b from " . $t_client_socket->sockhost () . " already exists"); 893 send_data ("SEND ERR\n"); 894 return; 895 } 896 897 send_data ("SEND OK\n"); 898 899 # Receive file 900 $data = recv_data_block ($size); 901 902 # Write it to disk 903 open (FILE, "> $file") || error ("Cannot open file '$file' for writing."); 904 binmode (FILE); 905 print (FILE $data); 906 close (FILE); 907 908 send_data ("SEND OK\n"); 909 print_log ("Received file '$base_name' size ${size}b from " . $t_client_socket->sockhost ()); 910} 911 912################################################################################ 913## SUB send_file 914## Send a file to the client 915################################################################################ 916sub send_file { 917 my $base_name = $_[0]; 918 my $data = ''; 919 my $file; 920 my $response; 921 my $size; 922 923 # Check file name 924 if ($base_name =~ /[$t_invalid_chars]/) { 925 print_log ("Requested file '$base_name' from " . $t_client_socket->sockhost () . " has an invalid file name"); 926 send_data ("RECV ERR\n"); 927 return; 928 } 929 930 # Apply filters 931 $file = "$t_directory/" . apply_filters ($base_name) . $base_name; 932 933 # Check if file exists 934 if (! -f $file) { 935 print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " does not exist"); 936 send_data ("RECV ERR\n"); 937 return; 938 } 939 940 $size = -s $file; 941 send_data ("RECV SIZE $size\n"); 942 943 # Wait for client response 944 $response = recv_command ($t_block_size); 945 if ($response ne "RECV OK") { 946 print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " not sent"); 947 return; 948 } 949 950 # Send the file 951 open (FILE, $file) || error ("Cannot open file '$file' for reading."); 952 binmode (FILE); 953 954 while ($data = <FILE>) { 955 send_data ($data); 956 } 957 958 close (FILE); 959 960 print_log ("Requested file '$file' from " . $t_client_socket->sockhost () . " sent"); 961} 962 963################################################################################ 964# Common functions 965################################################################################ 966 967################################################################################ 968## SUB print_log 969## Print log messages. 970################################################################################ 971sub print_log { 972 973 if ($t_log == 1) { 974 print (STDOUT "[log] $_[0]\n"); 975 } 976} 977 978################################################################################ 979## SUB error 980## Print an error and exit the program. 981################################################################################ 982sub error { 983 984 if ($t_quiet == 0) { 985 print (STDERR "[err] $_[0]\n"); 986 } 987 988 die("\n"); 989} 990 991################################################################################ 992## SUB recv_data_proxy 993## Recv data from proxy socket. 994################################################################################ 995sub recv_data_proxy { 996 my $data; 997 my $read; 998 my $retries = 0; 999 my $size = $_[0]; 1000 1001 while (1) { 1002 1003 # Try to read data from the socket 1004 if ($t_proxy_select->can_read ($t_timeout)) { 1005 1006 # Read at most $size bytes 1007 $read = sysread ($t_proxy_socket, $data, $size); 1008 1009 # Read error 1010 if (! defined ($read)) { 1011 error ("Read error from " . $t_proxy_socket->sockhost () . ": $!."); 1012 } 1013 1014 # EOF 1015 if ($read == 0) { 1016 error ("Connection from " . $t_proxy_socket->sockhost () . " unexpectedly closed."); 1017 } 1018 1019 return ($read, $data); 1020 } 1021 1022 # Retry 1023 $retries++; 1024 1025 # But check for error conditions first 1026 if ($retries > $t_retries) { 1027 error ("Connection from " . $t_proxy_socket->sockhost () . " timed out."); 1028 } 1029 } 1030} 1031################################################################################ 1032## SUB recv_data 1033## Read data from the client socket. Returns the number of bytes read and the 1034## string of bytes as a two element array. 1035################################################################################ 1036sub recv_data { 1037 my $data; 1038 my $read; 1039 my $retries = 0; 1040 my $size = $_[0]; 1041 1042 while (1) { 1043 1044 # Try to read data from the socket 1045 if ($t_select->can_read ($t_timeout)) { 1046 1047 # Read at most $size bytes 1048 $read = sysread ($t_client_socket, $data, $size); 1049 1050 # Read error 1051 if (! defined ($read)) { 1052 error ("Read error from " . $t_client_socket->sockhost () . ": $!."); 1053 } 1054 1055 # EOF 1056 if ($read == 0) { 1057 error ("Connection from " . $t_client_socket->sockhost () . " unexpectedly closed."); 1058 } 1059 1060 return ($read, $data); 1061 } 1062 1063 # Retry 1064 $retries++; 1065 1066 # But check for error conditions first 1067 if ($retries > $t_retries) { 1068 error ("Connection from " . $t_client_socket->sockhost () . " timed out."); 1069 } 1070 } 1071} 1072 1073################################################################################ 1074## SUB send_data 1075## Write data to the client socket. 1076################################################################################ 1077sub send_data { 1078 my $data = $_[0]; 1079 my $retries = 0; 1080 my $size; 1081 my $total = 0; 1082 my $written; 1083 1084 $size = length ($data); 1085 1086 while (1) { 1087 1088 # Try to write data to the socket 1089 if ($t_select->can_write ($t_timeout)) { 1090 1091 $written = syswrite ($t_client_socket, $data, $size - $total, $total); 1092 1093 # Write error 1094 if (! defined ($written)) { 1095 error ("Connection error from " . $t_client_socket->sockhost () . ": $!."); 1096 } 1097 1098 # EOF 1099 if ($written == 0) { 1100 error ("Connection from " . $t_client_socket->sockhost () . " unexpectedly closed."); 1101 } 1102 1103 } 1104 1105 $total += $written; 1106 1107 # Check if all data was written 1108 if ($total == $size) { 1109 return; 1110 } 1111 1112 # Retry 1113 $retries++; 1114 1115 # But check for error conditions first 1116 if ($retries > $t_retries) { 1117 error ("Connection from " . $t_client_socket->sockhost () . " timed out."); 1118 } 1119 } 1120} 1121 1122################################################################################ 1123## SUB recv_command 1124## Read a command from the client, ended by a new line character. 1125################################################################################ 1126sub recv_command { 1127 my $buffer; 1128 my $char; 1129 my $command = ''; 1130 my $read; 1131 my $total = 0; 1132 1133 while (1) { 1134 1135 ($read, $buffer) = recv_data ($t_block_size); 1136 $command .= $buffer; 1137 $total += $read; 1138 1139 # Check if the command is complete 1140 $char = chop ($command); 1141 if ($char eq "\n") { 1142 return $command; 1143 } 1144 1145 $command .= $char; 1146 1147 # Avoid overflow 1148 if ($total > $t_block_size) { 1149 error ("Received too much data from " . $t_client_socket->sockhost () . "."); 1150 } 1151 } 1152} 1153 1154################################################################################ 1155## SUB recv_data_block 1156## Read $_[0] bytes of data from the client. 1157################################################################################ 1158sub recv_data_block { 1159 my $buffer = ''; 1160 my $data = ''; 1161 my $read; 1162 my $size = $_[0]; 1163 my $total = 0; 1164 1165 while (1) { 1166 1167 ($read, $buffer) = recv_data ($size - $total); 1168 $data .= $buffer; 1169 $total += $read; 1170 1171 # Check if all data has been read 1172 if ($total == $size) { 1173 return $data; 1174 } 1175 } 1176} 1177 1178################################################################################ 1179## SUB ask_passwd 1180## Asks the user for a password. 1181################################################################################ 1182sub ask_passwd { 1183 my $msg1 = $_[0]; 1184 my $msg2 = $_[1]; 1185 my $pwd1; 1186 my $pwd2; 1187 1188 require Term::ReadKey; 1189 1190 # Disable keyboard echo 1191 Term::ReadKey::ReadMode('noecho'); 1192 1193 # Promt for password 1194 print ($msg1); 1195 $pwd1 = Term::ReadKey::ReadLine(0); 1196 print ("\n$msg2"); 1197 $pwd2 = Term::ReadKey::ReadLine(0); 1198 print ("\n"); 1199 1200 # Restore original settings 1201 Term::ReadKey::ReadMode('restore'); 1202 1203 if ($pwd1 ne $pwd2) { 1204 print ("Error: passwords do not match.\n"); 1205 exit 1; 1206 } 1207 1208 # Remove the trailing new line character 1209 chop $pwd1; 1210 1211 return $pwd1; 1212} 1213 1214################################################################################ 1215## SUB apply_filters 1216## Applies filters to the given file. 1217################################################################################ 1218sub apply_filters ($) { 1219 my ($file_name) = @_; 1220 1221 foreach my $filter (@t_filters) { 1222 my ($regexp, $dir) = @{$filter}; 1223 if ($file_name =~ /$regexp/) { 1224 print_log ("File '$file_name' matches filter '$regexp' (changing to directory '$dir')"); 1225 return $dir . '/'; 1226 } 1227 } 1228 1229 return ''; 1230} 1231 1232################################################################################ 1233## SUB install_service 1234## Install the Windows service. 1235################################################################################ 1236sub install_service() { 1237 1238 my $service_path = $0; 1239 my $service_params = $SERVICE_PARAMS; 1240 1241 # Change the service parameter from 'install' to 'run'. 1242 $service_params =~ s/\-S\s+\S+/\-S run/; 1243 1244 my %service_hash = ( 1245 machine => '', 1246 name => 'TENTACLESRV', 1247 display => $SERVICE_NAME, 1248 path => $service_path, 1249 user => '', 1250 pwd => '', 1251 description => 'Tentacle Server http://sourceforge.net/projects/tentacled/', 1252 parameters => $service_params 1253 ); 1254 1255 if (Win32::Daemon::CreateService(\%service_hash)) { 1256 print "Successfully added.\n"; 1257 exit 0; 1258 } else { 1259 print "Failed to add service: " . Win32::FormatMessage(Win32::Daemon::GetLastError()) . "\n"; 1260 exit 1; 1261 } 1262} 1263 1264################################################################################ 1265## SUB uninstall_service 1266## Install the Windows service. 1267################################################################################ 1268sub uninstall_service() { 1269 if (Win32::Daemon::DeleteService('', 'TENTACLESRV')) { 1270 print "Successfully deleted.\n"; 1271 exit 0; 1272 } else { 1273 print "Failed to delete service: " . Win32::FormatMessage(Win32::Daemon::GetLastError()) . "\n"; 1274 exit 1; 1275 } 1276} 1277 1278################################################################################ 1279## SUB callback_running 1280## Windows service callback function for the running event. 1281################################################################################ 1282sub callback_running { 1283 1284 if (Win32::Daemon::State() == WIN32_SERVICE_RUNNING) { 1285 } 1286} 1287 1288################################################################################ 1289## SUB callback_start 1290## Windows service callback function for the start event. 1291################################################################################ 1292sub callback_start { 1293 1294 # Accept_connections (); 1295 my $thr = threads->create(\&accept_connections); 1296 if (!defined($thr)) { 1297 Win32::Daemon::State(WIN32_SERVICE_STOPPED); 1298 Win32::Daemon::StopService(); 1299 return; 1300 } 1301 $thr->detach(); 1302 1303 Win32::Daemon::State(WIN32_SERVICE_RUNNING); 1304} 1305 1306################################################################################ 1307## SUB callback_stop 1308## Windows service callback function for the stop event. 1309################################################################################ 1310sub callback_stop { 1311 1312 foreach my $t_server_socket (@t_server_sockets) { 1313 $t_server_socket->shutdown (2); 1314 $t_server_socket->close (); 1315 } 1316 1317 Win32::Daemon::State(WIN32_SERVICE_STOPPED); 1318 Win32::Daemon::StopService(); 1319} 1320 1321################################################################################ 1322# Main 1323################################################################################ 1324 1325# Never run as root 1326if ($> == 0 && $^O ne 'MSWin32') { 1327 print ("Error: for safety reasons $0 cannot be run with root privileges.\n"); 1328 exit 1; 1329} 1330 1331# Parse command line options 1332parse_options (); 1333 1334# Check command line arguments 1335if ($#ARGV != -1) { 1336 print_help (); 1337 exit 1; 1338} 1339 1340# Show IPv6 status 1341if ($SOCKET_MODULE eq 'IO::Socket::INET') { 1342 print_log ("IO::Socket::INET6 is not found. IPv6 is disabled."); 1343} 1344 1345# Run as daemon? 1346if ($t_daemon == 1 && $^O ne 'MSWin32') { 1347 daemonize (); 1348} 1349 1350# Handle ctr-c 1351if ($^O eq 'MSWin32') { 1352 no warnings; 1353 $SIG{INT2} = \&stop_server; 1354 use warnings; 1355} 1356else { 1357 $SIG{INT} = \&stop_server; 1358} 1359 1360# Accept connections 1361accept_connections(); 1362 1363__END__ 1364 1365=head1 REQUIRED ARGUMENTES 1366 1367=over 1368 1369=item B<< -s F<storage_directory> >> Root directory to store the files received by the server 1370 1371=back 1372 1373=head1 OPTIONS 1374 1375=over 1376 1377=item I<-a ip_address> Address to B<listen> on (default I<0.0.0.0>). 1378 1379=item I<-c number> B<Maximum> number of simultaneous B<connections> (default I<10>). 1380 1381=item I<-d> Run as B<daemon>. 1382 1383=item I<-e cert> B<OpenSSL certificate> file. Enables SSL. 1384 1385=item I<-f ca_cert> Verify that the peer certificate is signed by a B<CA>. 1386 1387=item I<-h> Show B<help>. 1388 1389=item I<-i> B<Filters>. 1390 1391=item I<-k key> B<OpenSSL private key> file. 1392 1393=item I<-m size> B<Maximum file size> in bytes (default I<2000000b>). 1394 1395=item I<-o> Enable file B<overwrite>. 1396 1397=item I<-p port> B<Port to listen> on (default I<41121>). 1398 1399=item I<-q> B<Quiet>. Do now print error messages. 1400 1401=item I<-r number> B<Number of retries> for network opertions (default I<3>). 1402 1403=item I<-t time> B<Time-out> for network operations in B<seconds> (default I<1s>). 1404 1405=item I<-v> Be B<verbose>. 1406 1407=item I<-w> Prompt for B<OpenSSL private key password>. 1408 1409=item I<-x> pwd B<Server password>. 1410 1411=back 1412 1413=head1 EXIT STATUS 1414 1415=over 1416 1417=item 0 on Success 1418 1419=item 1 on Error 1420 1421=back 1422 1423=head1 CONFIGURATION 1424 1425Tentacle doesn't use any configurationf files, all the configuration is done by the options passed when it's started. 1426 1427=head1 DEPENDENCIES 1428 1429L<Getopt::Std>, L<IO::Select>, L<IO::Socket::INET>, L<Thread::Semaphore>, L<POSIX> 1430 1431 1432=head1 LICENSE 1433 1434This is released under the GNU Lesser General Public License. 1435 1436=head1 SEE ALSO 1437 1438L<Getopt::Std>, L<IO::Select>, L<IO::Socket::INET>, L<Thread::Semaphore>, L<POSIX> 1439 1440Protocol description and more info at: L<< http://openideas.info/wiki/index.php?title=Tentacle >> 1441 1442=head1 COPYRIGHT 1443 1444Copyright (c) 2005-2010 Artica Soluciones Tecnologicas S.L 1445 1446=cut 1447 1448