File Coverage

blib/lib/Test2/Thunderhorse.pm

Criterion	Covered	Total	%
statement	112	119	94.1
branch	18	22	81.8
condition	6	16	37.5
subroutine	17	17	100.0
pod	7	7	100.0
total	160	181	88.4

package Test2::Thunderhorse;
$Test2::Thunderhorse::VERSION = '0.102';
use v5.40;

use Test2::API qw(context);
use PAGI::Test::Client;
use Carp qw(croak);

use Exporter 'import';

our @EXPORT = qw(
	pagi_run
	http
	http_status_is
	http_header_is
	http_text_is
	websocket
	sse
);

die 'Error: Test2::Thunderhorse loaded in a PAGI environment'
	if ($ENV{PAGI_ENV} // 'test') ne 'test';
$ENV{PAGI_ENV} = 'test';

our $THIS_CLIENT;
my $LAST_HTTP;
my $LAST_WS;
my $LAST_SSE;

sub _build_client ($app, %args)
{
	return $THIS_CLIENT if defined $THIS_CLIENT;

	if (ref $app eq 'ARRAY') {
		%args = ($app->@[1, $app->$#*], app => $app->[0]->run, %args);
	}
	elsif (ref $app eq 'HASH') {
		%args = ($app->%*, %args);
	}
	else {
		$args{app} = $app->run;
	}

	$args{raise_app_exceptions} = true
		unless exists $args{raise_app_exceptions};

	return PAGI::Test::Client->new(%args);
}

sub pagi_run ($app, $code)
{
	my $client = _build_client($app, lifespan => true);
	local $THIS_CLIENT = $client;

	$client->start;
	$code->();
	$client->stop;

	return $client->state;
}

sub _http ($app, $http_request, %args)
{
	# Extract method and path
	my $method = lc $http_request->method;
	my $path = $http_request->uri->path_query;

	# Extract headers
	my %headers;
	$http_request->headers->scan(
		sub ($key, $value) {
			push $headers{$key}->@*, $value;
		}
	);

	$args{headers} = \%headers
		if %headers;

	# Extract body for POST/PUT/PATCH
	my $content = $http_request->content;
	$args{body} = $content
		if length $content // '';

	$LAST_HTTP = _build_client($app)->$method($path, %args);

	return $LAST_HTTP;
}

sub http (@args)
{
	return $LAST_HTTP // croak 'no last http in Test2::Thunderhorse'
		if @args == 0;

	return _http @args;
}

sub http_status_is ($expected)
{
	my $ctx = context();

	my $got = $LAST_HTTP->status;
	my $pass = $got == $expected;

	$ctx->ok($pass, 'status ok', ["expected: $expected", "got: $got"]);

	$ctx->release;
	return $pass;
}

sub http_text_is ($expected)
{
	my $ctx = context();

	my $got = $LAST_HTTP->text // '';
	my $pass = $got eq $expected;

	$ctx->ok($pass, 'body ok', ["expected: $expected", "got: $got"]);

	$ctx->release;
	return $pass;
}

sub http_header_is ($header, $expected)
{
	my $ctx = context();

	my $got = $LAST_HTTP->header($header);
	my $pass = defined($got) && defined($expected) && $got eq $expected;

	$ctx->ok($pass, "$header header ok", ["expected: $expected", "got: $got"]);

	$ctx->release;
	return $pass;
}

sub _websocket ($app, $path, @args)
{
	$LAST_WS = _build_client($app)->websocket($path, @args);

	if ($LAST_WS->is_closed) {
		my $ctx = context();
		$ctx->fail("Connecting to websocket $path failed");
		$ctx->release;
	}

	return $LAST_WS;
}

sub websocket (@args)
{
	return $LAST_WS // croak 'no last websocket in Test2::Thunderhorse'
		if @args == 0;

	return _websocket @args;
}

sub _sse ($app, $path, @args)
{
	$LAST_SSE = _build_client($app)->sse($path, @args);

	if ($LAST_SSE->is_closed) {
		my $ctx = context();
		$ctx->fail("Connecting to sse $path failed");
		$ctx->release;
	}

	return $LAST_SSE;
}

sub sse (@args)
{
	return $LAST_SSE // croak 'no last sse in Test2::Thunderhorse'
		if @args == 0;

	return _sse @args;
}

1;

__END__