#!/usr/bin/env perl -T

use strict;
use warnings;
use feature 'say';
use URI;

binmode(STDOUT => ':encoding(utf8)');


=head1 NAME

simpledb - Amazon SimpleDB command line interface

=head1 VERSION

version 1.0600

=head1 SYNOPSIS

 simpledb [opts] create-domain DOMAIN
 simpledb [opts] delete-domain DOMAIN
 simpledb [opts] list-domains

 simpledb [opts] put         DOMAIN ITEM [NAME=VALUE]...
 simpledb [opts] put-replace DOMAIN ITEM [NAME=VALUE]...
 simpledb [opts] get         DOMAIN ITEM
 simpledb [opts] delete      DOMAIN ITEM [NAME[=VALUE]]...

 simpledb [opts] select SELECTEXPRESSION

=head1 OPTIONS

 --help         Print help and exit.

 --http-proxy-host

 --http-proxy-port

 --sdb-service-url URL
      Defaults to https://sdb.amazonaws.com/
      Alternatives: http://docs.aws.amazon.com/general/latest/gr/rande.html#sdb_region

 --aws-access-key-id KEY
                AWS access key id
                [Defaults to $AWS_ACCESS_KEY_ID environment variable]

 --aws-secret-access-key SECRETKEY
                AWS secret access key
                [Defaults to $AWS_SECRET_ACCESS_KEY environment variable]

 --max COUNT
                Maximum number of domains/items to retrieve and list.
                [Defaults to all]

 --separator STRING
                Separator between attribute name and value.
                [Defaults to equals (=)]

=head1 ARGUMENTS

 DOMAIN            Domain name
 ITEM              Item name
 NAME              Attribute name
 VALUE             Attribute value
 SELECTEXPRESSION  SimpleDB select expression

=head1 DESCRIPTION

This utility provides a simple command line interface to most Amazon
SimpleDB (SDB) actions.

=head1 EXAMPLES

# The following examples assume you have set these environment variables:

  export AWS_ACCESS_KEY_ID=...
  export AWS_SECRET_ACCESS_KEY=...
  export SDB_SERVICE_URL=https://sdb.eu-west-1.amazonaws.com

# Create a new SimpleDB domain:

  simpledb create-domain mydomain

# List the domains for this account:

  simpledb list-domains

# Create some items with attribute name=value pairs:

  simpledb put mydomain item1 key1=valueA key2=value2 x=why

  simpledb put mydomain item2 key1=valueB key2=value2 y=zee

# Add another value for an attribute on an item:

  simpledb put mydomain item2 y=zed when=now who=you

# Replace all values for specific attributes on an item:

  simpledb put-replace mydomain item1 key1=value1 newkey=newvalue

# Delete all values for specific attributes on an item:

  simpledb delete mydomain item1 x

# Delete specific values for specific attributes on an item:

  simpledb delete mydomain item2 who=you

# List all item names in a domain  - note backquotes around domain

  simpledb select 'select itemName() from `my-domain`'

# List all items and their attributes matching a given select query:

  simpledb select 'select * from mydomain where key2="value2"'

# List all attributes on an item:

  simpledb get mydomain item1

  simpledb get mydomain item2

# Delete the entire SimpleDB domain including all items and attributes:

  simpledb delete-domain mydomain

=head1 ENVIRONMENT

 AWS_ACCESS_KEY_ID
      Default AWS access key id

 AWS_SECRET_ACCESS_KEY
      Default AWS secret access key

 SDB_SERVICE_URL
      Default https://sdb.amazonaws.com/
      Alternatives:
  http://docs.aws.amazon.com/general/latest/gr/rande.html#sdb_region

=head1 FILES

 $HOME/.awssecret
    If the above fail, then the keys are sought here in the
    format expected by the "aws" toolkit (one per line):
      access_key_id
      secret_access_key

 /etc/passwd-s3fs
    If all of the above fail, then the keys are sought
    here in the format expected by s3fs (colon separated):
      access_key_id:secret_access_key


=head1 CAVEATS

As currently written this tool does not support keys containing equal
signs (=).

Output will be difficult to parse if the values contain newlines.

=head1 HISTORY

 2013-09-11 Andrew Solomon <andrew at illywhacker dot net>
 - Rebased on SimpleDB::Client
 - Removed proxying
 - Removed attribute parameters from "get"

 2010-04-20 Eric Hammond <ehammond@thinksome.com>
 - Removed support for "query".  Please migrate to "select"

 2009-09-01 Peter Kaminski <kaminski@istori.com>
 - Added utf8 binmode for STDOUT
 - Added select method

 2009-03-16 Eric Hammond <ehammond@thinksome.com>
 - Fix --max options and large result sets without --max
   http://code.google.com/p/amazon-simpledb-cli/issues/detail?id=2

 2008-06-09 Eric Hammond <ehammond@thinksome.com>
 - Fallback to finding keys in $HOME/.awssecret or /etc/passwd-s3fs

 2008-06-03 Eric Hammond <ehammond@thinksome.com>
 - Completed --max option
 - bugfix: Corrected --aws-secret-access-key option spelling

 2008-05-26 Eric Hammond <ehammond@thinksome.com>
 - Original release

=cut

BEGIN { # Set envariables for -T tainting.
  $ENV{'PATH'}      = '/bin:/usr/bin';
  delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
}
BEGIN { # Extract path and program name.
  use vars qw($path $prog);
  $0 =~ m%(.*)[/\\]([^/\\]*)%;
  ($path, $prog) = ($1 || '.', $2 || $0);
}

use Getopt::Long;
use Pod::Usage;
use SimpleDB::Client;
use List::Util qw(min);

my %METHODS = (
  'create-domain' => \&create_domain,
  'delete-domain' => \&delete_domain,
  'list-domains'  => \&list_domains,
  'put'           => \&put_attributes,
  'put-replace'   => \&put_replace_attributes,
  'get'           => \&get_attributes,
  'delete'        => \&delete_attributes,
  'select'        => \&select,
);

my $help        = 0;
my $aws_access_key_id     = $ENV{AWS_ACCESS_KEY_ID};
my $aws_secret_access_key = $ENV{AWS_SECRET_ACCESS_KEY};
my $sdb_service_url       = $ENV{SDB_SERVICE_URL} || 'https://sdb.amazonaws.com/';
my $replace               = 0;
my $max                   = undef;
my $separator             = '=';

Getopt::Long::config('no_ignore_case');
GetOptions(
           'help|?'                  => \$help,
           'aws-access-key-id=s'     => \$aws_access_key_id,
           'aws-secret-access-key=s' => \$aws_secret_access_key,
           'sdb-service-url=s'       => \$sdb_service_url,
           'replace'                 => \$replace,
           'max=s'                   => \$max,
           'separator=s'             => \$separator,
          )
  or pod2usage(2);

pod2usage(1) if $help;

if ( not $aws_access_key_id and not $aws_secret_access_key ) {
  # Try reading $HOME/.awssecret in case the keys are there.
  if ( open(AWSSECRET, "< $ENV{HOME}/.awssecret") ) {
    chomp($aws_access_key_id     = <AWSSECRET>);
    chomp($aws_secret_access_key = <AWSSECRET>);
    close(AWSSECRET);
  # Try reading /etc/passwd-s3fs in case the keys are there.
  } elsif ( open(S3FS, "< /etc/passwd-s3fs") ) {
    chomp(($aws_access_key_id, $aws_secret_access_key) = split(':', <S3FS>));
    close(S3FS);
  }
}

die "$prog: ERROR: Specify --aws-access-key-id and --aws-secret-access-key\n"
  unless $aws_access_key_id and $aws_secret_access_key;

my $connection_params = {};

my $sdb = SimpleDB::Client->new(
  access_key   => $aws_access_key_id,
  secret_key   => $aws_secret_access_key,
  simpledb_uri => URI->new($sdb_service_url),
);

my $command = shift(@ARGV) || pod2usage(1);
my $method = $METHODS{$command}
  || die "$prog: Unrecognized command: $command\n";

eval { &$method($sdb, @ARGV); };
say STDERR ("$prog: ERROR: Running '$command @ARGV':".$@) if $@;

exit 0;

sub create_domain {
  my ($sdb, $domain_name) = @_;

  $sdb->send_request('CreateDomain', {DomainName => $domain_name});
}

sub list_domains {
  my ($sdb) = @_;

  return if defined $max and $max <= 0;
  my $next_token;
  my $remaining = $max;
  do {
    my $rh_params = {};
    $rh_params->{NextToken} = $next_token if ($next_token);
    $rh_params->{MaxNumberOfDomains} = min($remaining, 250) if ($remaining);

    my $response = $sdb->send_request('ListDomains',  $rh_params);
    my $domain_name_list = $response->{ListDomainsResult}->{DomainName};
    print defined $_ ? "$_\n" : '' for @$domain_name_list;
    $next_token = $response->{ListDomainsResult}->{NextToken};
    $remaining -= scalar @$domain_name_list if defined $remaining;
  } while ( $next_token and (not defined $remaining or $remaining > 0));
}

sub select {
  my ($sdb, $select_expression) = @_;

  return if defined $max and $max <= 0;
  my $next_token;
  my $remaining = $max;
  do {
    my $response = $sdb->send_request('Select',{
      SelectExpression                 => $select_expression,
      ($next_token        ? (NextToken        => $next_token)          : ()),
      (defined $remaining ? (MaxNumberOfItems => min($remaining, 250)) : ()),
    });

    my $item_list = $response->{SelectResult}->{Item};
    for my $item ( @$item_list ) {
      print $item->{Name} ? ($item->{Name}, "\n") : '';
      my $attribute_list = $item->{Attribute};
      print $_->{Name} ? (' ', $_->{Name}, $separator, $_->{Value}, "\n") : ''
        for @$attribute_list;
    }

    $next_token = $response->{SelectResult}->{NextToken};
    $remaining -= scalar @$item_list if defined $remaining;
  } while ( $next_token and (not defined $remaining or $remaining > 0));
}

sub delete_domain {
  my ($sdb, $domain_name) = @_;

  my $response = $sdb->send_request('DeleteDomain',{
    DomainName => $domain_name,
  });
}


sub put_replace_attributes {
  $replace = 1;
  goto &put_attributes;
}


sub put_attributes {
  my ($sdb, $domain_name, $item_name, @pairs) = @_;

  my $response = $sdb->send_request('PutAttributes',{
    DomainName => $domain_name,
    ItemName   => $item_name,
    %{pairs_to_attributes(\@pairs, 1)},
  });
}

sub delete_attributes {
  my ($sdb, $domain_name, $item_name, @pairs) = @_;

  my $response = eval {
    $sdb->send_request('DeleteAttributes', {
      DomainName => $domain_name,
      ItemName   => $item_name,
      %{pairs_to_attributes(\@pairs, 0)},
    });
  };
}


sub get_attributes {
  my ($sdb, $domain_name, $item_name, @attribute_names) = @_;

  my %attr_param;
  for (my $i=1; $i <= scalar(@attribute_names); $i++) {
    $attr_param{"AttributeName.$i"} = $attribute_names[$i-1];
  }
  my $response = $sdb->send_request('GetAttributes', {
    DomainName => $domain_name,
    ItemName => $item_name,
    %attr_param
  });
  return unless $response->{GetAttributesResult} && ref($response->{GetAttributesResult}) ;

  my $attribute_list = ref($response->{GetAttributesResult}->{Attribute}) eq 'ARRAY' ?
    $response->{GetAttributesResult}->{Attribute} : [$response->{GetAttributesResult}->{Attribute}];

  print $_->{Name}? ($_->{Name}, $separator, $_->{Value}, "\n") : ''
    for @$attribute_list;
}


sub pairs_to_attributes {
  my ($pairs, $with_replace) = @_;

  my %attributes = ();
  for (my $i = 1; $i <= scalar(@$pairs); $i++) {
    my $pair = $pairs->[$i-1];
    my ($name, $value) = split(/$separator/, $pair, 2);
    my $prefix = "Attribute.$i.";
    $attributes{"${prefix}Name"}  = $name;
    $attributes{"${prefix}Value"} = $value;
    if ($with_replace && $replace) {
      $attributes{"${prefix}Replace"} = 'true';
    }
  }
  return \%attributes;
}