File Coverage

blib/lib/Amazon/S3Curl/PurePerl.pm

Criterion	Covered	Total	%
statement	59	97	60.8
branch	2	16	12.5
condition	2	6	33.3
subroutine	15	26	57.6
pod	5	8	62.5
total	83	153	54.2

package Amazon::S3Curl::PurePerl;

#ABSTRACT: Amazon::S3Curl::PurePerl - Pure Perl s3 helper/downloader.
use strict;
use warnings;

use Module::Runtime qw[ require_module ];

our $VERSION = "0.052";
$VERSION = eval $VERSION;

#For instances when you want to use s3, but don't want to install anything. ( and you have curl )
#Amazon S3 Authentication Tool for Curl
#Copyright 2006-2010 Amazon.com, Inc. or its affiliates. All Rights Reserved.
use Moo;
use POSIX;
use File::Spec;
use Log::Contextual qw[ :log :dlog set_logger ];
use Log::Contextual::SimpleLogger;
use Digest::SHA::PurePerl;
use MIME::Base64 qw(encode_base64);
use IPC::System::Simple qw[ capture ];
my $DIGEST_HMAC;
BEGIN {
    eval {
        require_module("Digest::HMAC");
        $DIGEST_HMAC = "Digest::HMAC";
    };
    if ($@) {    #They dont have Digest::HMAC, use our packaged alternative
        $DIGEST_HMAC = "Amazon::S3Curl::PurePerl::Digest::HMAC";
        require_module($DIGEST_HMAC);
    }
};


set_logger(
    Log::Contextual::SimpleLogger->new(
        {
            levels_upto => 'debug'
        } ) );


has curl => (
    is      => 'ro',
    default => sub { 'curl' }    #maybe your curl isnt in PATH?
);

for (
    qw[
    aws_access_key
    aws_secret_key
    ] )
{
    has $_ => (
        is       => 'ro',
        required => 1,
    );

}

has url => (
    is => 'ro',
    required => 1,
    isa => sub {
        $_[0] =~ m|^/| or die "$_[0] is not a relative url. Should be /bucketname/file"
      },
);

has local_file => (
    is => 'ro',
    required => 0,
    predicate => 1,
);

has static_http_date => (
    is => 'ro',
    required => 0,
);

has s3_scheme_host_url => (
    is => 'ro',
    lazy => 1,
    default => sub {
        my $env_var = $ENV{AMAZON_S3CURL_PUREPERL_SCHEME_HOST};
        return $env_var if defined $env_var;
        return 'https://s3.amazonaws.com'
    }
);

sub http_date {
    POSIX::strftime( "%a, %d %b %Y %H:%M:%S +0000", gmtime );
}

sub _req {
    my ( $self, $method, $url ) = @_;
    die "method required" unless $method;
    $url ||= $self->url;
    my $to_sign  = $url;
    my $resource = sprintf( "%s%s" , $self->s3_scheme_host_url, $url );
    my $keyId       = $self->aws_access_key;
    my $httpDate    = $self->static_http_date || $self->http_date;
    my $contentMD5  = "";
    my $contentType = "";
    my $xamzHeadersToSign = "";
    my $stringToSign      = join( "\n" =>
          ( $method, $contentMD5, $contentType, $httpDate, "$xamzHeadersToSign$to_sign" ) );
    my $hmac =
      $DIGEST_HMAC->new( $self->aws_secret_key, "Digest::SHA::PurePerl",
        64 );
    $hmac->add($stringToSign);
    my $signature = encode_base64( $hmac->digest, "" );
    return [
        $self->curl,
        -H => "Date: $httpDate",
        -H => "Authorization: AWS $keyId:$signature",
        -H => "content-type: $contentType",
        "-L",
        "-f",
        '--no-sslv2',
        '--no-sslv3',
        $resource,
    ];
}




sub download_cmd {
    my ($self) = @_;
    my $args = $self->_req('GET');
    push @$args, ( "-o", $self->local_file );
    return $args;
}

sub upload_cmd {
    my ($self) = @_;
    my $url = $self->url;
    #trailing slash for upload means curl will plop on the filename at the end, ruining the hash signature.
    if ( $url =~ m|/$| ) {
        my $file_name = ( File::Spec->splitpath( $self->local_file ) )[-1];
        $url .= $file_name;
    }
    my $args = $self->_req('PUT',$url);
    splice( @$args, $#$args, 0, "-T", $self->local_file );
    return $args;
}

sub delete_cmd {
    my $args = shift->_req('DELETE');
    splice( @$args, $#$args, 0, qw[ -X DELETE ] );
    return $args;
}

sub head_cmd {
    my $args = shift->_req('HEAD');
    splice( @$args, $#$args, 0, qw[ -I -X HEAD ] );
    return $args;
}

sub url_exists {
    my $self = shift;
    my @args = grep { !/-f/ } @{ $self->head_cmd }; #take out fail mode, want to parse and look for the 404.
    log_info { "running " . join( " ", @_ ) } @args;
    my @output = capture( @args );
    die "no output received!" unless @output;
    return 1 if $output[0] =~ /200 OK/;
    return 0 if $output[0] =~ /404 Not Found/;
    die "url_exists did not find a 200 or 404: $output[0]";
}

sub _exec {
    my($self,$method) = @_;
    my $meth = $method."_cmd";
    die "cannot $meth" unless $self->can($meth);
    my $args = $self->$meth;
    log_info { "running " . join( " ", @_ ) } @$args;
    capture(@$args);
    return 1;
}

sub download {
    return shift->_exec("download");
}

sub upload {
    return shift->_exec("upload");
}

sub delete {
    return shift->_exec("delete");
}

sub head {
    return shift->_exec("head");
}

sub _local_file_required {
    my $method = shift;
    sub {
        die "parameter local_file required for $method"
          unless shift->local_file;
    };
}

before download => _local_file_required('download');
before upload => _local_file_required('upload');
1;
__END__