File Coverage

blib/lib/Test2/Tools/HTTP.pm

Criterion	Covered	Total	%
statement	228	247	92.3
branch	51	62	82.2
condition	16	24	66.6
subroutine	54	70	77.1
pod	31	31	100.0
total	380	434	87.5

package Test2::Tools::HTTP;

use strict;
use warnings;
use 5.008001;
use LWP::UserAgent;
use parent qw( Exporter );
use Test2::API qw( context );
use Test2::Compare;
use Test2::Compare::Wildcard;
use Test2::Compare::Custom;
use Test2::Tools::HTTP::UA;
use Test2::Tools::HTTP::Apps;
use Test2::Tools::HTTP::Tx;
use URI;
use Carp ();

our %EXPORT_TAGS = (
  short => [qw(
    app_add req ua res code message content content_type charset content_length content_length_ok location location_uri tx headers header
  )],
);

our @EXPORT    = qw(
  http_request http_ua http_base_url psgi_app_add psgi_app_del http_response http_code http_message http_content http_tx http_is_success
  http_is_info http_is_success http_is_redirect http_is_error http_is_client_error http_is_server_error
  http_isnt_info http_isnt_success http_isnt_redirect http_isnt_error http_isnt_client_error http_isnt_server_error
  http_content_type http_content_type_charset http_content_length http_content_length_ok http_location http_location_uri
  http_headers http_header
  psgi_app_guard
);

our @EXPORT_OK = (
  @{ $EXPORT_TAGS{'short'} },
);

*ua      = \&http_ua;
*req     = \&http_request;
*res     = \&http_response;
*app_add = \&psgi_app_add;
*charset = \&http_content_type_charset;

foreach my $short (qw( code message content content_type content_length content_length_ok location location_uri tx header headers ))
{
  no strict 'refs';
  *{$short} = \&{"http_$short"};
}

# ABSTRACT: Test HTTP / PSGI
our $VERSION = '0.09'; # VERSION


my $tx;
my $apps = Test2::Tools::HTTP::UA->apps;
my $ua_wrapper;

sub http_request
{
  my($req, $check, $message) = @_;

  my %options;

  if(ref $req eq 'ARRAY')
  {
    ($req, %options) = @$req;
  }

  $req = $req->clone;

  my $url = URI->new_abs($req->uri, http_base_url());

  $message ||= "@{[ $req->method ]} @{[ $url ]}";

  my $ctx = context();
  my $ok = 1;
  my @diag;
  my $connection_error = 0;

  unless($apps->uri_to_app($req->uri))
  {
    if($req->uri =~ /^\//)
    {
      $req->uri(
        URI->new_abs($req->uri, $apps->base_url),
      );
    }
  }

  http_ua(); # sets $ua_wrapper if not already
  my $res = eval { $ua_wrapper->request($req, %options) };

  if(my $error = $@)
  {
    $ok = 0;
    $connection_error = "$error";
    push @diag, "$error";
    $res = eval { $error->res };
  }

  if(defined $res)
  {
    bless($res, 'Test2::Tools::HTTP::Tx::Response'),
  }

  if($ok && defined $check)
  {
    my $delta = Test2::Compare::compare($res, $check, \&Test2::Compare::strict_convert);
    if($delta)
    {
      $ok = 0;
      push @diag, $delta->diag;
    }
  }

  $ctx->ok($ok, $message, \@diag);
  $ctx->release;

  $tx = bless {
    req              => bless($req, 'Test2::Tools::HTTP::Tx::Request'),
    res              => $res,
    ok               => $ok,
    connection_error => $connection_error,
    location         => do {
      $res
        ? $res->header('Location')
          ? URI->new_abs($res->header('Location'), $res->base)
          : undef
        : undef;
    },
  }, 'Test2::Tools::HTTP::Tx';

  $ok;
}


sub http_response (&)
{
  Test2::Compare::build(
    'Test2::Tools::HTTP::ResponseCompare',
    @_,
  );
}


sub _caller
{
  my $i = 1;
  my @caller;
  while(@caller = caller $i)
  {
    last if $caller[0] ne __PACKAGE__;
    $i++;
  }
  @caller;
}

sub _build
{
  defined(my $build = Test2::Compare::get_build()) or Carp::croak "No current build!";
  Carp::croak "'$build' is not a Test2::Tools::HTTP::ResponseCompare"
    unless $build->isa('Test2::Tools::HTTP::ResponseCompare');

  my @caller = _caller;

  my $func_name = $caller[3];
  $func_name =~ s/^.*:://;
  Carp::croak "'$func_name' should only ever be called in void context"
    if defined $caller[5];

  ($build, file => $caller[1], lines => [$caller[2]]);
}

sub _add_call
{
  my($name, $expect, $context) = @_;
  $context ||= 'scalar';
  my($build, @cmpargs) = _build;
  $build->add_call(
    $name,
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    ),
    undef,
    $context
  );
}

sub http_code ($)
{
  my($expect) = @_;
  _add_call('code', $expect);
}


sub http_message ($)
{
  my($expect) = @_;
  _add_call('message', $expect);
}


sub http_content ($)
{
  my($expect) = @_;
  my($build, @cmpargs) = _build;
  $build->add_http_check(
    sub {
      my($res) = @_;
      ($res->decoded_content || $res->content, 1);
    },
    [DREF => 'content'],
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    )
  );
}


sub _T()
{
  my @caller = _caller;
  Test2::Compare::Custom->new(
    code     => sub { $_ ? 1 : 0 },
    name     => 'TRUE',
    operator => 'TRUE()',
    file     => $caller[1],
    lines    => [$caller[2]],
  );
}

sub http_is_info         { _add_call('is_info',         _T()) }
sub http_is_success      { _add_call('is_success',      _T()) }
sub http_is_redirect     { _add_call('is_redirect',     _T()) }
sub http_is_error        { _add_call('is_error',        _T()) }
sub http_is_client_error { _add_call('is_client_error', _T()) }
sub http_is_server_error { _add_call('is_server_error', _T()) }


sub _F()
{
  my @caller = _caller;
  Test2::Compare::Custom->new(
    code     => sub { $_ ? 0 : 1 },
    name     => 'TRUE',
    operator => 'TRUE()',
    file     => $caller[1],
    lines    => [$caller[2]],
  );
}

sub http_isnt_info         { _add_call('is_info',         _F()) }
sub http_isnt_success      { _add_call('is_success',      _F()) }
sub http_isnt_redirect     { _add_call('is_redirect',     _F()) }
sub http_isnt_error        { _add_call('is_error',        _F()) }
sub http_isnt_client_error { _add_call('is_client_error', _F()) }
sub http_isnt_server_error { _add_call('is_server_error', _F()) }


sub http_headers
{
  my($expect) = @_;
  my($build, @cmpargs) = _build;
  $build->add_http_check(
    sub {
      my($res) = @_;

      my @headers = $res->flatten;
      my %headers;
      while(@headers)
      {
        my($key, $val) = splice @headers, 0, 2;
        push @{ $headers{$key} }, $val;
      }
      $_ = join ',', @{$_} for values %headers;

      (\%headers, 1);
    },
    [DREF => 'headers'],
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    ),
  );
}


sub http_header
{
  my($name, $expect) = @_;
  my($build, @cmpargs) = _build;
  $build->add_http_check(
    sub {
      my($res) = @_;
      my @values = $res->header($name);
      return (0,0) unless @values;
      if(ref($expect) eq 'ARRAY' || eval { $expect->isa('Test2::Compare::Array') })
      {
        return ([map { split /,/, $_ } @values], 1);
      }
      else
      {
        return (join(',',@values),1);
      }
    },
    [DREF => "header $name"],
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    ),
  );
}


sub http_content_type
{
  my($expect) = @_;
  my($build, @cmpargs) = _build;
  $build->add_http_check(
    sub {
      my($res) = @_;
      my $content_type = $res->content_type;
      defined $content_type
        ? ($content_type, 1)
        : ($content_type, 0);
    },
    [DREF => 'header content-type'],
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    )
  );
}

sub http_content_type_charset
{
  my($expect) = @_;
  my($build, @cmpargs) = _build;
  $build->add_http_check(
    sub {
      my($res) = @_;
      my $charset = $res->content_type_charset;
      defined $charset
        ? ($charset, 1)
        : ($charset, 0);
    },
    [DREF => 'header content-type charset'],
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    )
  );
}

# TODO: header $key => $check
# TODO: cookie $key => $check ??


sub http_content_length
{
  my($check) = @_;
  _add_call('content_length', $check);
}


sub http_content_length_ok
{
  my($build, @cmpargs) = _build;

  $build->add_http_check(
    sub {
      my($res) = @_;

      (
        $res->content_length,
        1,
        Test2::Compare::Wildcard->new(
          expect => length($res->content),
          @cmpargs,
        ),
      )
    },
    [METHOD => 'content_length'],
    undef,
  );


}


sub http_location
{
  my($expect) = @_;
  my($build, @cmpargs) = _build;
  $build->add_http_check(
    sub {
      my($res) = @_;
      my $location = $res->header('Location');
      (
        $location,
        defined $location
      )
    },
    [DEREF => "header('Location')"],
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    ),
  );
}

sub http_location_uri
{
  my($expect) = @_;
  my($build, @cmpargs) = _build;
  $build->add_http_check(
    sub {
      my($res) = @_;
      my $location = $res->header('Location');
      defined $location
        ? (URI->new_abs($location, $res->base), 1)
        : (undef, 0);
    },
    [DEREF => "header('Location')"],
    Test2::Compare::Wildcard->new(
      expect => $expect,
      @cmpargs,
    ),
  );
}


sub http_tx
{
  $tx;
}


sub http_base_url
{
  my($new) = @_;
  $apps->base_url($new);
}


sub http_ua
{
  my($new) = @_;

  if( (!defined $ua_wrapper) && !$new)
  {
    $new = LWP::UserAgent->new;
    $new->env_proxy;
    $new->cookie_jar({});
  }

  if($new)
  {
    $ua_wrapper = Test2::Tools::HTTP::UA->new($new);
    $ua_wrapper->instrument;
  }

  $ua_wrapper->ua;
}


sub psgi_app_add
{
  my($url, $app) = @_ == 1 ? (http_base_url, @_) : (@_);
  $apps->add_psgi($url, $app);
  return;
}


sub psgi_app_del
{
  my($url) = @_;
  $url ||= http_base_url;
  $apps->del_psgi($url);
  return;
}


sub psgi_app_guard
{
  my(%h) = @_ == 1 ? (http_base_url, @_) : (@_);

  Carp::croak "psgi_app_guard called in void context" unless defined wantarray;

  my %save;
  my $apps = Test2::Tools::HTTP::Apps->new;

  foreach my $url (keys %h)
  {
    my $old = $apps->uri_to_app($url) || 1;
    my $new = $h{$url};
    $save{$url} = $old;
    $apps->del_psgi($url) if ref $old;
    $apps->add_psgi($url => $new);
  }

  Test2::Tools::HTTP::Guard->new(%save);
}

package Test2::Tools::HTTP::Guard;

sub new
{
  my($class, %save) = @_;
  bless \%save, $class;
}

sub restore
{
  my($self) = @_;

  my $apps = Test2::Tools::HTTP::Apps->new;

  foreach my $url (keys %$self)
  {
    my $app = $self->{$url};
    $apps->del_psgi($url);
    $apps->add_psgi($url => $app)
      if ref $app;
  }
}

sub DESTROY
{
  my($self) = @_;
  $self->restore;
}

package Test2::Tools::HTTP::ResponseCompare;

use parent 'Test2::Compare::Object';

sub name { '' }
sub object_base { 'HTTP::Response' }

sub init
{
  my($self) = @_;
  $self->{HTTP_CHECK} ||= [];
  $self->SUPER::init();
}

sub add_http_check
{
  my($self, $cb, $id, $expect) = @_;

  push @{ $self->{HTTP_CHECK} }, [ $cb, $id, $expect ];
}

sub deltas
{
  my $self = shift;
  my @deltas = $self->SUPER::deltas(@_);
  my %params = @_;

  my ($got, $convert, $seen) = @params{qw/got convert seen/};

  foreach my $pair (@{ $self->{HTTP_CHECK} })
  {
    my($cb, $id, $check) = @$pair;

    my($val, $exists, $alt_check) = eval { $cb->($got) };
    my $error = $@;

    $check = $alt_check if defined $alt_check;

    $check = $convert->($check);

    if($error)
    {
      push @deltas => $self->delta_class->new(
        verified  => undef,
        id        => $id,
        got       => undef,
        check     => $check,
        exception => $error,
      );
    }
    else
    {
      push @deltas => $check->run(
        id      => $id,
        convert => $convert,
        seen    => $seen,
        exists  => $exists,
        $exists ? ( got => $val eq '' ? '[empty string]' : $val ) : (),
      );
    }
  }

  @deltas;
}

1;

__END__