view release on metacpan or  search on metacpan

lib/Amazon/S3Curl/PurePerl.pm  view on Meta::CPAN

    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",
        $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;
    };
}