1# Part of this code was borrowed from Richard Jones's Net::FTPServer 2# http://www.annexia.org/freeware/netftpserver 3 4package FTPServer; 5 6use strict; 7use warnings; 8 9use Cwd; 10use Socket; 11use IO::Socket::INET; 12use IO::Seekable; 13use POSIX qw(strftime); 14 15my $log = undef; 16my $GOT_SIGURG = 0; 17 18# CONSTANTS 19 20# connection states 21my %_connection_states = ( 22 'NEWCONN' => 0x01, 23 'WAIT4PWD' => 0x02, 24 'LOGGEDIN' => 0x04, 25 'TWOSOCKS' => 0x08, 26); 27 28# subset of FTP commands supported by these server and the respective 29# connection states in which they are allowed 30my %_commands = ( 31 # Standard commands from RFC 959. 32 'CWD' => $_connection_states{LOGGEDIN} | 33 $_connection_states{TWOSOCKS}, 34# 'EPRT' => $_connection_states{LOGGEDIN}, 35# 'EPSV' => $_connection_states{LOGGEDIN}, 36 'LIST' => $_connection_states{TWOSOCKS}, 37# 'LPRT' => $_connection_states{LOGGEDIN}, 38# 'LPSV' => $_connection_states{LOGGEDIN}, 39 'PASS' => $_connection_states{WAIT4PWD}, 40 'PASV' => $_connection_states{LOGGEDIN}, 41 'PORT' => $_connection_states{LOGGEDIN}, 42 'PWD' => $_connection_states{LOGGEDIN} | 43 $_connection_states{TWOSOCKS}, 44 'QUIT' => $_connection_states{LOGGEDIN} | 45 $_connection_states{TWOSOCKS}, 46 'REST' => $_connection_states{TWOSOCKS}, 47 'RETR' => $_connection_states{TWOSOCKS}, 48 'SYST' => $_connection_states{LOGGEDIN}, 49 'TYPE' => $_connection_states{LOGGEDIN} | 50 $_connection_states{TWOSOCKS}, 51 'USER' => $_connection_states{NEWCONN}, 52 # From ftpexts Internet Draft. 53 'SIZE' => $_connection_states{LOGGEDIN} | 54 $_connection_states{TWOSOCKS}, 55); 56 57 58 59# COMMAND-HANDLING ROUTINES 60 61sub _CWD_command 62{ 63 my ($conn, $cmd, $path) = @_; 64 my $paths = $conn->{'paths'}; 65 66 local $_; 67 my $new_path = FTPPaths::path_merge($conn->{'dir'}, $path); 68 69 # Split the path into its component parts and process each separately. 70 if (! $paths->dir_exists($new_path)) { 71 print {$conn->{socket}} "550 Directory not found.\r\n"; 72 return; 73 } 74 75 $conn->{'dir'} = $new_path; 76 print {$conn->{socket}} "200 directory changed to $new_path.\r\n"; 77} 78 79sub _LIST_command 80{ 81 my ($conn, $cmd, $path) = @_; 82 my $paths = $conn->{'paths'}; 83 84 # This is something of a hack. Some clients expect a Unix server 85 # to respond to flags on the 'ls command line'. Remove these flags 86 # and ignore them. This is particularly an issue with ncftp 2.4.3. 87 $path =~ s/^-[a-zA-Z0-9]+\s?//; 88 89 my $dir = $conn->{'dir'}; 90 91 print STDERR "_LIST_command - dir is: $dir\n"; 92 93 # Parse the first elements of the path until we find the appropriate 94 # working directory. 95 local $_; 96 97 $dir = FTPPaths::path_merge($dir, $path); 98 my $listing = $paths->get_list($dir); 99 unless ($listing) { 100 print {$conn->{socket}} "550 File or directory not found.\r\n"; 101 return; 102 } 103 104 print STDERR "_LIST_command - dir is: $dir\n" if $log; 105 106 print {$conn->{socket}} "150 Opening data connection for file listing.\r\n"; 107 108 # Open a path back to the client. 109 my $sock = __open_data_connection ($conn); 110 unless ($sock) { 111 print {$conn->{socket}} "425 Can't open data connection.\r\n"; 112 return; 113 } 114 115 for my $item (@$listing) { 116 print $sock "$item\r\n"; 117 } 118 119 unless ($sock->close) { 120 print {$conn->{socket}} "550 Error closing data connection: $!\r\n"; 121 return; 122 } 123 124 print {$conn->{socket}} "226 Listing complete. Data connection has been closed.\r\n"; 125} 126 127sub _PASS_command 128{ 129 my ($conn, $cmd, $pass) = @_; 130 131 # TODO: implement authentication? 132 133 print STDERR "switching to LOGGEDIN state\n" if $log; 134 $conn->{state} = $_connection_states{LOGGEDIN}; 135 136 if ($conn->{username} eq "anonymous") { 137 print {$conn->{socket}} "202 Anonymous user access is always granted.\r\n"; 138 } else { 139 print {$conn->{socket}} "230 Authentication not implemented yet, access is always granted.\r\n"; 140 } 141} 142 143sub _PASV_command 144{ 145 my ($conn, $cmd, $rest) = @_; 146 147 # Open a listening socket - but don't actually accept on it yet. 148 "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround. 149 my $sock = IO::Socket::INET->new (LocalHost => '127.0.0.1', 150 LocalPort => '0', 151 Listen => 1, 152 Reuse => 1, 153 Proto => 'tcp', 154 Type => SOCK_STREAM); 155 156 unless ($sock) { 157 # Return a code 550 here, even though this is not in the RFC. XXX 158 print {$conn->{socket}} "550 Can't open a listening socket.\r\n"; 159 return; 160 } 161 162 $conn->{passive} = 1; 163 $conn->{passive_socket} = $sock; 164 165 # Get our port number. 166 my $sockport = $sock->sockport; 167 168 # Split the port number into high and low components. 169 my $p1 = int ($sockport / 256); 170 my $p2 = $sockport % 256; 171 172 $conn->{state} = $_connection_states{TWOSOCKS}; 173 174 # We only accept connections from localhost. 175 print {$conn->{socket}} "227 Entering Passive Mode (127,0,0,1,$p1,$p2)\r\n"; 176} 177 178sub _PORT_command 179{ 180 my ($conn, $cmd, $rest) = @_; 181 182 # The arguments to PORT are a1,a2,a3,a4,p1,p2 where a1 is the 183 # most significant part of the address (eg. 127,0,0,1) and 184 # p1 is the most significant part of the port. 185 unless ($rest =~ /^\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3})/) { 186 print {$conn->{socket}} "501 Syntax error in PORT command.\r\n"; 187 return; 188 } 189 190 # Check host address. 191 unless ($1 > 0 && $1 < 224 && 192 $2 >= 0 && $2 < 256 && 193 $3 >= 0 && $3 < 256 && 194 $4 >= 0 && $4 < 256) { 195 print {$conn->{socket}} "501 Invalid host address.\r\n"; 196 return; 197 } 198 199 # Construct host address and port number. 200 my $peeraddrstring = "$1.$2.$3.$4"; 201 my $peerport = $5 * 256 + $6; 202 203 # Check port number. 204 unless ($peerport > 0 && $peerport < 65536) { 205 print {$conn->{socket}} "501 Invalid port number.\r\n"; 206 } 207 208 $conn->{peeraddrstring} = $peeraddrstring; 209 $conn->{peeraddr} = inet_aton ($peeraddrstring); 210 $conn->{peerport} = $peerport; 211 $conn->{passive} = 0; 212 213 $conn->{state} = $_connection_states{TWOSOCKS}; 214 215 print {$conn->{socket}} "200 PORT command OK.\r\n"; 216} 217 218sub _PWD_command 219{ 220 my ($conn, $cmd, $rest) = @_; 221 222 # See RFC 959 Appendix II and draft-ietf-ftpext-mlst-11.txt section 6.2.1. 223 my $pathname = $conn->{dir}; 224 $pathname =~ s,/+$,, unless $pathname eq "/"; 225 $pathname =~ tr,/,/,s; 226 227 print {$conn->{socket}} "257 \"$pathname\"\r\n"; 228} 229 230sub _REST_command 231{ 232 my ($conn, $cmd, $restart_from) = @_; 233 234 unless ($restart_from =~ /^([1-9][0-9]*|0)$/) { 235 print {$conn->{socket}} "501 REST command needs a numeric argument.\r\n"; 236 return; 237 } 238 239 $conn->{restart} = $1; 240 241 print {$conn->{socket}} "350 Restarting next transfer at $1.\r\n"; 242} 243 244sub _RETR_command 245{ 246 my ($conn, $cmd, $path) = @_; 247 248 $path = FTPPaths::path_merge($conn->{dir}, $path); 249 my $info = $conn->{'paths'}->get_info($path); 250 251 unless ($info->{'_type'} eq 'f') { 252 print {$conn->{socket}} "550 File not found.\r\n"; 253 return; 254 } 255 256 print {$conn->{socket}} "150 Opening " . 257 ($conn->{type} eq 'A' ? "ASCII mode" : "BINARY mode") . 258 " data connection.\r\n"; 259 260 # Open a path back to the client. 261 my $sock = __open_data_connection ($conn); 262 263 unless ($sock) { 264 print {$conn->{socket}} "425 Can't open data connection.\r\n"; 265 return; 266 } 267 268 my $content = $info->{'content'}; 269 270 # Restart the connection from previous point? 271 if ($conn->{restart}) { 272 $content = substr($content, $conn->{restart}); 273 $conn->{restart} = 0; 274 } 275 276 # What mode are we sending this file in? 277 unless ($conn->{type} eq 'A') # Binary type. 278 { 279 my ($r, $buffer, $n, $w); 280 281 282 # Copy data. 283 while ($buffer = substr($content, 0, 65536)) 284 { 285 $r = length $buffer; 286 287 # Restart alarm clock timer. 288 alarm $conn->{idle_timeout}; 289 290 for ($n = 0; $n < $r; ) 291 { 292 $w = syswrite ($sock, $buffer, $r - $n, $n); 293 294 # Cleanup and exit if there was an error. 295 unless (defined $w) { 296 close $sock; 297 print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n"; 298 return; 299 } 300 301 $n += $w; 302 } 303 304 # Transfer aborted by client? 305 if ($GOT_SIGURG) { 306 $GOT_SIGURG = 0; 307 close $sock; 308 print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n"; 309 return; 310 } 311 } 312 313 # Cleanup and exit if there was an error. 314 unless (defined $r) { 315 close $sock; 316 print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n"; 317 return; 318 } 319 } else { # ASCII type. 320 # Copy data. 321 my @lines = split /\r\n?|\n/, $content; 322 for (@lines) { 323 # Remove any native line endings. 324 s/[\n\r]+$//; 325 326 # Restart alarm clock timer. 327 alarm $conn->{idle_timeout}; 328 329 # Write the line with telnet-format line endings. 330 print $sock "$_\r\n"; 331 332 # Transfer aborted by client? 333 if ($GOT_SIGURG) { 334 $GOT_SIGURG = 0; 335 close $sock; 336 print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n"; 337 return; 338 } 339 } 340 } 341 342 unless (close ($sock)) { 343 print {$conn->{socket}} "550 File retrieval error: $!.\r\n"; 344 return; 345 } 346 347 print {$conn->{socket}} "226 File retrieval complete. Data connection has been closed.\r\n"; 348} 349 350sub _SIZE_command 351{ 352 my ($conn, $cmd, $path) = @_; 353 354 $path = FTPPaths::path_merge($conn->{dir}, $path); 355 my $info = $conn->{'paths'}->get_info($path); 356 unless ($info) { 357 print {$conn->{socket}} "550 File or directory not found.\r\n"; 358 return; 359 } 360 361 if ($info->{'_type'} eq 'd') { 362 print {$conn->{socket}} "550 SIZE command is not supported on directories.\r\n"; 363 return; 364 } 365 366 my $size = length $info->{'content'}; 367 368 print {$conn->{socket}} "213 $size\r\n"; 369} 370 371sub _SYST_command 372{ 373 my ($conn, $cmd, $dummy) = @_; 374 375 print {$conn->{socket}} "215 UNIX Type: L8\r\n"; 376} 377 378sub _TYPE_command 379{ 380 my ($conn, $cmd, $type) = @_; 381 382 # See RFC 959 section 5.3.2. 383 if ($type =~ /^([AI])$/i) { 384 $conn->{type} = 'A'; 385 } elsif ($type =~ /^([AI])\sN$/i) { 386 $conn->{type} = 'A'; 387 } elsif ($type =~ /^L\s8$/i) { 388 $conn->{type} = 'L8'; 389 } else { 390 print {$conn->{socket}} "504 This server does not support TYPE $type.\r\n"; 391 return; 392 } 393 394 print {$conn->{socket}} "200 TYPE changed to $type.\r\n"; 395} 396 397sub _USER_command 398{ 399 my ($conn, $cmd, $username) = @_; 400 401 print STDERR "username: $username\n" if $log; 402 $conn->{username} = $username; 403 404 print STDERR "switching to WAIT4PWD state\n" if $log; 405 $conn->{state} = $_connection_states{WAIT4PWD}; 406 407 if ($conn->{username} eq "anonymous") { 408 print {$conn->{socket}} "230 Anonymous user access granted.\r\n"; 409 } else { 410 print {$conn->{socket}} "331 Password required.\r\n"; 411 } 412} 413 414 415# HELPER ROUTINES 416 417sub __open_data_connection 418{ 419 my $conn = shift; 420 421 my $sock; 422 423 if ($conn->{passive}) { 424 # Passive mode - wait for a connection from the client. 425 accept ($sock, $conn->{passive_socket}) or return undef; 426 } else { 427 # Active mode - connect back to the client. 428 "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround. 429 $sock = IO::Socket::INET->new (LocalAddr => '127.0.0.1', 430 PeerAddr => $conn->{peeraddrstring}, 431 PeerPort => $conn->{peerport}, 432 Proto => 'tcp', 433 Type => SOCK_STREAM) or return undef; 434 } 435 436 return $sock; 437} 438 439 440########################################################################### 441# FTPSERVER CLASS 442########################################################################### 443 444{ 445 my %_attr_data = ( # DEFAULT 446 _input => undef, 447 _localAddr => 'localhost', 448 _localPort => undef, 449 _reuseAddr => 1, 450 _rootDir => Cwd::getcwd(), 451 _server_behavior => {}, 452 ); 453 454 sub _default_for 455 { 456 my ($self, $attr) = @_; 457 $_attr_data{$attr}; 458 } 459 460 sub _standard_keys 461 { 462 keys %_attr_data; 463 } 464} 465 466 467sub new { 468 my ($caller, %args) = @_; 469 my $caller_is_obj = ref($caller); 470 my $class = $caller_is_obj || $caller; 471 my $self = bless {}, $class; 472 foreach my $attrname ($self->_standard_keys()) { 473 my ($argname) = ($attrname =~ /^_(.*)/); 474 if (exists $args{$argname}) { 475 $self->{$attrname} = $args{$argname}; 476 } elsif ($caller_is_obj) { 477 $self->{$attrname} = $caller->{$attrname}; 478 } else { 479 $self->{$attrname} = $self->_default_for($attrname); 480 } 481 } 482 # create server socket 483 "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround. 484 $self->{_server_sock} 485 = IO::Socket::INET->new (LocalHost => $self->{_localAddr}, 486 LocalPort => $self->{_localPort}, 487 Listen => 1, 488 Reuse => $self->{_reuseAddr}, 489 Proto => 'tcp', 490 Type => SOCK_STREAM) 491 or die "bind: $!"; 492 return $self; 493} 494 495 496sub run 497{ 498 my ($self, $synch_callback) = @_; 499 my $initialized = 0; 500 501 # turn buffering off on STDERR 502 select((select(STDERR), $|=1)[0]); 503 504 # initialize command table 505 my $command_table = {}; 506 foreach (keys %_commands) { 507 my $subname = "_${_}_command"; 508 $command_table->{$_} = \&$subname; 509 } 510 511 my $old_ils = $/; 512 $/ = "\r\n"; 513 514 if (!$initialized) { 515 $synch_callback->(); 516 $initialized = 1; 517 } 518 519 $SIG{CHLD} = sub { wait }; 520 my $server_sock = $self->{_server_sock}; 521 522 # the accept loop 523 while (my $client_addr = accept (my $socket, $server_sock)) 524 { 525 # turn buffering off on $socket 526 select((select($socket), $|=1)[0]); 527 528 # find out who connected 529 my ($client_port, $client_ip) = sockaddr_in ($client_addr); 530 my $client_ipnum = inet_ntoa ($client_ip); 531 532 # print who connected 533 print STDERR "got a connection from: $client_ipnum\n" if $log; 534 535 # fork off a process to handle this connection. 536 # my $pid = fork(); 537 # unless (defined $pid) { 538 # warn "fork: $!"; 539 # sleep 5; # Back off in case system is overloaded. 540 # next; 541 # } 542 543 if (1) { # Child process. 544 545 # install signals 546 $SIG{URG} = sub { 547 $GOT_SIGURG = 1; 548 }; 549 550 $SIG{PIPE} = sub { 551 print STDERR "Client closed connection abruptly.\n"; 552 exit; 553 }; 554 555 $SIG{ALRM} = sub { 556 print STDERR "Connection idle timeout expired. Closing server.\n"; 557 exit; 558 }; 559 560 #$SIG{CHLD} = 'IGNORE'; 561 562 563 print STDERR "in child\n" if $log; 564 565 my $conn = { 566 'paths' => FTPPaths->new($self->{'_input'}, 567 $self->{'_server_behavior'}), 568 'socket' => $socket, 569 'state' => $_connection_states{NEWCONN}, 570 'dir' => '/', 571 'restart' => 0, 572 'idle_timeout' => 60, # 1 minute timeout 573 'rootdir' => $self->{_rootDir}, 574 }; 575 576 print {$conn->{socket}} "220 GNU Wget Testing FTP Server ready.\r\n"; 577 578 # command handling loop 579 for (;;) { 580 print STDERR "waiting for request\n" if $log; 581 582 last unless defined (my $req = <$socket>); 583 584 # Remove trailing CRLF. 585 $req =~ s/[\n\r]+$//; 586 587 print STDERR "received request $req\n" if $log; 588 589 # Get the command. 590 # See also RFC 2640 section 3.1. 591 unless ($req =~ m/^([A-Z]{3,4})\s?(.*)/i) { 592 # badly formed command 593 exit 0; 594 } 595 596 # The following strange 'eval' is necessary to work around a 597 # very odd bug in Perl 5.6.0. The following assignment to 598 # $cmd will fail in some cases unless you use $1 in some sort 599 # of an expression beforehand. 600 # - RWMJ 2002-07-05. 601 eval '$1 eq $1'; 602 603 my ($cmd, $rest) = (uc $1, $2); 604 605 # Got a command which matches in the table? 606 unless (exists $command_table->{$cmd}) { 607 print {$conn->{socket}} "500 Unrecognized command.\r\n"; 608 next; 609 } 610 611 # Command requires user to be authenticated? 612 unless ($_commands{$cmd} | $conn->{state}) { 613 print {$conn->{socket}} "530 Not logged in.\r\n"; 614 next; 615 } 616 617 # Handle the QUIT command specially. 618 if ($cmd eq "QUIT") { 619 print {$conn->{socket}} "221 Goodbye. Service closing connection.\r\n"; 620 last; 621 } 622 623 if (defined ($self->{_server_behavior}{fail_on_pasv}) 624 && $cmd eq 'PASV') { 625 undef $self->{_server_behavior}{fail_on_pasv}; 626 close $socket; 627 last; 628 } 629 630 # Run the command. 631 &{$command_table->{$cmd}} ($conn, $cmd, $rest); 632 } 633 } else { # Father 634 close $socket; 635 } 636 } 637 638 $/ = $old_ils; 639} 640 641sub sockport { 642 my $self = shift; 643 return $self->{_server_sock}->sockport; 644} 645 646 647package FTPPaths; 648 649use POSIX qw(strftime); 650 651# not a method 652sub final_component { 653 my $path = shift; 654 655 $path =~ s|.*/||; 656 return $path; 657} 658 659# not a method 660sub path_merge { 661 my ($a, $b) = @_; 662 663 return $a unless $b; 664 665 if ($b =~ m.^/.) { 666 $a = ''; 667 $b =~ s.^/..; 668 } 669 $a =~ s./$..; 670 671 my @components = split('/', $b); 672 673 foreach my $c (@components) { 674 if ($c =~ /^\.?$/) { 675 next; 676 } elsif ($c eq '..') { 677 next if $a eq ''; 678 $a =~ s|/[^/]*$||; 679 } else { 680 $a .= "/$c"; 681 } 682 } 683 684 return $a; 685} 686 687sub new { 688 my ($this, @args) = @_; 689 my $class = ref($this) || $this; 690 my $self = {}; 691 bless $self, $class; 692 $self->initialize(@args); 693 return $self; 694} 695 696sub initialize { 697 my ($self, $urls, $behavior) = @_; 698 my $paths = {_type => 'd'}; 699 700 # From a path like '/foo/bar/baz.txt', construct $paths such that 701 # $paths->{'foo'}->{'bar'}->{'baz.txt'} is 702 # $urls->{'/foo/bar/baz.txt'}. 703 for my $path (keys %$urls) { 704 my @components = split('/', $path); 705 shift @components; 706 my $x = $paths; 707 for my $c (@components) { 708 unless (exists $x->{$c}) { 709 $x->{$c} = {_type => 'd'}; 710 } 711 $x = $x->{$c}; 712 } 713 %$x = %{$urls->{$path}}; 714 $x->{_type} = 'f'; 715 } 716 717 $self->{'_paths'} = $paths; 718 $self->{'_behavior'} = $behavior; 719} 720 721sub get_info { 722 my ($self, $path, $node) = @_; 723 $node = $self->{'_paths'} unless $node; 724 my @components = split('/', $path); 725 shift @components if @components && $components[0] eq ''; 726 727 for my $c (@components) { 728 if ($node->{'_type'} eq 'd') { 729 $node = $node->{$c}; 730 } else { 731 return undef; 732 } 733 } 734 return $node; 735} 736 737sub dir_exists { 738 my ($self, $path) = @_; 739 return $self->exists($path, 'd'); 740} 741 742sub exists { 743 # type is optional, in which case we don't check it. 744 my ($self, $path, $type) = @_; 745 my $paths = $self->{'_paths'}; 746 747 die "Invalid path $path (not absolute).\n" unless $path =~ m.^/.; 748 my $info = $self->get_info($path); 749 return 0 unless defined($info); 750 return $info->{'_type'} eq $type if defined($type); 751 return 1; 752} 753 754sub _format_for_list { 755 my ($self, $name, $info) = @_; 756 757 # XXX: mode should be specifyable as part of the node info. 758 my $mode_str; 759 if ($info->{'_type'} eq 'd') { 760 $mode_str = 'dr-xr-xr-x'; 761 } else { 762 $mode_str = '-r--r--r--'; 763 } 764 765 my $size = 0; 766 if ($info->{'_type'} eq 'f') { 767 $size = length $info->{'content'}; 768 if ($self->{'_behavior'}{'bad_list'}) { 769 $size = 0; 770 } 771 } 772 my $date = strftime ("%b %e %H:%M", localtime); 773 return "$mode_str 1 0 0 $size $date $name"; 774} 775 776sub get_list { 777 my ($self, $path) = @_; 778 my $info = $self->get_info($path); 779 return undef unless defined $info; 780 my $list = []; 781 782 if ($info->{'_type'} eq 'd') { 783 for my $item (keys %$info) { 784 next if $item =~ /^_/; 785 push @$list, $self->_format_for_list($item, $info->{$item}); 786 } 787 } else { 788 push @$list, $self->_format_for_list(final_component($path), $info); 789 } 790 791 return $list; 792} 793 7941; 795 796# vim: et ts=4 sw=4 797