The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package WebService::Amazon::DynamoDB;
# ABSTRACT: Abstract API support for Amazon DynamoDB
use strict;
use warnings;

our $VERSION = '0.005';

=head1 NAME

WebService::Amazon::DynamoDB - support for the AWS DynamoDB API

=head1 VERSION

version 0.005

=head1 SYNOPSIS

 # Using access key
 my $ddb = WebService::Amazon::DynamoDB->new(
  version        => '20120810',
  access_key     => 'access_key',
  secret_key     => 'secret_key',
  uri            => 'http://localhost:8000',
 );
 $ddb->batch_get_item(
  sub {
   my $tbl = shift;
   my $data = shift;
   warn "Batch get: $tbl had " . join(',', %$data) . "\n";
  },
  items => {
   $table_name => {
    keys => [
     name => 'some test name here',
    ],
    fields => [qw(name age)],
   }
  },
 )->get;

 # Using the IAM role from the current EC2 instance
 my $ddb = WebService::Amazon::DynamoDB->new(
  security       => 'iam',
 );

 # Using a specific IAM role
 my $ddb = WebService::Amazon::DynamoDB->new(
  security       => 'iam',
  iam_role       => 'role_name',
 );

=head1 BEFORE YOU START

B<NOTE>: I'd recommend looking at the L<Amazon::DynamoDB> module first.
It is a fork of this one with better features, more comprehensive tests,
and overall it's maintained much more actively.

=head1 DESCRIPTION

Provides a L<Future>-based API for Amazon's DynamoDB REST API.
See L<WebService::Amazon::DynamoDB::20120810> for available methods.

Current implementations for issuing the HTTP requests:

=over 4

=item * L<WebService::Async::UserAgent::NaHTTP> - use L<Net::Async::HTTP>
for applications based on L<IO::Async> (this gives nonblocking behaviour)

=item * L<WebService::Async::UserAgent::LWP> - use L<LWP::UserAgent> (will
block, timeouts are unlikely to work)

=item * L<WebService::Async::UserAgent::MojoUA> - use L<Mojo::UserAgent>,
should be suitable for integration into a L<Mojolicious> application (could
be adapted for nonblocking, although the current version does not do this).

=back

Only the L<Net::Async::HTTP> implementation has had any significant testing or use.

=cut

use WebService::Amazon::IAM::Client;

use WebService::Amazon::DynamoDB::20120810;
use Module::Load;
use POSIX qw(strftime);

use Log::Any qw($log);

=head1 METHODS

=cut

sub new {
	my $class = shift;
	my %args = @_;
	$args{implementation} //= 'WebService::Async::UserAgent::NaHTTP';
	unless(ref $args{implementation}) {
		$log->debugf("Loading module for HTTP implementation [%s]", $args{implementation});
		Module::Load::load($args{implementation});
		$log->debugf("Instantiating [%s]", $args{implementation});
		$args{implementation} = $args{implementation}->new(
			(exists $args{loop} ? (loop => delete $args{loop}) : ())
		);
	}
	my $version = delete $args{version} || '20120810';
	my $pkg = __PACKAGE__ . '::' . $version;
	$log->debugf("Look for ->new in [%s]", $pkg);
	if(my $code = $pkg->can('new')) {
		$class = $pkg if $class eq __PACKAGE__;
		$args{security} ||= 'key';
		$args{region} ||= 'us-west-1';
		$args{iam_role} = Future->done($args{iam_role}) if exists $args{iam_role} && !ref $args{iam_role};
		if(exists $args{host} or exists $args{port}) {
			$args{uri} = URI->new('http://' . $args{host} . ':' . $args{port});
		} else {
			$args{uri} ||= 'https://dynamodb.' . $args{region} . '.amazonaws.com/';
			$args{uri} = URI->new($args{uri}) unless ref $args{uri};
		}
		return $code->($class, %args)
	}
	die "No support for version $version";
}

sub security { shift->{security} }

sub uri { shift->{uri} }

sub api_version { ... }

=head2 make_request

Generates an L<HTTP::Request>.

=cut

sub make_request {
	my $self = shift;
	my %args = @_;
	my $target = $args{target};
	my $js = JSON::MaybeXS->new;
	my $req = HTTP::Request->new(
		POST => $self->uri
	);
	$req->header( host => $self->uri->host );
	my $http_date = strftime('%a, %d %b %Y %H:%M:%S %Z', localtime);
	$req->protocol('HTTP/1.1');
	$req->header( 'Date' => $http_date );
	$req->header( 'x-amz-date' => strftime('%Y%m%dT%H%M%SZ', gmtime) );
	$req->header( 'x-amz-target', 'DynamoDB_'. $self->api_version. '.'. $target );
	$req->header( 'content-type' => 'application/x-amz-json-1.0' );
	my $payload = $js->encode($args{payload});
	$req->content($payload);
	$req->header( 'Content-Length' => length($payload));
	$self->credentials->then(sub {
		my ($creds) = @_;
		# Don't show these by default
		# $log->debugf("Using [%s] for credentials", $creds);
		my $token = delete $creds->{token};
		my $amz = WebService::Amazon::Signature->new(
			version    => 4,
			algorithm  => $self->algorithm,
			scope      => $self->scope,
			%$creds,
		);
		$amz->from_http_request($req);
		$req->header(Authorization => $amz->calculate_signature);
		$req->header('X-Amz-Security-Token' => $token) if defined $token;
		Future->done($req)
	})
}

sub credentials {
	my ($self) = @_;
	if($self->security eq 'key') {
		$log->debugf("Using key-based security");
		# We don't bother caching the hashref, since we'd need to be passing
		# a copy anyway (caller may change the values)
		return Future->done({
			access_key => $self->access_key,
			secret_key => $self->secret_key,
		})
	}

	return $self->cached_iam_credentials->else(sub {
		$log->debug("No cached credentials (or already expired)");
		$self->find_iam_role->then(sub {
			my ($role) = @_;
			$log->debugf("Found role [%s]", $role);
			$self->retrieve_iam_credentials(
				$role
			)
		})
	});
}

sub cached_iam_credentials {
	my ($self) = @_;
	return Future->fail('no cached credentials') unless exists $self->{cached_iam_credentials};

	# Assume expired if we're within 5 seconds
	return Future->fail('cached credentials expire') if $self->{cached_iam_credentials}{expire_at} <= time - 5;

	# Shallow copy, so we're not affected if the caller changes the values
	return Future->done({
		%{ $self->{cached_iam_credentials}{details} }
	})
}

sub find_iam_role {
	my ($self) = @_;
	$self->{iam_role} //= $self->iam->active_roles
}

sub retrieve_iam_credentials {
	my ($self, $role) = @_;
	$self->iam->credentials_for_role($role)->then(sub {
		my ($creds, $expiry) = @_;
		$log->debugf("New credentials received, will expire in %s seconds", strftime '%H:%M:%S', gmtime($expiry - time));
		$self->{cached_iam_credentials} = {
			expire_at => $expiry,
			details => $creds
		};
		# Shallow copy, so we're not affected if the caller changes the values
		Future->done({ %$creds })
	})
}

sub _request {
	my $self = shift;
	my $req = shift;
	# Don't show requests by default
	# $log->debugf("Issuing request [%s]", $req->as_string("\n"));
	$self->implementation->request($req)
}

sub iam {
	$_[0]->{iam} //= WebService::Amazon::IAM::Client->new(
		ua => $_[0]->implementation,
	)
}

1;

__END__

=head1 SEE ALSO

=over 4

=item * L<Net::Amazon::DynamoDB> - supports the older (2011) API with v2
signing, so it doesn't work with L<DynamoDB Local|http://docs.aws.amazon.com/amazondynamodb/latest/developerguide/Tools.html>.

=item * L<AWS::CLIWrapper> - alternative approach using wrappers around AWS
commandline tools

=back

=head1 AUTHOR

Tom Molesworth <cpan@perlsite.co.uk>

=head1 LICENSE

Copyright Tom Molesworth 2013-2015. Licensed under the same terms as Perl itself.