File Coverage

blib/lib/RapidApp/Test/Client.pm

Criterion	Covered	Total	%
statement	90	98	91.8
branch	20	28	71.4
condition	5	12	41.6
subroutine	25	29	86.2
pod	0	16	0.0
total	140	183	76.5

package RapidApp::Test::Client;

use strict;
use warnings;

# Object class for simulating RapidApp HTTP client sessions

use Moo;
use Types::Standard qw(:all);

use RapidApp;
use Scalar::Util qw(blessed);
use Time::HiRes qw(gettimeofday tv_interval);
use LWP::UserAgent;
use HTTP::Request::Common;
use JSON qw(decode_json);
use Try::Tiny;

# shorthand aliases:
sub lreq { (shift)->last_request }
sub lres { (shift)->last_response }

has 'ajax_request_headers', is => 'ro', default => sub {{
  'X-RapidApp-RequestContentType' => 'JSON',
  'X-RapidApp-VERSION'            => $RapidApp::VERSION,
  'X-Requested-With'              => 'XMLHttpRequest',
  'Content-Type'                  => 'application/x-www-form-urlencoded; charset=UTF-8',
}}, isa => HashRef;

has 'request_num',   is => 'rw', default => sub{0}, isa => Int;
has 'last_request',  is => 'rw', default => sub{undef}, isa => Maybe[InstanceOf['HTTP::Request']];
has 'last_response', is => 'rw', default => sub{undef}, isa => Maybe[InstanceOf['HTTP::Response']];
has 'last_request_started',  is => 'rw', default => sub{undef};
has 'last_request_elapsed',  is => 'rw', default => sub{undef}, isa => Maybe[Str];
has 'last_url',      is => 'rw', default => sub{undef}, isa => Maybe[Str];
has 'cookie',        is => 'rw', default => sub{undef}, isa => Maybe[Str];

# i.e. http://localhost:3000
has 'base_url', is => 'ro', isa => Maybe[Str], default => sub {undef};

has 'agent_string', is => 'ro', lazy => 1, default => sub {
  my $self = shift;
  return (ref $self);
}, isa => Str;

has 'request_caller', is => 'ro', lazy => 1, default => sub {
  my $self = shift;

  # create in a closure:
  my $ua = LWP::UserAgent->new;
	$ua->agent($self->agent_string);

  return sub {
    my $request = shift;
    return $ua->request($request);
  }
}, isa => CodeRef;

sub make_request {
  my ($self, $req) = @_;

  $self->last_request(undef);
  $self->last_response(undef);
  $self->last_request_elapsed(undef);
  $self->request_num( $self->request_num + 1 );

  $self->last_request_started([gettimeofday]);

  $req->header( Cookie => $self->cookie ) if ($self->cookie);

  my $res = $self->request_caller->( $self->last_request($req) );

  # Record the response unless the request_caller already did:
  $self->record_response( $res ) unless ($self->last_response);

  return $res;
}

sub record_response {
  my ($self, $res) = @_;
  die "last_response already defined" if ($self->last_response);
  $self->last_response( $res );
  $self->cookie( $res->header('Set-Cookie') );
  $self->last_request_elapsed(sprintf("%0.5f sec",tv_interval(
    $self->last_request_started
  )));
  return $res;
}

sub normalize_url {
  my ($self, $url) = @_;

  $url = join('',$self->base_url,$url) if (
    $self->base_url &&
    $url =~ /^\// #<-- starts with '/'
  );

  return $self->last_url($url);
}


sub get_request {
  my ($self, $url, $headers) = @_;
  $url = $self->normalize_url($url);
  my $req = GET($url);
  $req->header( %$headers ) if ($headers);
  $self->make_request($req);
}

sub post_request {
  my ($self, $url, $params, $headers) = @_;
  $url = $self->normalize_url($url);
  my $arr_arg = ref($params) eq 'HASH' ? [%$params] : $params;
  my $req = POST($url,$params);
  $req->header( %$headers ) if ($headers);
  $self->make_request($req);
}

sub last_request_is_ajax {
  my $self = shift;
  my $req = $self->last_request or return 0;
  my $req_with = $req->header('X-Requested-With');
  return $req_with && $req_with eq 'XMLHttpRequest';
}

sub last_request_type {
  my $self = shift;
  return '(none)' unless ($self->last_request);
  return $self->last_request_is_ajax ? 'Ajax' : 'Browser';
}

sub last_response_set_cookie {
  my $self = shift;
  my $res = $self->last_response or return 0;
  return $res->header('Set-Cookie');
}

sub describe_request {
  my $self = shift;
  my $req = $self->last_request or return '(no request)';

  my @list = (
    ' <r', $self->request_num,'> ',
    $self->last_request_type,
    '->', $req->method, '(\'',$req->uri->path,'\')',
  );

  # If we already have the response, include the elapsed time:
  push @list,('  [',$self->last_request_elapsed,']')
    if ($self->last_response);

  push @list, ' **set-cookie**' if ($self->last_response_set_cookie);

  return join('',@list);
}

#####################


# Simulate an Ajax POST request as if it was generated by the
# RapidApp/ExtJS JavaScript client/browser to a JSON-encoded
# resource. Decodes and returns the JSON as perl ref
sub ajax_post_decode {
  my ($self, $url, $params) = @_;
  my $res = $self->post_request($url, $params, $self->ajax_request_headers);
  return try{decode_json($res->decoded_content)} || $res->decoded_content;
}


sub ajax_get_raw {
  my ($self, $url) = @_;
  my $res = $self->get_request($url, $self->ajax_request_headers);
  return $res->decoded_content;
}


sub ajax_get_decode {
  my ($self, $url) = @_;
  my $content = $self->ajax_get_raw($url);
  return try{decode_json($content)} || $content;
}

sub browser_get_raw {
  my ($self, $url) = @_;
  my $res = $self->get_request($url);
  return $res->decoded_content;
}

sub browser_post_raw {
  my ($self, $url, $params) = @_;
  my $res = $self->post_request($url,$params);
  return $res->decoded_content;
}


1;