File Coverage

blib/lib/Net/SFTP/Server.pm

Criterion	Covered	Total	%
statement	40	320	12.5
branch	1	152	0.6
condition	1	269	0.3
subroutine	12	44	27.2
pod	0	25	0.0
total	54	810	6.6

package Net::SFTP::Server;

$VERSION = '0.03';

use strict;
use warnings;
use Carp;

use Fcntl qw(O_NONBLOCK F_SETFL F_GETFL);
use Errno ();
use Scalar::Util qw(dualvar);

use Net::SFTP::Server::Constants qw(:all);
use Net::SFTP::Server::Buffer;
our @CARP_NOT = qw(Net::SFTP::Server::Buffer);

our $debug;

sub _debug {
    local $\;
    print STDERR ((($debug & 256) ? "Server#$$#" : "#"), @_,"\n");
}

sub _debugf {
    my $fmt = shift;
    _debug sprintf($fmt, @_);
}

sub _hexdump {
    no warnings qw(uninitialized);
    my $data = shift;
    while ($data =~ /(.{1,32})/smg) {
        my $line=$1;
        my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)),
                (("  ") x 32))[0..31];
        $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;
	local $\;
        print STDERR join(" ", @c, '|', $line), "\n";
    }
}

sub set_error {
    my $self = shift;
    my $error = shift;
    if ($error) {
	my $str = (@_ ? join('', @_) : "Unknown error $error");
	$debug and $debug & 64 and _debug("error: $error, $str");
	$self->{error} = dualvar($error, $str);
    }
    else {
	$self->{error} = 0
    }
}

sub error { shift->{error} }

sub set_exit {
    my $self = shift;
    my $exit = shift;
    $self->{exit} = $exit;
}

sub set_error_and_exit {
    my $self = shift;
    my $code = shift;
    $self->set_exit(!!$code);
    $self->set_error($code, @_);
}

sub _prepare_fh {
    my ($name, $fh) = @_;
    $fh ||= do {
	no strict 'refs';
	\*{uc "STD$name"};
    };
    fileno $fh < 0 and croak "${name}_fh is not a valid file handle";
    my $flags = fcntl($fh, F_GETFL, 0);
    fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
    $fh;
}

sub new {
    @_ & 1 or croak 'Usage: $class->new(%opts)';
    my ($class, %opts) = @_;

    my $in_fh = _prepare_fh(in => delete $opts{in_fh});
    my $out_fh = _prepare_fh(out => delete $opts{out_fh});

    my $timeout = delete $opts{timeout};

    my $self = { protocol_version => 0,
		 in_fh => $in_fh,
		 out_fh => $out_fh,
		 in_buffer => '',
		 out_buffer => '',
		 in_buffer_max_size => 65 * 1024,
		 max_packet_size => 64 * 1024,
		 packet_handler_cache => [],
		 command_handler_cache => [],
		 timeout => $timeout,
	       };

    bless $self, $class;

    $self->set_error_and_exit;

    return $self;
}

sub set_protocol_version {
    my ($self, $version) = @_;
    $self->{packet_handler_cache} = [];
    $self->{command_handler_cache} = [];
    $self->{protocol_version} = $version;
}

sub _do_io_unix {
    my ($self, $wait_for_packet) = @_;

    my $out_b = \$self->{out_buffer};
    my $out_fh = $self->{out_fh};
    my $out_fn = fileno $out_fh;
    my $in_b = \$self->{in_buffer};
    my $in_fh = $self->{in_fh};
    my $in_fn = fileno $in_fh;
    my $in_buffer_max_size = $self->{in_buffer_max_size};
    my $timeout = $self->{timeout};
    my $packet_len;
    my $in_fh_closed;

    local $SIG{PIPE} = 'IGNORE';

    $debug and $debug & 32 and
	_debugf("_do_io_unix enter buffer_in: %d, buffer_out: %d",
		length $$in_b, length $$out_b);

    while (1) {
	if (!defined $packet_len and length $$in_b >= 4) {
	    $packet_len = unpack(N => $$in_b) + 4;
	    $debug and $debug & 32 and _debug "_do_io_unix packet_len: $packet_len";

	    if ($packet_len > $in_buffer_max_size) {
		$self->set_error_and_exit(1, "Packet of length $packet_len is too big");
		return undef;
	    }
	}

	if (defined $packet_len and $wait_for_packet) {
	    $wait_for_packet = ($packet_len > length $$in_b and
				!$in_fh_closed);
	    $debug and $debug & 32 and _debug "wait_for_packet set to $wait_for_packet";
	}

	$debug and $debug & 32 and
	    _debugf("_do_io_unix wait_for_packet: %d, packet_len: %s, in buffer: %d, out buffer: %d",
		    $wait_for_packet,
		    ($packet_len // 'undef'),
		    length($$in_b), length($$out_b));

	last unless ($wait_for_packet or length $$out_b);

	my $rb = '';
	length $$in_b < $in_buffer_max_size
	    and !$in_fh_closed
		and vec($rb, $in_fn, 1) = 1;

	my $wb = '';
	vec($wb, $out_fn, 1) = 1 if length $$out_b;

	$rb eq '' and $wb eq '' and croak "Internal error: useless select";

	my $n = select($rb, $wb, undef, $timeout);
	$debug and $debug & 32 and _debug "_do_io_unix select n: $n";
	if ($n >= 0) {
	    if (vec($wb, $out_fn, 1)) {
		my $bytes = syswrite($out_fh, $$out_b);
		if ($debug and $debug & 32) {
		    _debugf("_do_io_unix write queue: %s, syswrite: %s",
			    length $$out_b,
			    ($bytes // 'undef'));
		    $debug & 2048 and $bytes and _hexdump(substr($$out_b, 0, $bytes));
		}
		if ($bytes) {
		    substr($$out_b, 0, $bytes, '');
		}
		else {
		    $self->set_error_and_exit(1, "Broken connection");
		    return undef;
		}
	    }
	    if (vec($rb, $in_fn, 1)) {
		my $bytes = sysread($in_fh, $$in_b, 16*1024, length $$in_b);
		if ($debug and $debug & 32) {
		    _debugf("_do_io_unix sysread: %s, total read: %d",
			    ($bytes // 'undef'),
			    length $$in_b);
		    $debug & 1024 and $bytes and _hexdump(substr($$in_b, -$bytes));
		}
		unless ($bytes) {
		    $self->set_error_and_exit(1, "Connection closed by remote peer");
		    $in_fh_closed = 1;
		    undef $wait_for_packet;
		}
	    }
	}
	else {
	    next if ($n < 0 and $! == Errno::EINTR());
	    $debug and $debug & 32
		and _debugf("_do_io_unix failed, wait_for_packet: %d, packet_len: %s, in buffer: %d, out buffer: %d, n: %d, \$!: %s (%d)",
			    $wait_for_packet, ($packet_len // 'undef'), length($$in_b), length($$out_b), $n, $!, int $!);
	    return undef;
	}
    }
    $debug and $debug & 32
	and _debugf("_do_io_unix done, wait_for_packet: %d, packet_len: %s, in buffer: %d, out buffer: %d",
		    $wait_for_packet, ($packet_len // 'undef'), length($$in_b), length($$out_b));

    return !$in_fh_closed;
}

*_do_io = \&_do_io_unix;

sub get_packet {
    my $self = shift;
    my $in_b = \$self->{in_buffer};
    my $in_b_len = length $$in_b;
    $debug and $debug & 1 and
	_debugf("shift packet, in buffer len: %d, peeked packet len: %s",
		       $in_b_len,
		       ($in_b_len >= 4 ? unpack N => $$in_b : '-'));

    $in_b_len >= 4 or return undef;
    my $pkt_len = (unpack N => $$in_b);
    $in_b_len >= 4 + $pkt_len or return undef;
    $debug and $debug & 1 and _debug("got it!");
    substr($$in_b, 0, 4, '');
    substr($$in_b, 0, $pkt_len, '');
}

my %packer = ( uint8 => \&buf_push_uint8,
	       uint32 => \&buf_push_uint32,
	       uint64 => sub { croak "uint64 packing unimplemented" },
	       str => \&buf_push_str,
	       utf8 => \&buf_push_utf8,
	       name => \&buf_push_name,
	       attrs => \&buf_push_attrs,
	       raw => \&buf_push_raw);

sub push_packet {
    my $self = shift;
    my $out_b = \$self->{out_buffer};
    if (length $$out_b) {
	$self->set_error_and_exit(1,
	    "Internal error, packet already in output buffer");
	return undef;
    }

    if (@_ == 1) {
	buf_push_str($$out_b, $_[0]);
    }
    else {
	@_ & 1 and croak 'Usage: $sftp_server->push_packet(type => data, type => data, ...) or $sftp_server->push_packet($load)';
	$$out_b = "\x00\x00\x00\x00";
	while (@_) {
	    my $type = shift;
	    my $packer = $packer{$type};
	    if (defined $packer) {
		$packer->($$out_b, $_[0]);
		shift;
	    }
	    else {
		$self->set_error_and_exit(1,
                    "Internal error, invalid packing type $type");
		return;
	    }
	}
	substr $$out_b, 0, 4, pack(N => (length($$out_b) - 4));
    }
    if ($debug and $debug & 1) {
	_debugf "push_packet packet len %d", length $$out_b;
	$debug & 8 and _hexdump $$out_b;
    }

    1;
}

my %command_id = (init => 1,
		  open => 3,
		  close => 4,
		  read => 5,
		  write => 6,
		  lstat => 7,
		  fstat => 8,
		  setstat => 9,
		  fsetstat => 10,
		  opendir => 11,
		  readdir => 12,
		  remove => 13,
		  mkdir => 14,
		  rmdir => 15,
		  realpath => 16,
		  stat => 17,
		  rename => 18,
		  readlink => 19,
		  symlink => 20,
		  link => 21,
		  block => 22,
		  unblock => 23,
		  extended => 200);

my %response_id = (version => 2,
		   status => 101,
		   handle => 102,
		   data => 103,
		   name => 104,
		   attrs => 105,
		   extended => 201);

my @command_name;
while (my ($k, $v) = each %command_id) {
    $command_name[$v] = $k;
}

sub command_name { $command_name[$_[1]] }

sub response_id { $response_id{$_[1]} }

sub dispatch_packet {
    my $self = shift;
    my ($cmd) = buf_shift_uint8($_[0])
	or return $self->bad_packet();
    my ($id) = ($cmd == 1 ? undef : buf_shift_uint32 $_[0])
	or return $self->bad_packet($cmd);

    $debug and $debug & 1
	and _debugf("dispatch packet cmd %s, id: %s", $cmd, ($id // '-'));

    my $sub = $self->{_packet_handler_cache}[$cmd] ||= do {
	my $name = $self->command_name($cmd) || 'unknown';
	$self->can("handle_packet_${name}_v$self->{protocol_version}") ||
	    $self->can("handle_packet_${name}") ||
		$self->can('unsupported_command');
    };
    $debug and $debug & 4096 and _debug "packet handler: $sub";
    $sub->($self, $cmd, $id, $_[0]);
}

my @status_messages = ( "ok",
			"eof",
			"no such file",
			"permission denied",
			"failure",
			"bad message",
			"no connection",
			"connection lost",
			"operation not supported" );

sub push_status_response {
    my ($self, $id, $status, $msg, $lang) = @_;
    $msg //= ($status_messages[$status] // "failure");
    $lang //= 'en';
    $debug and $debug & 2 and _debug "push id: $id, status: $status, msg: $msg, lang: $lang";
    $self->push_packet(uint8 => SSH_FXP_STATUS,
		       uint32 => $id, uint32 => $status,
		       utf8 => $msg, str => $lang);
}

sub push_status_ok_response {
    my ($self, $id) = @_;
    $self->push_status_response($id, SSH_FX_OK)
}

sub push_status_eof_response {
    my ($self, $id) = @_;
    $self->push_status_response($id, SSH_FX_EOF)
}

sub push_handle_response {
    my ($self, $id, $hid) = @_;
    $debug and $debug & 2 and _debug "push handle hid: $hid";
    $self->push_packet(uint8 => SSH_FXP_HANDLE, uint32 => $id, str => $hid);
}

sub push_name_response {
    my $self = shift;
    my $id = shift;
    my $count = @_;
    $self->push_packet(uint8 => SSH_FXP_NAME,
		       uint32 => $id, uint32 => $count,
		       map { (name => $_) } @_);
}

sub push_attrs_response {
    my ($self, $id, $attrs) = @_;
    $self->push_packet(uint8 => SSH_FXP_ATTRS,
		       uint32 => $id, attrs => $attrs);
}

sub unsupported_command {
    my ($self, $cmd, $id) = @_;
    my $name = (uc $self->command_name($cmd) || $cmd);
    $debug and $debug & 2
	and _debugf("unsupported command %s [%d], id: %s",
		    $name, $cmd, ($id // '-'));
    $self->push_status_response($id, SSH_FX_OP_UNSUPPORTED,
			      "command $name is not supported");
}

sub run {
    my $self = shift;
    until ($self->{exit}) {
	$self->_do_io(1) or next;
	my $pkt = $self->get_packet;
	$self->dispatch_packet($pkt) if defined $pkt;
    }
    $self->{exit};
}

sub bad_packet {
    my ($self, $cmd, $id) = @_;
    $cmd //= 'undef';
    $id //= 'id';
    $self->set_error_and_exit(1, "Invalid packet cmd: $cmd, id: $id");
}

sub bad_command {
    my ($self, $cmd, $id, $msg) = @_;
    my $str = "Bad message";
    $str .= ": $msg" if defined $msg;
    $self->push_status_response($id, SSH_FX_BAD_MESSAGE, $str);
}

sub dispatch_command {
    my $self = shift;
    my $cmd = shift;

    $debug and $debug & 2
	and _debugf("dispatch command cmd %d %s, id: %s",
		    $cmd,
		    ($self->command_name($cmd) // '-'),
		    ($_[0] // '-'));

    my $sub = $self->{_command_handler_cache}[$cmd] ||= do {
	my $name = $self->command_name($cmd) || 'unknown';
	$self->can("handle_command_${name}_v$self->{protocol_version}") ||
	    $self->can("handle_command_${name}") ||
		sub { shift->unsupported_command($cmd, $_[0]) };
    };
    $sub->($self, @_);
}

sub handle_packet_init_v0 {
    my ($self, $cmd) = @_;
    my $version = buf_shift_uint32($_[3]) // goto BAD_PACKET;
    my @ext;
    while (length $_[3]) {
	push (@ext,
	      (buf_shift_str($_[3]) // goto BAD_PACKET),
	      (buf_shift_str($_[3]) // goto BAD_PACKET));
    }
    return $self->dispatch_command($cmd, undef, $version, @ext);

 BAD_PACKET:
    return $self->bad_packet($cmd);
}

sub handle_command_init_v0 {
    my $self = shift;
    shift; # $id
    my $version = shift;
    $version >= 3 or return $self->bad_packet(1);
    $self->set_protocol_version(3);
    $self->push_packet(uint8 => SSH_FXP_VERSION, uint32 => 3,
		       map { (str => $_) } $self->server_extensions);
}

sub server_extensions {
    return ('[e-mail]' => 1);
}

sub _make_packet_handler {
    my $name = shift;
    my @args = map "\n        (buf_shift_$_(\$_[3]) // goto BAD_PACKET)", @_;
    my $args = join(",", @args);
    my $code = <
sub {
    my (\$self, \$cmd, \$id) = \@_;
    \$debug and \$debug & 2 and _debug "$name unpacker called";
    return \$self->dispatch_command(\$cmd, \$id,$args);
  BAD_PACKET:
    \$self->bad_command(\$cmd, \$id, 'missing parameter')
}
EOC
    $debug and $debug & 16384 and _debug "$name packet handler code:\n$code";
    my $method = "handle_packet_$name";
    no strict 'refs';
    *$method = eval $code;
}

_make_packet_handler open_v3 => qw(utf8 uint32 attrs);
_make_packet_handler close_v3 => qw(str);
_make_packet_handler read_v3 => qw(str uint64 uint32);
_make_packet_handler write_v3 => qw(str uint64 str);
_make_packet_handler stat_v3 => qw(utf8);
_make_packet_handler lstat_v3 => qw(utf8);
_make_packet_handler fstat_v3 => qw(str);
_make_packet_handler setstat_v3 => qw(utf8 attrs);
_make_packet_handler fsetstat_v3 => qw(str attrs);
_make_packet_handler opendir_v3 => qw(utf8);
_make_packet_handler readdir_v3 => qw(str);
_make_packet_handler remove_v3 => qw(utf8);
_make_packet_handler mkdir_v3 => qw(utf8 attrs);
_make_packet_handler rmdir_v3 => qw(utf8);
_make_packet_handler realpath_v3 => qw(utf8);
_make_packet_handler rename_v3 => qw(utf8 utf8);
_make_packet_handler readlink_v3 => qw(utf8);
_make_packet_handler symlink_v3 => qw(utf8 utf8 utf8);

1;
__END__