package Amazon::API::Botocore::Shape;

use strict;
use warnings;

our $VERSION = '2.4.6';

use parent qw(Exporter Class::Accessor::Fast);

use Amazon::API::Constants qw(:chars :booleans);
use Amazon::API::Botocore::Shape::Utils qw(flatten require_shape check_type check_pattern check_enum _check );
use Amazon::API::NullLogger;

use Carp qw(croak confess);
use Cwd;
use Data::Dumper;
use English qw(-no_match_vars);
use Readonly;
use Scalar::Util qw( reftype blessed looks_like_number );
use List::Util qw( any pairs none );
use JSON::PP;

__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors(
  qw(
    documentation
    enum
    flattened
    logger
    location
    locationName
    key
    value
    max
    member
    members
    min
    paginator
    pattern
    required
    service
    shape
    streaming
    timestampFormat
    type
    _value
  )
);

our $PROTOCOL;
our $LOGGER_SOURCE;

# request-side value validation mode (enum/min/max/pattern) is the canonical
# global $Amazon::API::VALIDATE_MODE: 'strict' (default) croaks, 'warn' carps and
# passes through, 'off' skips. Amazon::API sets the default; localize it for
# per-call override:  local $Amazon::API::VALIDATE_MODE = 'off';

########################################################################
sub new {
########################################################################
  my ( $class, $args, $is_response ) = @_;

  my $self = $class->SUPER::new($args);

  $self->set_logger(
      $LOGGER_SOURCE
    ? $LOGGER_SOURCE->($class)
    : Amazon::API::NullLogger->new
  );

  if ($is_response) {
    $self->set__value(undef);
    return;
  }

  $self->_init_value;

  return $self;
}

########################################################################
sub is_structure {
########################################################################
  my ($self) = @_;

  return $self->get_type eq 'structure';
}

########################################################################
sub is_list {
########################################################################
  my ($self) = @_;

  return $self->get_type eq 'list';
}

########################################################################
sub is_string {
########################################################################
  my ($self) = @_;

  return $self->get_type eq 'string';
}

########################################################################
sub is_integer {
########################################################################
  my ($self) = @_;

  return $self->get_type eq 'integer';
}

########################################################################
sub is_map {
########################################################################
  my ($self) = @_;

  return $self->get_type eq 'map';
}

########################################################################
sub is_flattened {
########################################################################
  my ($self) = @_;

  return $self->get_flattened;
}

########################################################################
sub _init_structure {
########################################################################
  my ($self) = @_;

  my $value = $self->get__value;

  foreach my $member ( @{ $self->get_required // [] } ) {
    croak "$member is a required parameter"
      if !any { $_ eq $member } keys %{$value};
  }

  my %result = %{$value};  # do not alter input!

  foreach my $member ( keys %{ $self->get_members } ) {

    if ( exists $result{$member} ) {
      my $val = $result{$member};
      next if blessed $val && reftype($val) eq 'SCALAR';  # JSON::PP::true

      my $class = require_shape( $self->get_members->{$member}->{shape}, $self->get_service );

      $result{$member} = $class->new($val);
    }
  }

  return \%result;
}

########################################################################
sub _init_map {
########################################################################
  my ($self) = @_;

  my $value = $self->get__value;

  return $value
    if $self->is_flattened;

  if ( ref $value eq 'HASH' ) {
    $value = [$value];
  }

  foreach my $elem ( @{$value} ) {
    croak 'elements of a map must be of type HASH'
      if ref($elem) ne 'HASH';
  }

  my @list;

  my $value_class = require_shape( $self->get_value->{shape}, $self->get_service );

  foreach my $elem ( @{$value} ) {
    my @kv = %{$elem};
    # Use the plain key string as the hash key - NOT $key_class->new($kv[0]),
    # which Perl would stringify into a blessed-object ref, destroying the
    # real key value. Use pairs to process ALL key-value pairs in the element,
    # not just the first ($kv[0]/$kv[1]) which would drop all but one entry
    # from multi-key maps like Lambda EnvironmentMap.
    for my $pair ( pairs @kv ) {
      my ( $k, $v ) = @{$pair};
      push @list, { $k => $value_class->new($v) };
    }
  }

  $value = \@list;

  return $value;
}

########################################################################
sub _init_list {
########################################################################
  my ($self) = @_;

  my $value = $self->get__value;

  _check( !$self->get_max || @{$value} <= $self->get_max, q{more than } . ( $self->get_max // q{} ) . q{ elements in list} );

  _check( !$self->get_min || @{$value} >= $self->get_min,
    q{need at least } . ( $self->get_min // q{} ) . q{ elements in list} );

  my $class = require_shape( $self->get_member->{shape}, $self->get_service );

  # do not alter the input!
  my @list;

  foreach my $elem ( @{$value} ) {
    push @list, $class->new($elem);
  }

  return \@list;
}

########################################################################
sub _init_string {
########################################################################
  my ($self) = @_;

  my $value = $self->get__value;

  my $pattern = $self->get_pattern;

  check_pattern( $value, $pattern );

  check_enum( $value, $self->get_enum );

  _check( !$self->get_min || length $value >= $self->get_min, q{length of value must be >= } . ( $self->get_min // q{} ) );

  _check( !$self->get_max || length $value <= $self->get_max, q{length of value must be <= } . ( $self->get_max // q{} ) );

  return $value;
}

########################################################################
sub _init_integer {
########################################################################
  my ($self) = @_;

  my $value = $self->get__value;

  _check( !defined $self->get_min || $value >= $self->get_min, q{value must be >= } . ( $self->get_min // q{} ) );

  _check( !defined $self->get_max || $value <= $self->get_max, q{value must be <= } . ( $self->get_max // q{} ) );

  return $value;
}

########################################################################
sub _init_value {
########################################################################
  my ($self) = @_;

  my $value = $self->get__value;

  return
    if !$value;

  # timestamp members accept an epoch or any object that can ->epoch
  # (Time::Piece, DateTime - duck-typed, never loaded here). Coerce to epoch
  # now so it satisfies the SCALAR guard below and formats downstream.
  if ( $self->get_type eq 'timestamp' && blessed $value && $value->can('epoch') ) {
    $value = $value->epoch;
    $self->set__value($value);
  }

  croak 'ref type of value should be one of SCALAR, ARRAY or HASH'
    if blessed $value && reftype($value) ne 'SCALAR';

  my %types = (
    structure => 'HASH',
    list      => 'ARRAY',
    map       => [ 'ARRAY', 'HASH' ],
    string    => 'SCALAR',
    integer   => 'SCALAR',
    long      => 'SCALAR',
    timestamp => 'SCALAR',
    double    => 'SCALAR',
    boolean   => 'SCALAR',
    blob      => 'SCALAR',
  );

  my $required_type = $types{ $self->get_type };

  my $actual_type = ref($value) || 'SCALAR';

  check_type( $required_type, $actual_type )
    or croak sprintf '%s requires a value of type %s', ref $self,
    $required_type;

  my %init_value_subs = (
    structure => sub { $self->_init_structure },
    map       => sub { $self->_init_map },
    list      => sub { $self->_init_list },
    string    => sub { $self->_init_string },
    integer   => sub { $self->_init_integer },
  );

  my $sub = $init_value_subs{ $self->get_type } // sub { return $value };

  $self->set__value( $sub->() );

  return $value;
}

########################################################################
sub get_shape_type {
########################################################################
  my ($self) = @_;

  return 'MAP'
    if $self->is_map;

  return 'STRUCTURE'
    if $self->is_structure;

  return 'LIST'
    if $self->is_list;

  return 'SCALAR';
}

# 'finalization' of a shape is done in order to create a data structure
# that can then be used to create a Botocore request
########################################################################
sub finalize {
########################################################################
  my ( $self, $protocol ) = @_;

  local $PROTOCOL = $protocol
    if defined $protocol;

  $self->get_logger->debug( 'returning because ' . ref($self) . ' is not blessed?' )
    if !blessed $self;

  return $self
    if !blessed $self;

  $self->get_logger->debug(
    sub {
      return Dumper(
        [ type       => $self->get_type,
          shape_type => $self->get_shape_type,
          shape      => $self,
          protocol   => $PROTOCOL,
        ]
      );
    }
  );

  my %dispatch = (
    SCALAR => sub {
      my $type = $self->get_type;

      my $val = $self->get__value;

      $self->get_logger->debug(
        Dumper(
          [ type => $type,
            val  => $val
          ]
        )
      );

      if ( $type eq 'integer' || $type eq 'long' ) {
        return defined $val ? $val + 0 : $val;
      }
      elsif ( $type eq 'float' || $type eq 'double' ) {
        return defined $val ? $val * 1.0 : $val;
      }
      elsif ( $type eq 'boolean' ) {
        my $bool_value = $val ? 1 : 0;

        # query/ec2 protocols serialize via param_n()/query_param_n()
        # (Botocore::Shape::Utils), which flatten the request into
        # key=value query-string pairs and have no JSON encoder
        # downstream - they can't handle a JSON::PP::true/false blessed
        # scalar ref and die trying to dereference it as an array.
        # JSON-style protocols need the blessed sentinel so the eventual
        # encode_json call emits true/false rather than "1"/"0".
        return $bool_value
          if $PROTOCOL && $PROTOCOL =~ /^(?:query|ec2)$/xsm;

        return $bool_value ? JSON::PP::true : JSON::PP::false;
      }
      elsif ( $type eq 'blob' ) {
        # value blobs (KMS Plaintext, Kinesis Data, ...) are base64 on the
        # wire for every protocol. Streaming blobs (an S3 PutObject body)
        # are the raw payload and must pass through untouched.
        return $val
          if !defined $val || $self->get_streaming;

        require MIME::Base64;
        return MIME::Base64::encode_base64( $val, $EMPTY );  # single line, no breaks
      }

      return $val;
    },
    MAP       => sub { return $self->finalize_map },
    LIST      => sub { return $self->finalize_list },
    STRUCTURE => sub { return $self->finalize_structure },
  );

  return $dispatch{ $self->get_shape_type }->();
}

########################################################################
sub finalize_map {
########################################################################
  my ($self) = @_;

  my $location_name = $self->{locationName};

  my ( $key, $value ) = @{$self}{qw(key value)};

  my $key_location_name   = $key->{locationName};
  my $value_location_name = $value->{locationName};

  $key   = $key_location_name   || undef;
  $value = $value_location_name || undef;

  my @elem_list = eval {
    my $values = $self->get__value;

    return @{$values}
      if reftype($values) ne 'HASH';

    return map {
      { $_ => $values->{$_} }
    } keys %{$values};
  };

  my $list
    = $key
    ? _create_key_value_list( $key, $value, @elem_list )
    : [@elem_list];

  return flatten( $location_name, $list )
    if $self->is_flattened;

  # Non-flattened maps in the query/ec2 protocols use an 'entry.N'
  # wrapper (e.g. MessageAttributes.entry.1.Name=Foo), NOT the 'member.N'
  # wrapper that query_param_n applies to generic lists. Pre-index the
  # entries into an entry.N-keyed hash here - the only stage that knows
  # this is a map - so the generic walker emits the correct keys.
  if ( $key && $PROTOCOL && ( any { $PROTOCOL eq $_ } qw( query ec2 ) ) ) {
    my %indexed;
    my $idx = 1;
    foreach my $entry ( @{$list} ) {
      $indexed{ 'entry.' . $idx++ } = $entry;
    }
    return $location_name ? { $location_name => \%indexed } : \%indexed;
  }

  # Non-flattened maps with no key/value location names (e.g. Lambda
  # EnvironmentMap) should be returned as a plain hashref with shape
  # values finalized. Without this, blessed shape objects survive into
  # JSON encoding and cause serialization errors.
  if ( !$key && $PROTOCOL && !( any { $PROTOCOL eq $_ } qw( query ec2 ) ) ) {
    my %plain;
    for my $item (@elem_list) {
      for my $pair ( pairs %{$item} ) {
        my ( $k, $v ) = @{$pair};
        $plain{$k} = blessed $v ? $v->finalize : $v;
      }
    }

    return $location_name ? { $location_name => \%plain } : \%plain;
  }

  # Keyed non-query maps (REST-JSON maps with explicit key/value
  # location names) — return the pre-built list as-is.
  return $location_name ? { $location_name => $list } : $list;
}

# @list is an array of key/value hashes
########################################################################
sub _create_key_value_list {
########################################################################
  my ( $key, $value, @list ) = @_;

  my @kv_list;

  foreach my $p ( pairs map { %{$_} } @list ) {
    my ( $k, $v ) = @{$p};

    push @kv_list,
      {
      $key   => $k,
      $value => blessed $v ? $v->finalize : $v,
      };

  }

  return \@kv_list;
}

########################################################################
sub finalize_list {
########################################################################
  my ($self) = @_;

  my $member = $self->get_member;

  my $location_name = $member->{locationName};

  my $list = [];

  my $output;

  my @bare_list_protocols = qw( ec2 query );

  if ( $location_name && none { $PROTOCOL eq $_ } @bare_list_protocols ) {
    $output = {};
    $output->{$location_name} = $list;
  }
  else {
    $output = $list;
  }

  foreach my $elem ( @{ $self->get__value } ) {
    push @{$list}, $elem->finalize;
  }

  return flatten($output)
    if $self->is_flattened;

  return $output;
}

########################################################################
sub _format_timestamp {
########################################################################
  my ( $value, $format ) = @_;

  return $value
    if !defined $value;

  # canonicalize input to epoch seconds. Accept epoch (int/float) or any
  # object that can ->epoch (Time::Piece, DateTime) - duck-typed so we never
  # load DateTime. Bare strings are refused rather than date-parsed (that is
  # boto's fragile path); pass an epoch or a Time::Piece/DateTime.
  my $epoch
    = ( blessed $value && $value->can('epoch') ) ? $value->epoch
    : looks_like_number($value)                  ? $value
    :   croak "timestamp: expected epoch seconds or a Time::Piece/DateTime, got '$value'\n";

  return $epoch + 0
    if $format eq 'unixTimestamp';

  my @g = gmtime int $epoch;

  return sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ', $g[5] + 1900, $g[4] + 1, $g[3], $g[2], $g[1], $g[0]
    if $format eq 'iso8601';

  # rfc822 - explicit English names (locale-independent), matches boto's
  # email.utils.formatdate(usegmt=True): "Wed, 17 Jun 2015 22:11:58 GMT"
  my @dow = qw(Sun Mon Tue Wed Thu Fri Sat);
  my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);

  return sprintf '%s, %02d %s %04d %02d:%02d:%02d GMT', $dow[ $g[6] ], $g[3], $mon[ $g[4] ], $g[5] + 1900, $g[2], $g[1], $g[0];
}

########################################################################
sub finalize_structure {
########################################################################
  my ($self) = @_;

  my $members = $self->get_members;

  $self->get_logger->debug(
    sub {
      return Dumper(
        [ sub     => 'finalize',
          members => $members,
          value   => $self->get__value,
        ]
      );
    }
  );

  my $output = {};

  foreach my $member ( keys %{$members} ) {

    my $member_name;

    if ( !$members->{$member}->{location} ) {
      $member_name = $members->{$member}->{locationName} // $member;
    }
    else {
      $member_name = $member;
    }

    next
      if !defined $self->get__value->{$member};

    my $value = $self->get__value->{$member};

    if ( blessed $value && $value->can('get_type') && $value->get_type eq 'timestamp' ) {
      # resolve the effective wire format, most-specific first:
      #   member timestampFormat -> shape timestampFormat -> location default
      #   (header=>rfc822, querystring=>iso8601) -> protocol body default
      #   (json/rest-json=>unixTimestamp, else iso8601).
      my $location = $members->{$member}->{location} // $EMPTY;

      my $format = $members->{$member}->{timestampFormat} // $value->get_timestampFormat // (
          $location eq 'header'                ? 'rfc822'
        : $location eq 'querystring'           ? 'iso8601'
        : ( $PROTOCOL // $EMPTY ) =~ /json/xsm ? 'unixTimestamp'
        :                                        'iso8601'
      );

      $output->{$member_name} = _format_timestamp( $value->get__value, $format );
    }
    else {
      $output->{$member_name} = blessed $value && $value->can('finalize') ? $value->finalize : $value;
    }
  }

  return $output;
}

1;

