The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Data::Riak::HTTP::Response;
{
  $Data::Riak::HTTP::Response::VERSION = '1.4';
}

use strict;
use warnings;

use Moose;
use URI;
use HTTP::Headers::ActionPack 0.05;

use overload '""' => 'as_string', fallback => 1;

my $_deconstruct_parts;

has 'parts' => (
    is => 'ro',
    isa => 'ArrayRef[HTTP::Message]',
    lazy => 1,
    default => sub {
        my $self = shift;
        my @parts = $_deconstruct_parts->( $self->http_response );
        return \@parts;
    }
);

has 'http_response' => (
    is => 'ro',
    isa => 'HTTP::Response',
    required => 1,
    handles => {
        code        => 'code',
        status_code => 'code',
        message     => 'content',
        value       => 'content',
        is_success  => 'is_success',
        is_error    => 'is_error',
        as_string   => 'as_string',
        header      => 'header',
        headers     => 'headers'
    }
);

$_deconstruct_parts = sub {
    my $message = shift;
    return () unless $message->content;
    my @parts = $message->parts;
    return $message unless @parts;
    return map { $_deconstruct_parts->( $_ ) } @parts;
};

with 'Data::Riak::Transport::Response';

sub create_results {
    my ($self, $riak, $request) = @_;

    return map {
        $self->_create_result($riak, $request, $_)
    } @{ $self->parts };
}

my %header_values = (
    etag          => 'etag',
    content_type  => 'content-type',
    vector_clock  => 'x-riak-vclock',
    last_modified => 'last_modified',
);

sub _create_result {
    my ($self, $riak, $request, $http_message) = @_;

    HTTP::Headers::ActionPack->new->inflate( $http_message->headers );

    my %result_args = (
        riak          => $riak,
        status_code   => $self->http_response->code, # FIXME: http specific
        value         => $http_message->content,
        (map {
            my $v = $http_message->header($header_values{$_});
            defined $v ? ($_ => $v) : ();
        } keys %header_values),
    );

    if ($request->result_does('Data::Riak::Result::WithLocation')) {
        $result_args{location} = $http_message->can('request')
            ? $http_message->request->uri
            : (URI->new( $http_message->header('location') )
                   || die 'Cannot determine location from ' . $http_message);
    }

    if ($request->result_does('Data::Riak::Result::WithLinks')) {
        my $links = $http_message->header('link');
        $result_args{links} = [map {
            Data::Riak::Link->from_link_header($_)
        } $links ? $links->iterable : ()],
    }

    return $request->new_result(\%result_args);
}

__PACKAGE__->meta->make_immutable;
no Moose;

1;

__END__

=pod

=head1 NAME

Data::Riak::HTTP::Response

=head1 VERSION

version 1.4

=head1 AUTHORS

=over 4

=item *

Andrew Nelson <anelson at cpan.org>

=item *

Florian Ragwitz <rafl@debian.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Infinity Interactive.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut