path: root/tests/FTPServer.pm

# Part of this code was borrowed from Richard Jones's Net::FTPServer
# http://www.annexia.org/freeware/netftpserver

package FTPServer;

use strict;
use warnings;

use Cwd;
use Socket;
use IO::Socket::INET;
use IO::Seekable;
use POSIX qw(strftime);

my $log        = undef;
my $GOT_SIGURG = 0;

# CONSTANTS

# connection states
my %_connection_states = (
    'NEWCONN'  => 0x01,
    'WAIT4PWD' => 0x02,
    'LOGGEDIN' => 0x04,
    'TWOSOCKS' => 0x08,
);

# subset of FTP commands supported by these server and the respective
# connection states in which they are allowed
my %_commands = (
    # Standard commands from RFC 959.
    'CWD'  => $_connection_states{LOGGEDIN} |
              $_connection_states{TWOSOCKS},
#   'EPRT' => $_connection_states{LOGGEDIN},
#   'EPSV' => $_connection_states{LOGGEDIN},
    'LIST' => $_connection_states{TWOSOCKS},
#   'LPRT' => $_connection_states{LOGGEDIN},
#   'LPSV' => $_connection_states{LOGGEDIN},
    'PASS' => $_connection_states{WAIT4PWD},
    'PASV' => $_connection_states{LOGGEDIN},
    'PORT' => $_connection_states{LOGGEDIN},
    'PWD'  => $_connection_states{LOGGEDIN} |
              $_connection_states{TWOSOCKS},
    'QUIT' => $_connection_states{LOGGEDIN} |
              $_connection_states{TWOSOCKS},
    'REST' => $_connection_states{TWOSOCKS},
    'RETR' => $_connection_states{TWOSOCKS},
    'SYST' => $_connection_states{LOGGEDIN},
    'TYPE' => $_connection_states{LOGGEDIN} |
              $_connection_states{TWOSOCKS},
    'USER' => $_connection_states{NEWCONN},
    # From ftpexts Internet Draft.
    'SIZE' => $_connection_states{LOGGEDIN} |
              $_connection_states{TWOSOCKS},
);



# COMMAND-HANDLING ROUTINES

sub _CWD_command
{
    my ($conn, $cmd, $path) = @_;
    my $paths = $conn->{'paths'};

    local $_;
    my $new_path = FTPPaths::path_merge($conn->{'dir'}, $path);

    # Split the path into its component parts and process each separately.
    if (! $paths->dir_exists($new_path)) {
        print {$conn->{socket}} "550 Directory not found.\r\n";
        return;
    }

    $conn->{'dir'} = $new_path;
    print {$conn->{socket}} "200 directory changed to $new_path.\r\n";
}

sub _LIST_command
{
    my ($conn, $cmd, $path) = @_;
    my $paths = $conn->{'paths'};

    my $ReturnEmptyList = ( $paths->GetBehavior('list_empty_if_list_a') &&
                            $path eq '-a');
    my $SkipHiddenFiles = ( $paths->GetBehavior('list_no_hidden_if_list') &&
                            ( ! $path ) );

    if ($paths->GetBehavior('list_fails_if_list_a') && $path eq '-a')
      {
            print {$conn->{socket}} "500 Unknown command\r\n";
            return;
      }


    if (!$paths->GetBehavior('list_dont_clean_path'))
      {
        # This is something of a hack. Some clients expect a Unix server
        # to respond to flags on the 'ls command line'. Remove these flags
        # and ignore them. This is particularly an issue with ncftp 2.4.3.
        $path =~ s/^-[a-zA-Z0-9]+\s?//;
      }

    my $dir = $conn->{'dir'};

    print STDERR "_LIST_command - dir is: $dir\n";

    # Parse the first elements of the path until we find the appropriate
    # working directory.
    local $_;

    my $listing;
    if (!$ReturnEmptyList)
      {
        $dir = FTPPaths::path_merge($dir, $path);
        $listing = $paths->get_list($dir,$SkipHiddenFiles);
        unless ($listing) {
            print {$conn->{socket}} "550 File or directory not found.\r\n";
            return;
        }
      }

    print STDERR "_LIST_command - dir is: $dir\n" if $log;

    print {$conn->{socket}} "150 Opening data connection for file listing.\r\n";

    # Open a path back to the client.
    my $sock = __open_data_connection ($conn);
    unless ($sock) {
        print {$conn->{socket}} "425 Can't open data connection.\r\n";
        return;
    }

    if (!$ReturnEmptyList)
      {
        for my $item (@$listing) {
            print $sock "$item\r\n";
        }
      }

    unless ($sock->close) {
        print {$conn->{socket}} "550 Error closing data connection: $!\r\n";
        return;
    }

    print {$conn->{socket}} "226 Listing complete. Data connection has been closed.\r\n";
}

sub _PASS_command
{
    my ($conn, $cmd, $pass) = @_;

    # TODO: implement authentication?

    print STDERR "switching to LOGGEDIN state\n" if $log;
    $conn->{state} = $_connection_states{LOGGEDIN};

    if ($conn->{username} eq "anonymous") {
        print {$conn->{socket}} "202 Anonymous user access is always granted.\r\n";
    } else {
        print {$conn->{socket}} "230 Authentication not implemented yet, access is always granted.\r\n";
    }
}

sub _PASV_command
{
    my ($conn, $cmd, $rest) = @_;

    # Open a listening socket - but don't actually accept on it yet.
    "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
    my $sock = IO::Socket::INET->new (LocalHost => '127.0.0.1',
                                      LocalPort => '0',
                                      Listen => 1,
                                      Reuse => 1,
                                      Proto => 'tcp',
                                      Type => SOCK_STREAM);

    unless ($sock) {
        # Return a code 550 here, even though this is not in the RFC. XXX
        print {$conn->{socket}} "550 Can't open a listening socket.\r\n";
        return;
    }

    $conn->{passive} = 1;
    $conn->{passive_socket} = $sock;

    # Get our port number.
    my $sockport = $sock->sockport;

    # Split the port number into high and low components.
    my $p1 = int ($sockport / 256);
    my $p2 = $sockport % 256;

    $conn->{state} = $_connection_states{TWOSOCKS};

    # We only accept connections from localhost.
    print {$conn->{socket}} "227 Entering Passive Mode (127,0,0,1,$p1,$p2)\r\n";
}

sub _PORT_command
{
    my ($conn, $cmd, $rest) = @_;

    # The arguments to PORT are a1,a2,a3,a4,p1,p2 where a1 is the
    # most significant part of the address (eg. 127,0,0,1) and
    # p1 is the most significant part of the port.
    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})/) {
        print {$conn->{socket}} "501 Syntax error in PORT command.\r\n";
        return;
    }

    # Check host address.
    unless ($1  > 0 && $1 < 224 &&
            $2 >= 0 && $2 < 256 &&
            $3 >= 0 && $3 < 256 &&
            $4 >= 0 && $4 < 256) {
        print {$conn->{socket}} "501 Invalid host address.\r\n";
        return;
    }

    # Construct host address and port number.
    my $peeraddrstring = "$1.$2.$3.$4";
    my $peerport = $5 * 256 + $6;

    # Check port number.
    unless ($peerport > 0 && $peerport < 65536) {
        print {$conn->{socket}} "501 Invalid port number.\r\n";
    }

    $conn->{peeraddrstring} = $peeraddrstring;
    $conn->{peeraddr} = inet_aton ($peeraddrstring);
    $conn->{peerport} = $peerport;
    $conn->{passive} = 0;

    $conn->{state} = $_connection_states{TWOSOCKS};

    print {$conn->{socket}} "200 PORT command OK.\r\n";
}

sub _PWD_command
{
    my ($conn, $cmd, $rest) = @_;

    # See RFC 959 Appendix II and draft-ietf-ftpext-mlst-11.txt section 6.2.1.
    my $pathname = $conn->{dir};
    $pathname =~ s,/+$,, unless $pathname eq "/";
    $pathname =~ tr,/,/,s;

    print {$conn->{socket}} "257 \"$pathname\"\r\n";
}

sub _REST_command
{
    my ($conn, $cmd, $restart_from) = @_;

    unless ($restart_from =~ /^([1-9][0-9]*|0)$/) {
        print {$conn->{socket}} "501 REST command needs a numeric argument.\r\n";
        return;
    }

    $conn->{restart} = $1;

    print {$conn->{socket}} "350 Restarting next transfer at $1.\r\n";
}

sub _RETR_command
{
    my ($conn, $cmd, $path) = @_;

    $path = FTPPaths::path_merge($conn->{dir}, $path);
    my $info = $conn->{'paths'}->get_info($path);

    unless ($info->{'_type'} eq 'f') {
        print {$conn->{socket}} "550 File not found.\r\n";
        return;
    }

    print {$conn->{socket}} "150 Opening " .
        ($conn->{type} eq 'A' ? "ASCII mode" : "BINARY mode") .
        " data connection.\r\n";

    # Open a path back to the client.
    my $sock = __open_data_connection ($conn);

    unless ($sock) {
        print {$conn->{socket}} "425 Can't open data connection.\r\n";
        return;
    }

    my $content = $info->{'content'};

    # Restart the connection from previous point?
    if ($conn->{restart}) {
        $content = substr($content, $conn->{restart});
        $conn->{restart} = 0;
    }

    # What mode are we sending this file in?
    unless ($conn->{type} eq 'A') # Binary type.
    {
        my ($r, $buffer, $n, $w);


        # Copy data.
        while ($buffer = substr($content, 0, 65536))
        {
            $r = length $buffer;

            # Restart alarm clock timer.
            alarm $conn->{idle_timeout};

            for ($n = 0; $n < $r; )
            {
                $w = syswrite ($sock, $buffer, $r - $n, $n);

                # Cleanup and exit if there was an error.
                unless (defined $w) {
                    close $sock;
                    print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
                    return;
                }

                $n += $w;
            }

            # Transfer aborted by client?
            if ($GOT_SIGURG) {
                $GOT_SIGURG = 0;
                close $sock;
                print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
                return;
            }
        }

        # Cleanup and exit if there was an error.
        unless (defined $r) {
            close $sock;
            print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
            return;
        }
    } else { # ASCII type.
        # Copy data.
        my @lines = split /\r\n?|\n/, $content;
        for (@lines) {
            # Remove any native line endings.
            s/[\n\r]+$//;

            # Restart alarm clock timer.
            alarm $conn->{idle_timeout};

            # Write the line with telnet-format line endings.
            print $sock "$_\r\n";

            # Transfer aborted by client?
            if ($GOT_SIGURG) {
                $GOT_SIGURG = 0;
                close $sock;
                print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
                return;
            }
        }
    }

    unless (close ($sock)) {
        print {$conn->{socket}} "550 File retrieval error: $!.\r\n";
        return;
    }

    print {$conn->{socket}} "226 File retrieval complete. Data connection has been closed.\r\n";
}

sub _SIZE_command
{
    my ($conn, $cmd, $path) = @_;

    $path = FTPPaths::path_merge($conn->{dir}, $path);
    my $info = $conn->{'paths'}->get_info($path);
    unless ($info) {
        print {$conn->{socket}} "550 File or directory not found.\r\n";
        return;
    }

    if ($info->{'_type'} eq 'd') {
        print {$conn->{socket}} "550 SIZE command is not supported on directories.\r\n";
        return;
    }

    my $size = length $info->{'content'};

    print {$conn->{socket}} "213 $size\r\n";
}

sub _SYST_command
{
    my ($conn, $cmd, $dummy) = @_;

    if ($conn->{'paths'}->GetBehavior('syst_response'))
      {
        print {$conn->{socket}} $conn->{'paths'}->GetBehavior('syst_response') . "\r\n";
      }
    else
      {
        print {$conn->{socket}} "215 UNIX Type: L8\r\n";
      }
}

sub _TYPE_command
{
    my ($conn, $cmd, $type) = @_;

    # See RFC 959 section 5.3.2.
    if ($type =~ /^([AI])$/i) {
        $conn->{type} = 'A';
    } elsif ($type =~ /^([AI])\sN$/i) {
        $conn->{type} = 'A';
    } elsif ($type =~ /^L\s8$/i) {
        $conn->{type} = 'L8';
    } else {
        print {$conn->{socket}} "504 This server does not support TYPE $type.\r\n";
        return;
    }

    print {$conn->{socket}} "200 TYPE changed to $type.\r\n";
}

sub _USER_command
{
    my ($conn, $cmd, $username) = @_;

    print STDERR "username: $username\n" if $log;
    $conn->{username} = $username;

    print STDERR "switching to WAIT4PWD state\n" if $log;
    $conn->{state} = $_connection_states{WAIT4PWD};

    if ($conn->{username} eq "anonymous") {
        print {$conn->{socket}} "230 Anonymous user access granted.\r\n";
    } else {
        print {$conn->{socket}} "331 Password required.\r\n";
    }
}


# HELPER ROUTINES

sub __open_data_connection
{
    my $conn = shift;

    my $sock;

    if ($conn->{passive}) {
        # Passive mode - wait for a connection from the client.
        accept ($sock, $conn->{passive_socket}) or return undef;
    } else {
        # Active mode - connect back to the client.
        "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
        $sock = IO::Socket::INET->new (LocalAddr => '127.0.0.1',
                                       PeerAddr => $conn->{peeraddrstring},
                                       PeerPort => $conn->{peerport},
                                       Proto => 'tcp',
                                       Type => SOCK_STREAM) or return undef;
    }

    return $sock;
}


###########################################################################
# FTPSERVER CLASS
###########################################################################

{
    my %_attr_data = ( # DEFAULT
        _input           => undef,
        _localAddr       => 'localhost',
        _localPort       => undef,
        _reuseAddr       => 1,
        _rootDir         => Cwd::getcwd(),
        _server_behavior => {},
    );

    sub _default_for
    {
        my ($self, $attr) = @_;
        $_attr_data{$attr};
    }

    sub _standard_keys
    {
        keys %_attr_data;
    }
}


sub new {
    my ($caller, %args) = @_;
    my $caller_is_obj = ref($caller);
    my $class = $caller_is_obj || $caller;
    my $self = bless {}, $class;
    foreach my $attrname ($self->_standard_keys()) {
        my ($argname) = ($attrname =~ /^_(.*)/);
        if (exists $args{$argname}) {
            $self->{$attrname} = $args{$argname};
        } elsif ($caller_is_obj) {
            $self->{$attrname} = $caller->{$attrname};
        } else {
            $self->{$attrname} = $self->_default_for($attrname);
        }
    }
    # create server socket
    "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
    $self->{_server_sock}
                    = IO::Socket::INET->new (LocalHost => $self->{_localAddr},
                                             LocalPort => $self->{_localPort},
                                             Listen => 1,
                                             Reuse => $self->{_reuseAddr},
                                             Proto => 'tcp',
                                             Type => SOCK_STREAM)
                                        or die "bind: $!";

    foreach my $file (keys %{$self->{_input}}) {
        my $ref = \$self->{_input}{$file}{content};
        $$ref =~ s/{{port}}/$self->sockport/eg;
    }

    return $self;
}


sub run
{
    my ($self, $synch_callback) = @_;
    my $initialized = 0;

    # turn buffering off on STDERR
    select((select(STDERR), $|=1)[0]);

    # initialize command table
    my $command_table = {};
    foreach (keys %_commands) {
        my $subname = "_${_}_command";
        $command_table->{$_} = \&$subname;
    }

    my $old_ils = $/;
    $/ = "\r\n";

    if (!$initialized) {
        $synch_callback->();
        $initialized = 1;
    }

    $SIG{CHLD} = sub { wait };
    my $server_sock = $self->{_server_sock};

    # the accept loop
    while (my $client_addr = accept (my $socket, $server_sock))
    {
        # turn buffering off on $socket
        select((select($socket), $|=1)[0]);

        # find out who connected
        my ($client_port, $client_ip) = sockaddr_in ($client_addr);
        my $client_ipnum = inet_ntoa ($client_ip);

        # print who connected
        print STDERR "got a connection from: $client_ipnum\n" if $log;

        # fork off a process to handle this connection.
        # my $pid = fork();
        # unless (defined $pid) {
        #     warn "fork: $!";
        #     sleep 5; # Back off in case system is overloaded.
        #     next;
        # }

        if (1) { # Child process.

            # install signals
            $SIG{URG}  = sub {
                $GOT_SIGURG  = 1;
            };

            $SIG{PIPE} = sub {
                print STDERR "Client closed connection abruptly.\n";
                exit;
            };

            $SIG{ALRM} = sub {
                print STDERR "Connection idle timeout expired. Closing server.\n";
                exit;
            };

            #$SIG{CHLD} = 'IGNORE';


            print STDERR "in child\n" if $log;

            my $conn = {
                'paths'           => FTPPaths->new($self->{'_input'},
                                        $self->{'_server_behavior'}),
                'socket'          => $socket,
                'state'           => $_connection_states{NEWCONN},
                'dir'             => '/',
                'restart'         => 0,
                'idle_timeout'    => 60, # 1 minute timeout
                'rootdir'         => $self->{_rootDir},
            };

            print {$conn->{socket}} "220 GNU Wget Testing FTP Server ready.\r\n";

            # command handling loop
            for (;;) {
                print STDERR "waiting for request\n" if $log;

                last unless defined (my $req = <$socket>);

                # Remove trailing CRLF.
                $req =~ s/[\n\r]+$//;

                print STDERR "received request $req\n" if $log;

                # Get the command.
                # See also RFC 2640 section 3.1.
                unless ($req =~ m/^([A-Z]{3,4})\s?(.*)/i) {
                    # badly formed command
                    exit 0;
                }

                # The following strange 'eval' is necessary to work around a
                # very odd bug in Perl 5.6.0. The following assignment to
                # $cmd will fail in some cases unless you use $1 in some sort
                # of an expression beforehand.
                # - RWMJ 2002-07-05.
                eval '$1 eq $1';

                my ($cmd, $rest) = (uc $1, $2);

                # Got a command which matches in the table?
                unless (exists $command_table->{$cmd}) {
                    print {$conn->{socket}} "500 Unrecognized command.\r\n";
                    next;
                }

                # Command requires user to be authenticated?
                unless ($_commands{$cmd} | $conn->{state}) {
                    print {$conn->{socket}} "530 Not logged in.\r\n";
                    next;
                }

                # Handle the QUIT command specially.
                if ($cmd eq "QUIT") {
                    print {$conn->{socket}} "221 Goodbye. Service closing connection.\r\n";
                    last;
                }

                if (defined ($self->{_server_behavior}{fail_on_pasv})
                        && $cmd eq 'PASV') {
                    undef $self->{_server_behavior}{fail_on_pasv};
                    close $socket;
                    last;
                }

                # Run the command.
                &{$command_table->{$cmd}} ($conn, $cmd, $rest);
            }
        } else { # Father
            close $socket;
        }
    }

    $/ = $old_ils;
}

sub sockport {
    my $self = shift;
    return $self->{_server_sock}->sockport;
}


package FTPPaths;

use POSIX qw(strftime);

# not a method
sub final_component {
    my $path = shift;

    $path =~ s|.*/||;
    return $path;
}

# not a method
sub path_merge {
    my ($a, $b) = @_;

    return $a unless $b;

    if ($b =~ m.^/.) {
        $a = '';
        $b =~ s.^/..;
    }
    $a =~ s./$..;

    my @components = split('/', $b);

    foreach my $c (@components) {
        if ($c =~ /^\.?$/) {
            next;
        } elsif ($c eq '..') {
            next if $a eq '';
            $a =~ s|/[^/]*$||;
        } else {
            $a .= "/$c";
        }
    }

    return $a;
}

sub new {
    my ($this, @args) = @_;
    my $class = ref($this) || $this;
    my $self = {};
    bless $self, $class;
    $self->initialize(@args);
    return $self;
}

sub initialize {
    my ($self, $urls, $behavior) = @_;
    my $paths = {_type => 'd'};

    # From a path like '/foo/bar/baz.txt', construct $paths such that
    # $paths->{'foo'}->{'bar'}->{'baz.txt'} is
    # $urls->{'/foo/bar/baz.txt'}.
    for my $path (keys %$urls) {
        my @components = split('/', $path);
        shift @components;
        my $x = $paths;
        for my $c (@components) {
            unless (exists $x->{$c}) {
                $x->{$c} = {_type => 'd'};
            }
            $x = $x->{$c};
        }
        %$x = %{$urls->{$path}};
        $x->{_type} = 'f';
    }

    $self->{'_paths'} = $paths;
    $self->{'_behavior'} = $behavior;
}

sub get_info {
    my ($self, $path, $node) = @_;
    $node = $self->{'_paths'} unless $node;
    my @components = split('/', $path);
    shift @components if @components && $components[0] eq '';

    for my $c (@components) {
        if ($node->{'_type'} eq 'd') {
            $node = $node->{$c};
        } else {
            return undef;
        }
    }
    return $node;
}

sub dir_exists {
    my ($self, $path) = @_;
    return $self->exists($path, 'd');
}

sub exists {
    # type is optional, in which case we don't check it.
    my ($self, $path, $type) = @_;
    my $paths = $self->{'_paths'};

    die "Invalid path $path (not absolute).\n" unless $path =~ m.^/.;
    my $info = $self->get_info($path);
    return 0 unless defined($info);
    return $info->{'_type'} eq $type if defined($type);
    return 1;
}

sub _format_for_list {
    my ($self, $name, $info) = @_;

    # XXX: mode should be specifyable as part of the node info.
    my $mode_str;
    if ($info->{'_type'} eq 'd') {
        $mode_str = 'dr-xr-xr-x';
    } else {
        $mode_str = '-r--r--r--';
    }

    my $size = 0;
    if ($info->{'_type'} eq 'f') {
        $size = length  $info->{'content'};
        if ($self->{'_behavior'}{'bad_list'}) {
            $size = 0;
        }
    }
    my $date = strftime ("%b %e %H:%M", localtime);
    return "$mode_str 1  0  0  $size $date $name";
}

sub get_list {
    my ($self, $path, $no_hidden) = @_;
    my $info = $self->get_info($path);
    return undef unless defined $info;
    my $list = [];

    if ($info->{'_type'} eq 'd') {
        for my $item (keys %$info) {
            next if $item =~ /^_/;
            # 2013-10-17 Andrea Urbani (matfanjol)
            #            I skip the hidden files if requested
            if (($no_hidden) &&
                (defined($info->{$item}->{'attr'})) &&
                (index($info->{$item}->{'attr'}, "H")>=0))
              {
                # This is an hidden file and I don't want to see it!
                print STDERR "get_list: Skipped hidden file [$item]\n";
              }
            else
              {
                push @$list, $self->_format_for_list($item, $info->{$item});
              }
        }
    } else {
        push @$list, $self->_format_for_list(final_component($path), $info);
    }

    return $list;
}

# 2013-10-17 Andrea Urbani (matfanjol)
# It returns the behavior of the given name.
# In this file I handle also the following behaviors:
#  list_dont_clean_path  : if defined, the command
#                           $path =~ s/^-[a-zA-Z0-9]+\s?//;
#                          is not runt and the given path
#                          remains the original one
#  list_empty_if_list_a  : if defined, "LIST -a" returns an
#                          empty content
#  list_fails_if_list_a  : if defined, "LIST -a" returns an
#                          error
#  list_no_hidden_if_list: if defined, "LIST" doesn't return
#                          hidden files.
#                          To define an hidden file add
#                            attr => "H"
#                          to the url files
#  syst_response         : if defined, its content is printed
#                          out as SYST response
sub GetBehavior {
  my ($self, $name) = @_;
  return $self->{'_behavior'}{$name};
}

1;

# vim: et ts=4 sw=4