The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Connector::Builtin::File::SCP;

use strict;
use warnings;
use English;
use File::Spec;
use File::Temp qw(tempfile tempdir);
use Proc::SafeExec;
use Data::Dumper;
use Template;

use Moose;
extends 'Connector::Builtin';

has noargs => (
    is  => 'rw',
    isa => 'Bool',
    default => 0,
);

has file => (
    is  => 'rw',
    isa => 'Str',
);

has path => (
    is  => 'rw',
    isa => 'Str',
);

has content => (
    is  => 'rw',
    isa => 'Str',
);

has command => (
    is  => 'rw',
    isa => 'Str',
    default => '/usr/bin/scp'
);

has identity => (
    is  => 'rw',
    isa => 'Str',
    default => ''
);

has sshconfig => (
    is  => 'rw',
    isa => 'Str',
    default => ''
);

has port => (
    is  => 'rw',
    isa => 'Str',
    default => ''
);

has timeout => (
    is  => 'rw',
    isa => 'Int',
    default => 30
);

has _scp_option => (
    is  => 'rw',
    isa => 'ArrayRef',
    lazy => 1,
    builder => '_init_scp_option',
);

has filemode => (
    is  => 'rw',
    isa => 'Str',
    default => ''
);

sub _build_config {

    my $self = shift;
    if (! -d $self->{LOCATION}) {
       confess("Cannot open directory " . $self->{LOCATION} );
    }

    return 1;
}

sub _init_scp_option {

    my $self = shift;

    my @options;
    push @options, '-P'. $self->port() if ($self->port());
    push @options, '-F'. $self->sshconfig() if ($self->sshconfig());
    push @options, '-i'. $self->identity() if ($self->identity());

    return \@options;

}

# return the content of the file
sub get {

    my $self = shift;
    my $path = shift;

    my $source = $self->_sanitize_path( $path );

    # We need to double encode the backslash escape (for local and remote) 
    $source =~ s/\\/\\/g;

    my $tmpdir = tempdir( CLEANUP => 1 );    
    my ($fh, $target) = tempfile( DIR => $tmpdir );

    my $res = $self->_transfer($source, $target );

    # soemthing went wrong
    if ($res) {
        unlink $target if (-e $target);
        return $self->_node_not_exists();
    }

    # read the content from temporary file
    my $content = do {
      local $INPUT_RECORD_SEPARATOR;
      open my $fh, '<', $target;
      <$fh>;
    };

    unlink $target;

    return $content;
}

sub get_meta {
    my $self = shift;

    # If we have no path, we tell the caller that we are a connector
    # but if noargs is set, we behave like a scalar...
    my @path = $self->_build_path_with_prefix( shift );
    if (scalar @path == 0 && !$self->noargs()) {
        return { TYPE  => "connector" };
    }

    return {TYPE  => "scalar" };
}


sub exists {

    my $self = shift;

    # No path = connector root which always exists
    my @path = $self->_build_path_with_prefix( shift );
    if (scalar @path == 0) {
        return 1;
    }

    return 1;

}


# return the content of the file
sub set {

    my $self = shift;
    my $file = shift;
    my $data = shift;

    my $content;
    if ($self->content()) {
        $self->log()->debug('Process template for content ' . $self->content());
        my $template = Template->new({});

        $data = { DATA => $data } if (ref $data eq '');

        $template->process( \$self->content(), $data, \$content) || die "Error processing content template.";
    } else {
        if (ref $data ne '') {
            die "You need to define a content template if data is not a scalar";
        }
        $content = $data;
    }


    my $tmpdir = tempdir( CLEANUP => 1 );
    my ($fh, $source) = tempfile( DIR => $tmpdir );
    
    open FILE, ">$source" || die "Unable to open file for writing";
    print FILE $content;
    close FILE;
    
    if ($self->filemode()) {
        my $mode = $self->filemode();
        $mode = oct($mode) if $mode =~ /^0/;
        chmod $mode, $source;
    }

    my $target = $self->_sanitize_path( $file, $data );

    my $res = $self->_transfer( $source, $target );

    unlink $target if (-e $target);

    if ($res) {
        die "Unable to transfer data";
    }

    return 1;
}

sub _transfer {

    my $self = shift;
    my $source  = shift;
    my $target = shift;

    my %filehandles;
    my $stdout = File::Temp->new();
    $filehandles{stdout} = \*$stdout;

    my $stderr = File::Temp->new();
    $filehandles{stderr} = \*$stderr;

    # compose the system command to execute
    my @cmd = @{$self->_scp_option()};

    unshift @cmd, $self->command();

    push @cmd, $source;
    push @cmd, $target;

    $self->log()->debug("scp command: " . join(" ",@cmd));

    my $command = Proc::SafeExec->new({
        exec => \@cmd,
        no_autowait => 1,
        %filehandles,
    });

    eval{
        local $SIG{ALRM} = sub { die "alarm\n" };
        alarm $self->timeout();
        $command->wait();
    };

    alarm 0;

    if ($EVAL_ERROR) {
        $self->log()->debug($EVAL_ERROR);
        $self->log()->error("SCP tranfer timed out");
        return 2;
    }

    if ($command->exit_status() != 0) {
        $self->log()->error("SCP tranfer failed, exit status was " . $command->exit_status());
        return 1;
    }

    return 0;

}


sub _sanitize_path {

    my $self = shift;
    my $inargs = shift;
    my $data = shift;

    my $host = $self->{LOCATION};

    if ($self->noargs()) {
        $self->log()->debug('Skip filename rendering, noargs options is set');
        return $host;
    }

    my @args = $self->_build_path_with_prefix( $inargs );


    my $file;
    my $template = Template->new({});

    if ($self->path()) {
        my $pattern = $self->path();
        $self->log()->debug('Process template ' . $pattern);
        $template->process( \$pattern, { ARGS => \@args, DATA => $data }, \$file) || die "Error processing file template.";
    } elsif ($self->file()) {
        my $pattern = $self->file();
        my $template = Template->new({});
        $self->log()->debug('Process template ' . $pattern);
        $template->process( \$pattern, { ARGS => \@args, DATA => $data }, \$file) || die "Error processing file template.";
        if ($file =~ m{[\/\\]}) {
            $self->log()->error('Target file name contains directory seperator! Consider using path instead.');
            die "Target file name contains directory seperator! Consider using path instead.";
        }
    } else {
        $self->log()->error('Neither target pattern nor noargs set');
        die "You must set either file or path or use the noargs option.";
    }

    $file =~ s/[^\s\w\.\-\\]//g;

    my $filename;
    # check if the LOCATION already has a path spec
    if ($host !~ /:/) {
        # if the file name has a leading slash, just concat with :
        if ($file =~ /^\//) {
            $filename = $host.':'.$file;
        # otherwise add ~/ for users home
        } else {
            $filename = $host.':~/'.$file;
        }

    } else {
        # if a path spec is given, check if it has a trailing slash
        if ($host !~ /\/$/) {
            $host .= '/';
        }
        $filename = $host.$file;
    }

    $self->log()->debug('Filename evaluated to ' . $filename);

    $filename =~ s/ /\\ /g;

    return $filename;
}

1;
__END__

=head1 Name

Connector::Builtin::File::SCP

=head1 Description

Read/Write files to/from a remote host using SCP.

=head1 Parameters

=over

=item LOCATION

The target host specification, minimal the hostname, optional including
username and a base path specification. Valid examples are:

   my.remote.host
   otheruser@my.remote.host
   my.remote.host:/tmp
   otheruser@my.remote.host:/tmp

Note: If the connector is called with arguments, those are used to build a
filename / path which is appended to the target specification. If you call
the connector without arguments, you need to set the noargs parameter and
must LOCATION point to a file (otherwise you will end up with the temporary
file name used as target name).

=item noargs

Set to true, if you want to use the value given by LOCATION as final
target. This makes additional path arguments and the file/path parameter
useless.

=item file

Pattern for Template Toolkit to build the filename. The connector path
components are available in the key ARGS. In set mode the unfiltered
data is also available in key DATA. The result is appended to LOCATION.
NB: For security reasons, only word, space, dash, underscore and dot are
allowed in the filename. If you want to include a directory, add the path
parameter instead!

=item path

Same as file, but allows the directory seperator (slash and backslash)
in the resulting filename. Use this for the full path including the
filename as the file parameter is not used, when path is set!

=filemode (set mode only)

By default, the file is created with restrictive permissions of 0600. You 
can set other permissions using filemode. Due to perls lack for variable
types, you must give this either as octal number with leading zero or as 
string without the leading zero. Otherwise you might get wrong permissions.


=item content

Pattern for Template Toolkit to build the content. The data is passed
"as is". If data is a scalar, it is wrapped into a hash using DATA as key.

=item command, optional

Path to the scp command, default is /usr/bin/scp.

=item port, optional

Port to connect to, added with "-P" to the command line.

=item identity, optional

Path to an ssh identity file, added with "-i" to the command line.

=item sshconfig, optional

Path to an ssh client configuration, added with "-F" to the command line.

=item timeout, optional

Abort the transfer after timeout seconds.

=back

=head1 Supported Methods

=head2 set

Write data to a file.

    $conn->set('filename', { NAME => 'John Doe', 'ROLE' => 'Administrator' });

See the file parameter how to control the filename. 

=head2 get

Fetch data from a file. See the file parameter how to control the filename.

    my $data = $conn->set('filename');

=head1 Example

    my $conn = Connector::Builtin::File::SCP->new({
       LOCATION => 'localhost:/var/data',
       file => '[% ARGS.0 %].txt',
       content => ' Hello [% NAME %]',
       filemode => 0644
    });

    $conn->set('test', { NAME => 'John Doe' });

Results in a file I</var/data/test.txt> with the content I<Hello John Doe>.

=head1 A note on security

To enable the scp transfer, the file is created on the local disk using 
tempdir/tempfile. The directory is created with permissions only for the 
current user, so no other user than root and yourself is able to see the 
content. The tempfile is cleaned up immediatly, the directory is handled
by the internal garbage collection.