The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package App::Shotgun::Target::FTP;
BEGIN {
  $App::Shotgun::Target::FTP::AUTHORITY = 'cpan:GETTY';
}
BEGIN {
  $App::Shotgun::Target::FTP::VERSION = '0.001';
}
use strict;
use warnings;

# ABSTRACT: App::Shotgun target for FTP servers

#sub POE::Component::Client::SimpleFTP::DEBUG () { 1 };

use MooseX::POE::SweetArgs 0.213;
use POE::Component::Client::SimpleFTP 0.003;

with qw(
	App::Shotgun::Target
	MooseX::LogDispatch
);


has port => (
	isa => 'Int',
	is => 'ro',
	default => 21,
);


has usetls => (
	isa => 'Bool',
	is => 'ro',
	default => 0,
);


has username => (
	isa => 'Str',
	is => 'ro',
	required => 1,
);


has password => (
	isa => 'Str',
	is => 'ro',
	required => 1,
);

# the file we are currently transferring
has _filefh => (
	isa => 'Ref',
	is => 'rw',
	init_arg => undef,
);

# convenience function to simplify passing events to poco-ftp
sub ftp {
	my( $self, @args ) = @_;

	$poe_kernel->post( $self->name, @args );

	return;
}

# the master told us to shutdown
event shutdown => sub {
	my $self = shift;

	# disconnect from the ftpd
	$self->ftp( 'quit' );

	return;
};

sub START {
	my $self = shift;

	POE::Component::Client::SimpleFTP->new(
		alias => $self->name,

		remote_addr => $self->hostname,
		remote_port => $self->port,
		username => $self->username,
		password => $self->password,
		( $self->usetls ? ( tls_cmd => 1, tls_data => 1 ) : () ),
	);

	# now we just wait for the connection to succeed/fail
	return;
}

event _parent => sub { return };
event _child => sub { return };

# actually transfer $file from the local dir to the remote
event transfer => sub {
	my $self = shift;

	$self->logger->debug( "Target [" . $self->name . "] starting transfer of '" . $self->file . "'" );

	# Do we need to mkdir the file's path?
	my $dir = $self->file->dir->absolute( $self->path )->stringify;
	if ( ! $self->known_dir( $dir ) ) {
		# okay, go check it!
		$self->state( 'testdir' );
		$self->ftp( 'cd', $dir );

		return;
	}

	# Okay, we are now ready to transfer the file
	$self->process_put;

	return;
};

sub process_put {
	my $self = shift;

	$self->state( 'xfer' );
	$self->ftp( 'put', $self->file->absolute( $self->path )->stringify );
}

event connected => sub {
	my $self = shift;

	# do nothing hah

	return;
};

event connect_error => sub {
	my( $self, $code, $string ) = @_;

	$self->error( "[" . $self->name . "] CONNECT error: $code $string" );

	return;
};

event login_error => sub {
	my( $self, $code, $string ) = @_;

	$self->error( "[" . $self->name . "] LOGIN error: $code $string" );

	return;
};

event authenticated => sub {
	my $self = shift;

	# okay, change to the path for our transfer?
	if ( $self->path->stringify ne '/' ) {
		$self->ftp( 'cd', $self->path->stringify );
	} else {
		# we are now ready to transfer files
		$self->ready( $self );
	}

	return;
};

event cd => sub {
	my( $self, $code, $reply, $path ) = @_;

	if ( $self->state eq 'init' ) {
		# we are now ready to transfer files
		$self->add_known_dir( $self->path->stringify );
		$self->ready( $self );
	} elsif ( $self->state eq 'testdir' ) {
		# we tried to cd to the full path, and it worked!
		$self->_build_filedirs;
		foreach my $d ( @{ $self->_filedirs } ) {
			$self->add_known_dir( $d );
		}

		# Okay, actually start the transfer!
		$self->process_put;
	} elsif ( $self->state eq 'dir' ) {
		# Okay, this dir is ok, move on to the next one
		$self->add_known_dir( shift @{ $self->_filedirs } );
		if ( defined $self->_filedirs->[0] ) {
			$self->ftp( 'cd', $self->_filedirs->[0] );
		} else {
			# finally validated the entire dir path
			$self->process_put;
		}
	} else {
		die "(CD) unknown state: " . $self->state;
	}

	return;
};

event cd_error => sub {
	my( $self, $code, $reply, $path ) = @_;

	if ( $self->state eq 'init' ) {
		$self->error( "[" . $self->name . "] Error changing to initial path '$path': $code $reply" );
	} elsif ( $self->state eq 'testdir' ) {
		# we have to cd/mkdir EACH directory path to be compatible with many ftpds
		# we store the full path here, so we can always be sure it's a valid path ( CWD issues )
		# on a vsftpd 2.2.0 ftpd:
		#ftp> mkdir /lib
		#257 "/lib" created
		#ftp> mkdir /lib/App
		#257 "/lib/App" created
		#ftp> mkdir /lib/App/Shotgun/Foo
		#550 Create directory operation failed.
		#ftp>
		$self->_build_filedirs;

		# if there is only 1 path, we've "tested" it and no need to re-cd into it!
		if ( scalar @{ $self->_filedirs } == 1 ) {
			# we need to mkdir this one!
			$self->state( 'dir' );
			$self->ftp( 'mkdir', $self->_filedirs->[0] );
		} else {
			# we now cd to the first element
			$self->state( 'dir' );
			$self->ftp( 'cd', $self->_filedirs->[0] );
		}
	} elsif ( $self->state eq 'dir' ) {
		# we need to mkdir this one!
		$self->ftp( 'mkdir', $self->_filedirs->[0] );
	} else {
		die "(CD_ERROR) unknown state: " . $self->state;
	}

	return;
};

event mkdir => sub {
	my( $self, $code, $reply, $path ) = @_;

	if ( $self->state eq 'dir' ) {
		# mkdir the next directory in the filedirs?
		$self->add_known_dir( shift @{ $self->_filedirs } );
		if ( defined $self->_filedirs->[0] ) {
			$self->ftp( 'mkdir', $self->_filedirs->[0] );
		} else {
			# Okay, finally done creating the entire path to the file!
			$self->process_put;
		}
	} else {
		die "(MKDIR) unknown state: " . $self->state;
	}

	return;
};

event mkdir_error => sub {
	my( $self, $code, $reply, $path ) = @_;

	$self->error( "[" . $self->name . "] MKDIR($path) error: $code $reply" );

	return;
};

event put_error => sub {
	my( $self, $code, $reply, $path ) = @_;

	$self->error( "[" . $self->name . "] XFER($path) error: $code $reply" );

	return;
};

event put_connected => sub {
	my( $self, $path ) = @_;

	# okay, we can send the first block of data!
	my $localpath = $self->file->absolute( $self->shotgun->source )->stringify;
	if ( open( my $fh, '<', $localpath ) ) {
		$self->_filefh( $fh );

		# send the first chunk
		$self->send_chunk;
	} else {
		$self->error( "[" . $self->name . "] XFER($path) error: unable to open $localpath: $!" );
	}

	return;
};

event put_flushed => sub {
	my( $self, $path ) = @_;

	# read the next chunk of data from the fh
	$self->send_chunk;

	return;
};

sub send_chunk {
	my $self = shift;

	my $buf;
	my $retval = read( $self->_filefh, $buf, 10_240 ); # TODO is 10240 ok? I lifted it from poco-ftp code
	if ( $retval ) {
		$self->ftp( 'put_data', $buf );
	} elsif ( $retval == 0 ) {
		# all done with the file
		if ( close( $self->_filefh ) ) {
			$self->ftp( 'put_close' );
		} else {
			$self->error( "[" . $self->name . "] XFER error: unable to close " . $self->file->absolute( $self->shotgun->source )->stringify . ": $!" );
		}
	} else {
		# error reading file
		$self->error( "[" . $self->name . "] XFER error: unable to read from " . $self->file->absolute( $self->shotgun->source )->stringify . ": $!" );
	}

	return;
}

event put => sub {
	my( $self, $code, $reply, $path ) = @_;

	# we're finally done with this transfer!
	$self->xferdone( $self );

	return;
};

no MooseX::POE::SweetArgs;
__PACKAGE__->meta->make_immutable;
1;


__END__
=pod

=head1 NAME

App::Shotgun::Target::FTP - App::Shotgun target for FTP servers

=head1 VERSION

version 0.001

=head1 DESCRIPTION

Implements the FTP target.

=head1 ATTRIBUTES

=head2 port

The port to connect on the server.

The default is: 21

=head2 usetls

Enable/disable TLS encryption for the connection.

The default is: false

=head2 username

The username to login to the server with.

Required.

=head2 password

The password to login to the server with.

Required.

=for Pod::Coverage ftp process_put send_chunk START

=head1 AUTHORS

=over 4

=item *

Torsten Raudssus <torsten@raudssus.de>

=item *

Apocalypse <APOCAL@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011 by Raudssus Social Software L<http://www.raudssus.de/>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut