File Coverage

blib/lib/Terse.pm

Criterion	Covered	Total	%
statement	190	276	68.8
branch	85	150	56.6
condition	47	98	47.9
subroutine	31	38	81.5
pod	9	11	81.8
total	362	573	63.1

package Terse;
our $VERSION = '0.19';
use 5.006;
use strict;
use warnings;
no warnings 'redefine';
use Plack::Request;
use Plack::Response;
use Cpanel::JSON::XS;
use Scalar::Util qw/reftype/;
use Time::HiRes qw(gettimeofday);
use Terse::WebSocket;
use Want qw/want/;
use Digest::SHA;
use URI;
use Struct::WOP qw/all/ => { type => ['UTF-8'], destruct => 1 };

our ($JSON, %PRIVATE);
BEGIN {
	$JSON = Cpanel::JSON::XS->new->utf8->canonical(1)->allow_blessed->convert_blessed;
	%PRIVATE = (
		map { $_ => 1 }
		qw/new run logger logInfo logError websocket delayed_response build_terse content_type raiseError graft pretty serialize DESTROY TO_JSON AUTOLOAD to_app/
	);
}

sub new {
	my ($pkg, %args) = @_;

	$pkg = ref $pkg if ref $pkg;

	if (delete $args{private}) {
		for my $key (keys %args) {
			if ($key !~ m/^_/) {
	       			$args{"_$key"} = delete $args{$key};
			}
		}
	}

	return bless \%args, $pkg;
}

sub run {
	my ($pkg, %args) = @_;

	my $j = $pkg->new(
		private => 1,
		login => 'login',
		logout => 'logout',
		auth => 'auth',
		insecure_session => 0,
		content_type => 'application/json',
		request_class => 'Plack::Request',
		websocket_class => 'Terse::WebSocket',
		sock => 'psgix.io',
		stream_check => 'psgi.streaming',
		favicon => 'favicon.ico',
		%args
	);

	$j->headers = {};

	$j->_build_terse();

	$j->request = $j->{_request_class}->new($args{plack_env});
	$j->response = $pkg->new(
		authenticated => \0,
		error => \0,
		errors => [],
	);

	if ($j->request->env->{PATH_INFO} =~ m/favicon.ico$/) {
		return [500, [], []] unless -f $j->_favicon;
		open my $fh, '<', $j->_favicon;
		my $favicon = do { local $/; <$fh> };
		close $fh;
		return [200, ['Content-Type', 'image/vnd.microsoft.icon'], [$favicon] ];
	}

	my $content_type = $j->request->content_type;
	if ($content_type && $content_type =~ m/application\/json/) {
		$j->graft('params', $j->request->raw_body || "{}");
	} else {
		$j->params = {%{$j->request->parameters || {}}};
	}

	unless ((reftype($j->params) || "") eq 'HASH') {
		$j->response->raiseError('Invalid parameters', 400);
		return $j->_response($j->response);
	}

	$j->sid = $j->request->cookies->{sid};

	unless ($j->sid) {
		my $h = Digest::SHA->new(256);
		my @us = gettimeofday;
		push @us, map { $j->request->env->{$_} } grep {
			$_ =~ /^HTTP(?:_|$)/;
		} keys %{ $j->request->env };
		$h->add(@us);
		$j->sid = $h->hexdigest;
	}

	$j->sid = {
		value => $j->is_logout ? "" : $j->sid,
		path  => $j->{_sid_path} || $j->{_root_path} || "/",
		secure => !$j->{_insecure_session},
		samesite => 'none'
	};

	my $auth = $j->{_auth};

	my ($session) = $j->_dispatch($auth, $pkg->new());

	my $req = $j->params->req;
	$req =~ /^([a-z][0-9a-zA-Z_]{1,31})$/ && do { $req = $1 // '' } if $req;
	$req = $j->{_application}->preprocess_req($req, $j) if $j->{_application}->can('preprocess_req');
	if (!$req || !$session || $PRIVATE{$req}) {
		$j->response->raiseError('Invalid request', 400);
		return $j->_response($j->response);
	}

	$j->req = $req;
	$j->response->authenticated = \1;
	$j->session = $session;

	$j->sid->expires = (ref $j->session && $j->session->expires) || (time + 24 * 60 * 60)
		if (!$j->sid->expires);

	($j->is_login, $j->is_logout) = (
		$j->{_login} eq $req,
		$j->{_logout} eq $req
	);

	my ($out) = $j->_dispatch($req);

	return $j->_response($j->response) if $j->response->error;

	$j->session = $out if ( $j->is_login || $j->is_logout );

	($j->session) = $j->_dispatch($auth, $j->session)  if $j->response->authenticated;

	if ((!$j->response->authenticated || !$j->session) && !($j->is_login || $j->is_logout)) {
		$j->response->raiseError('Unauthenticated during the request', 400);
		return $j->_response($j->response);
	}

	return $j->_response($j->response, $j->sid, $j->content_type);
}

sub to_app {
	my ($self, $new, $run) = @_;
	my $app = $self->new($new ? %{ $new } : ());
	return sub {
		my ($env) = (shift);
		Terse->run(
			plack_env => $env,
			application => $app,
			($env->{'psgix.logger'} ? (logger => $env->{'psgix.logger'}) : ()),
		);
	};
};

sub logger {
	my ($self, $logger) = @_;
	$self->{_logger} = $logger if ($logger);
	return $self->{_logger};
}

sub logError {
	my ($self, $message, $status, $no_response) = @_;
	$self->{_application}
		? $self->response->raiseError($message, $status)
		: $self->raiseError($message, $status);
	$message = { message => $message } if (!ref $message);
	$message = $self->{_application}->_logError($message, $status)
		if ($self->{_application} && $self->{_application}->can('_logError'));
	ref $self->{_logger} eq 'CODE'
		? $self->{_logger}->('error', $message)
		: $self->{_logger}->error($message)
	if $self->{_logger};
	$self->response->no_response = 1 if $no_response;
	return $self;
}

sub logInfo {
	my ($self, $message) = @_;
	$message = { message => $message } if (!ref $message);
	$message = $self->{_application}->_logInfo($message)
		if ($self->{_application} && $self->{_application}->can('_logInfo'));
	ref $self->{_logger} eq 'CODE'
		? $self->{_logger}->('info', $message)
		: $self->{_logger}->info($message)
	if $self->{_logger};
	return $self;
}

sub raiseError {
	my ($self, $message, $code) = @_;
	return $self->response->raiseError($message, $code) if $self->{_application};
	$self->{error} = \1;
	if ((reftype($message) || '') eq 'ARRAY') {
		push @{$self->{errors}}, @{$message};
	} else {
		push @{$self->{errors}}, $message;
	}
	$self->{status_code} = $code if ($code && !$self->{status_code});
	return $self;
}

sub graft {
	my ($self, $name, $json) = @_;

	unless ($json =~ m/[\{\[]/) {
		$self->{$name} = $json;
		return $self->{$name};
	}

	$self->{$name} = eval {
		$JSON->decode($json);
	};

	return 0 if $@;

	return $self->_bless_tree($self->{$name});
}

sub pretty { $_[0]->{_pretty} = 1; $_[0]; }

sub serialize {
	my ($self, $die) = @_;
	my $pretty = !!(reftype $self eq 'HASH' && $self->{_pretty});
	my $out = eval {
		$JSON->pretty($pretty)->encode(maybe_decode($self));
	};
	die $@ if ($@ && $die);
	return $out || $@;
}

sub _build_terse {
	my ($t) = @_;

	if (! $t->{_application}) {
		$t->response->raiseError('No application passed to run', 500);
		return $t->_response($t->response);
	}

	$t->{redirect} = sub {
		my ($self, $url, $response) = @_;
		$url = URI->new($url);
		$url->query_form( $url->query_form, %{$response || {}});
		$self->response->status_code = 302;
		$self->response->message = 'Found';
		$self->headers->Location = $url->as_string;
		return $self;
	};

	$t->{websocket} = sub {
		my ($self, %args) = @_;
		my $websocket = $t->{_websocket_class}->new($self);
		if (!ref $websocket) {
			$args{error}->($t, $websocket);
			return;
		}
		$t->{_delayed_response} = sub {
			my $responder = shift;
			$websocket->start($t, \%args, $responder);
		};
		return $websocket;
	} unless $t->{websocket} || !$t->{_websocket_class};

	$t->{delayed_response} = sub {
		my ($self, $response, $sid, $ct, $status) = @_;
		$sid ||= $self->sid;
		$status ||= 200;
		$ct ||= 'application/json';
		return $self->{_application}->delayed_response_handle(
			$self, $response, $sid, $ct, $status
		) if $self->{_application_has_delayed_response_handler};
		$self->{_delayed_response} = sub {
			my $responder = shift;
			my $res = $self->_build_response($sid, $ct, $status);
			$res = [splice @{$res->finalize}, 0, 2];
			my $writer = $responder->($res);
			$response = eval { $response->($writer); };
			if ($@ || $self->response->error) {
				$res->[0] = $self->response->status_code || 500;
				$self->raiseError($@) if $@;
				push @{$res}, [$self->response->serialize];
				return $responder->($res);
			}
			elsif ($response) {
				$writer->write($response->serialize);
			}
			$writer->close;
		};
		$self;
	} unless $t->{delayed_response};

	$t->{_application}->build_terse($t) if $t->{_application}->can('build_terse');
	$t->{_application_has_dispatcher} = !! $t->{_application}->can('dispatch');
	$t->{_application_has_response_handler} = !! $t->{_application}->can('response_handle');
	$t->{_application_has_delayed_response_handler} = !! $t->{_application}->can('delayed_response_handle');

	$t->{_build_response} = sub {
		my ($self, $sid, $content, $status) = @_;
		my $res = $self->request->new_response($self->response->{status_code} ||= $status);
		$res->cookies($self->cookies) if $self->cookies;
		$res->headers({%{$self->headers}}) if $self->headers;
		$res->cookies->{sid} = {%{$sid}} if $sid;
		$res->content_type($content);
		return $res;
	} unless $t->{_build_response};

	$t->{content_type} = sub {
		$_[0]->{_content_type} = $_[1] if $_[1];
		return $_[0]->{_content_type};
	} unless $t->{content_type};

	$t->{_response} = sub {
		my ($self, $response_body, $sid, $ct, $status) = @_;
		return $self->{_application}->response_handle(@_) if $self->{_application_has_response_handler};
		$ct ||= 'application/json';
		my $res = $self->{_delayed_response};
		return $res if ($res);
		$res = $self->_build_response($sid, $ct, $status || 200);
		$res->body($response_body->serialize());
		return $res->finalize;
	} unless $t->{_response};

	$t->{_dispatch} = sub {
		my ($self, $method, @params) = @_;
		my @out = $self->{_application_has_dispatcher} ? eval {
			$self->{_application}->dispatch($method, $self, @params)
		} : eval {
			unless ($self->{_application}->can($method)) {
				$self->response->raiseError('Invalid request - ' . $method, 400);
				return;
			}
			$self->{_application}->$method($self, @params);
		};
		if ($@) {
			$self->response->raiseError(['Error while dispatching the request', $@], 400);
			return;
		}
		return @out;
	} unless $t->{_dispatch};

	return $t;
}

sub _bless_tree {
	my ($self, $node) = @_;
	my $refnode = ref $node;
	return unless $refnode eq 'HASH' || $refnode eq 'ARRAY';
	if ($refnode eq 'HASH'){
		bless $node, $node->{_inherit} ? ref $self : __PACKAGE__;
		$self->_bless_tree($node->{$_}) for keys %$node;
	}
	if ($refnode eq 'ARRAY'){
		bless $node, ref $self;
		$self->_bless_tree($_) for @$node;
	}
	$node;
}

sub TO_JSON {
	my $self = shift;
	my $ref = reftype $self;
	return $self unless $ref && $ref =~ m/ARRAY|HASH/;
	return [@$self] if $ref eq 'ARRAY';
	return 'cannot stringify application object' if $self->{_application};
	my $output = {};
	my $nodebug = ! $self->{_debug};
	for(keys %$self){
		my $skip;
		$skip++ if $_ =~ /^_/ && $nodebug;
		next if $skip;
		$output->{$_} = $self->{$_};
	}
	return $output;
}

sub DESTROY {}

sub AUTOLOAD : lvalue {
	my $classname =  ref $_[0];
	my $validname = '[_a-zA-Z][\:a-zA-Z0-9_]*';
	our $AUTOLOAD =~ /^${classname}::($validname)$/;
	my $key = $1;
	die "illegal key name, must be of $validname form\n$AUTOLOAD" unless $key;
	my $miss = Want::want('REF OBJECT') ? {} : '';
	my $retval = $_[0]->{$key};
	return $retval->(@_) if (ref $retval eq 'CODE');
	die "illegal use of AUTOLOAD $classname -> $key - too many arguments" if (scalar @_ > 2);
	my $isBool = Want::want('SCALAR BOOL') && ((reftype($retval) // '') eq 'SCALAR');
	return $$retval if $isBool;
	$_[0]->{$key} = $_[1] // $retval // $miss;
	$_[0]->_bless_tree($_[0]->{$key}) if ref $_[0]->{$key} eq 'HASH' || ref $_[0]->{$key} eq 'ARRAY';
	$_[0]->{$key};
}

1;

__END__