view release on metacpan or  search on metacpan

lib/Terse.pm  view on Meta::CPAN

package Terse;
our $VERSION = '0.123456789';
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 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->_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->request->uri,
		secure => !$j->{_insecure_session},
	};

	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);

lib/Terse.pm  view on Meta::CPAN

=head2 logger

Set or Retrieve the logger for the application.

	$terse->logger($logger);
	$terse->logger->info();
	$terse->logger->err();

=cut

=head2 logError

Log and raise an error message.

	$terse->logError('this is an error message', 404);

=cut

=head2 logInfo

Log an info message.

	$terse->logInfo('this an info message');

=cut

=head2 raiseError

Raise an error message.

	$terse->raiseError('this is an error message', 404);

=cut

=head2 graft

Decode a JSON string.

	$terse->response->graft('config', "{...}");

=cut

=head2 pretty

Set JSON to pretty print mode.

	$terse->pretty(1);

=cut

=head2 serialize

Encode a perl struct as a JSON string.

	$terse->serialize({ ... });

=cut

=head2 delayed_response

Delay the response for non-blocking I/O based server streaming or long-poll Comet push technology.

	$terse->delayed_response(sub {
		$terse->response->test = 'okay';
		return $terse->response;
	});

=cut

=head1 AUTHOR

LNATION, C<< <email at lnation.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-terse at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Terse>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Terse


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Terse>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/Terse>

=item * Search CPAN

L<https://metacpan.org/release/Terse>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2022 by LNATION.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)


=cut

1; # End of Terse