File Coverage

blib/lib/Stash/REST.pm

Criterion	Covered	Total	%
statement	199	207	96.1
branch	86	122	70.4
condition	43	78	55.1
subroutine	21	21	100.0
pod	8	8	100.0
total	357	436	81.8

package Stash::REST;
use strict;
use 5.008_005;
our $VERSION = '0.08';

use warnings;
use utf8;
use URI;
use URI::QueryParam;
use HTTP::Request::Common qw(GET POST DELETE HEAD);
use Carp qw/confess cluck/;

use Moo;
use namespace::clean;

use Class::Trigger;

has 'do_request' => (
    is       => 'rw',
    isa      => sub { die "$_[0] is not a CodeRef" unless ref $_[0] eq 'CODE' },
    required => 1
);

has 'decode_response' => (
    is       => 'rw',
    isa      => sub { die "$_[0] is not a CodeRef" unless ref $_[0] eq 'CODE' },
    required => 1
);

has 'stash' => (
    is  => 'rw',
    isa => sub { die "$_[0] is not a HashRef" unless ref $_[0] eq 'HASH' },
    default => sub { {} }
);

has 'fixed_headers' => (
    is  => 'rw',
    isa => sub { die "$_[0] is not a ArrayRef" unless ref $_[0] eq 'ARRAY' },
    default => sub { [] }
);

around 'stash' => sub {
    my $orig  = shift;
    my $c     = shift;
    my $stash = $orig->($c);

    if (@_) {
        return $stash->{ $_[0] } if ( @_ == 1 && ref $_[0] eq '' );

        my $new_stash = @_ > 1 ? {@_} : $_[0];
        die('stash takes a hash or hashref') unless ref $new_stash;
        foreach my $key ( keys %$new_stash ) {
            $stash->{$key} = $new_stash->{$key};
        }
    }

    return $stash;
};

sub _capture_args {
    my ( $method, $self, @params ) = @_;
    my ( $uri, $data, %conf );

    confess 'invalid number of params' if @params < 1;

    $uri = shift @params;
    confess 'invalid uri param' if ref $uri ne '' && ref $uri ne 'ARRAY';

    $uri = join '/', @$uri if ref $uri eq 'ARRAY';

    # if number of params is odd, then, the last item is defined as $data
    if ( scalar @params % 2 == 0 ) {
        %conf = @params;
        $data = exists $conf{data} ? $conf{data} : undef;
    }
    else {
        $data = pop @params;
        %conf = @params;
    }

    confess 'param $data should be an array ref'
      if ref $data ne 'ARRAY' && ( exists $conf{headers} && !grep { 'Content-Type' } @{ $conf{headers} } );

    confess "Can't use ->{files} helper with custom Content-Type."
      if exists $conf{files} && ( exists $conf{headers} && grep { 'Content-Type' } @{ $conf{headers} } );

    my $can_have_body = $method =~ /POST|PUT|DELETE/;

    if ( !$can_have_body && $data && ref $data eq 'ARRAY' ) {
        confess "$method can't have {data}. Please, use only {params} instead" if ( exists $conf{params} );

        $conf{params} = $data;

    }
    elsif ( !$can_have_body && $data ) {
        cluck "$method does not allow body. You may have problems with proxy. Consider removing it";
        $conf{data} = $data;
    }
    else {
        $conf{data} = $data;
    }

    return ( $self, $uri, %conf );
}

sub rest_put {
    my ( $self, $url, %conf ) = &_capture_args( 'PUT', @_ );

    $self->call_trigger( 'before_rest_put', { url => $url, conf => \%conf } );
    $self->_rest_request(
        $url,
        code => ( exists $conf{is_fail} ? 400 : 202 ),
        %conf,
        method => 'PUT'
    );
}

sub rest_head {
    my ( $self, $url, %conf ) = &_capture_args( 'HEAD', @_ );

    $self->call_trigger( 'before_rest_head', { url => $url, conf => \%conf } );
    $self->_rest_request(
        $url,
        code => 200,
        %conf,
        method => 'HEAD'
    );
}

sub rest_delete {
    my ( $self, $url, %conf ) = &_capture_args( 'DELETE', @_ );

    $self->call_trigger( 'before_rest_delete', { url => $url, conf => \%conf } );
    $self->_rest_request(
        $url,
        code => 204,
        %conf,
        method => 'DELETE'
    );
}

sub rest_get {
    my ( $self, $url, %conf ) = &_capture_args( 'GET', @_ );

    $self->call_trigger( 'before_rest_get', { url => $url, conf => \%conf } );
    $self->_rest_request(
        $url,
        code => 200,
        %conf,
        method => 'GET'
    );
}

sub rest_post {
    my ( $self, $url, %conf ) = &_capture_args( 'POST', @_ );
    $self->call_trigger( 'before_rest_post', { url => $url, conf => \%conf } );

    $self->_rest_request( $url, %conf, method => 'POST' );
}

sub _rest_request {
    my ( $self, $url, %conf ) = @_;

    my $data = exists $conf{data} ? $conf{data} : undef;

    $conf{automatic_load_item} = 1 unless exists $conf{automatic_load_item};

    my $is_fail = exists $conf{is_fail} && $conf{is_fail};

    my $code = $conf{code};
    $code ||= $is_fail ? 400 : 201;
    $conf{code} = $code;

    my $uri = URI->new($url);
    if ( $conf{params} ) {
        my @old = ref $conf{params} eq 'ARRAY' ? @{ $conf{params} } : %{ $conf{params} };
        while ( my ( $k, $v ) = splice( @old, 0, 2 ) ) {
            $uri->query_param_append( $k, $v );
        }
    }
    $url = $uri->as_string;

    my $stashkey = exists $conf{stash} ? $conf{stash} : undef;

    my @headers = ( @{ $self->fixed_headers() }, @{ $conf{headers} || [] } );

    my $req;

    if ( !exists $conf{files} ) {
        if ( defined $data ) {
            $req = POST $url, @headers, Content => $data;
        }
        else {
            $req = GET $url, @headers;
        }
    }
    else {
        $conf{files}{$_} = [ $conf{files}{$_} ] for keys %{ $conf{files} };

        $req = POST $url, @headers,
          'Content-Type' => 'form-data',
          Content        => [ ( $data && ref $data eq 'ARRAY' ? @$data : () ), %{ $conf{files} } ];
    }

    $conf{process_request}->( { req => $req, conf => \%conf } )
      if ( exists $conf{process_request} && ref $conf{process_request} eq 'CODE' );

    $self->call_trigger( 'process_request', { req => $req, conf => \%conf } );

    # change to correct method.
    $req->method( $conf{method} );

    my $res = eval { $self->do_request()->($req) };
    confess "request died: $@" if $@;

    $conf{process_response}->( { req => $req, res => $res, conf => \%conf } )
      if ( exists $conf{process_response} && ref $conf{process_response} eq 'CODE' );

    $self->call_trigger( 'process_response', { req => $req, res => $res, conf => \%conf } );

    #is( $res->code, $code, $name . ' status code is ' . $code );
    if ( !exists $conf{skip_response_tests} ) {
        confess 'response expected fail and it is successed' if $is_fail  && $res->is_success;
        confess 'response expected success and it is failed' if !$is_fail && !$res->is_success;

        confess 'response code [', $res->code, '] diverge expected [', $code, ']' if $code != $res->code;
    }

    $conf{process_response_success}->( { req => $req, res => $res, conf => \%conf } )
      if ( exists $conf{process_response_success} && ref $conf{process_response_success} eq 'CODE' );

    $self->call_trigger( 'process_response_success', { req => $req, res => $res, conf => \%conf } );

    return '' if $code == 204;
    return $res if exists $conf{method} && $conf{method} eq 'HEAD';

    my $obj = eval { $self->decode_response()->($res) };
    confess("decode_response failed: $@") if $@;

    $conf{response_decoded}->( { req => $req, res => $res, decoded => $obj, conf => \%conf } )
      if ( exists $conf{response_decoded} && ref $conf{response_decoded} eq 'CODE' );

    $self->call_trigger( 'response_decoded', { req => $req, res => $res, decoded => $obj, conf => \%conf } );

    if ($stashkey) {
        $self->stash->{$stashkey} = $obj;

        $self->stash( $stashkey . '.prepare_request' => $conf{prepare_request} ) if exists $conf{prepare_request};

        if ( $code == 201 ) {
            $self->stash( $stashkey . '.id' => $obj->{id} ) if ref $obj eq 'HASH' && exists $obj->{id};

            my $item_url = $res->header('Location');

            if ( $item_url && $conf{automatic_load_item} ) {
                $self->stash->{ $stashkey . '.url' } = $item_url;

                $self->rest_reload($stashkey);

                $conf{item_loaded}->( { stash => $stashkey, conf => \%conf } )
                  if ( exists $conf{item_loaded} && ref $conf{item_loaded} eq 'CODE' );

                $self->call_trigger( 'item_loaded', { stash => $stashkey, conf => \%conf } );
            }
            else {
                confess 'requests with response code 201 should contain header Location';
            }

            $conf{stash_added}->( { stash => $stashkey, conf => \%conf } )
              if ( exists $conf{stash_added} && ref $conf{stash_added} eq 'CODE' );
            $self->call_trigger( 'stash_added', { stash => $stashkey, conf => \%conf } );
        }
    }

    if ( $stashkey && exists $conf{list} ) {

        $self->stash( $stashkey . '.list-url' => $url );

        $self->rest_reload_list($stashkey);

        $conf{list_loaded}->( { stash => $stashkey, conf => \%conf } )
          if ( exists $conf{list_loaded} && ref $conf{list_loaded} eq 'CODE' );

        $self->call_trigger( 'list_loaded', { stash => $stashkey, conf => \%conf } );

    }

    return $obj;
}

sub rest_reload {
    my $self     = shift;
    my $stashkey = shift;

    my %conf = @_;

    my $code = exists $conf{code} ? $conf{code} : 200;
    $conf{code} = $code;

    my @headers = ( @{ $self->fixed_headers() }, @{ $conf{headers} || [] } );
    my $item_url = $self->stash->{ $stashkey . '.url' };

    confess "can't stash $stashkey.url is not valid" unless $item_url;

    my $prepare_request =
      exists $self->stash->{ $stashkey . '.prepare_request' }
      ? $self->stash->{ $stashkey . '.prepare_request' }
      : undef;

    confess 'prepare_request must be a coderef'
      if $prepare_request && ref $prepare_request ne 'CODE';

    my $req = GET $item_url, @headers;
    $req->method('GET');
    $prepare_request->($req) if $prepare_request;

    $self->call_trigger( 'process_request', { req => $req, conf => \%conf } );
    my $res = $self->do_request()->($req);

    $self->call_trigger( 'process_response', { req => $req, res => $res, conf => \%conf } );

    confess 'request code diverge expected' if $code != $res->code;

    $self->call_trigger( 'process_response_success', { req => $req, res => $res, conf => \%conf } );

    my $obj;
    if ( $res->code == 200 ) {
        my $obj = eval { $self->decode_response()->($res) };
        confess("decode_response failed: $@") if $@;

        $self->call_trigger( 'response_decoded', { req => $req, res => $res, decoded => $obj, conf => \%conf } );

        $self->stash( $stashkey . '.get' => $obj );
    }
    elsif ( $res->code == 404 ) {

        $self->call_trigger( 'stash_removed', { stash => $stashkey, conf => \%conf } );

        # $self->stash->{ $stashkey . '.get' };
        delete $self->stash->{ $stashkey . '.id' };
        delete $self->stash->{ $stashkey . '.url' };
        delete $self->stash->{$stashkey};

    }
    else {
        confess 'response code ' . $res->code . ' is not valid for rest_reload';
    }

    return $obj;
}

sub rest_reload_list {
    my $self     = shift;
    my $stashkey = shift;

    my %conf = @_;

    my $code = exists $conf{code} ? $conf{code} : 200;
    $conf{code} = $code;

    my @headers = ( @{ $self->fixed_headers() }, @{ $conf{headers} || [] } );
    my $item_url = $self->stash->{ $stashkey . '.list-url' };

    confess "can't stash $stashkey.list-url is not valid" unless $item_url;

    my $prepare_request =
      exists $self->stash->{ $stashkey . '.prepare_request' }
      ? $self->stash->{ $stashkey . '.prepare_request' }
      : undef;
    confess 'prepare_request must be a coderef'
      if $prepare_request && ref $prepare_request ne 'CODE';

    my $req = GET $item_url, @headers;
    $prepare_request->($req) if $prepare_request;

    $self->call_trigger( 'process_request', { req => $req, conf => \%conf } );

    my $res = $self->do_request()->($req);

    $self->call_trigger( 'process_response', { req => $req, res => $res, conf => \%conf } );

    confess 'request code diverge expected' if $code != $res->code;

    $self->call_trigger( 'process_response_success', { req => $req, res => $res, conf => \%conf } );

    my $obj;
    if ( $res->code == 200 ) {
        my $obj = eval { $self->decode_response()->($res) };
        confess("decode_response failed: $@") if $@;

        $self->call_trigger( 'response_decoded', { req => $req, res => $res, decoded => $obj, conf => \%conf } );

        $self->stash( $stashkey . '.list' => $obj );
    }
    else {
        confess 'response code ' . $res->code . ' is not valid for rest_reload';
    }

    return $obj;
}

sub stash_ctx {
    my ( $self, $staname, $sub ) = @_;

    $self->call_trigger( 'before_stash_ctx', { stash => $staname } );

    my @ret = $sub->( $self->stash->{$staname} );

    $self->call_trigger( 'after_stash_ctx', { stash => $staname, results => \@ret } );
    return @ret;
}

1;

__END__