view release on metacpan or  search on metacpan

lib/Crop/Server.pm  view on Meta::CPAN

	});
	(end code)
=cut

use v5.14;
use warnings;
no warnings 'experimental';

use Encode qw/ decode /;
use XML::LibXSLT;
use XML::LibXML;
use XML::Simple;
use JSON;
use CGI::Cookie;

use FindBin qw/ $RealBin /;

use Crop::Debug;
use Crop::Error qw/ all_right warn /;
use Crop::Server::Constants;
use Crop::Server::Handler;
use Crop::HTTP::Session;
use Crop::DateTime;
use Crop::Client;
use Crop::Rights;

=begin nd
Constant: HOMEPAGE
	Homepage of the web-site is always '/'
=cut
use constant {
	HOMEPAGE => '/',
};

=begin nd
Variable: our @EXPORT
	Export by default:
	
	OK - handler return status
=cut
our @EXPORT = qw/ OK PAGELESS /;

=begin nd
Variable: our %Attributes
	Attributes:

	auth      - if true an autentication is required; since true by default, you should redefine the <authenticate ( )> method
	client    - client ID
	content   - body of the response
	cwd       - current working directory
	data      - persistent data across all the handlers of an client request
	json      - JSON exemplar
	handler   - hash of registered handlers
	headers   - HTTP headers for response
	iflow     - Input flow of data (see <I ( )>)
	oflow     - Output flow of data (see <O ( )>)
	            special item named {ERROR} contains hashref of all the errors ocquired (see <Crop::Error>)
	output_t  - type of output ('XML', 'XSLT', 'JSON', and so on)
	page      - filename of output template in cwd
	redirect  - URL to redirect
	request   - client request object, <Crop::HTTP::Request> exemplar; will be Saved manually, so stable=>1
	rights    - rights granted to the client, exemplar of <Crop::Rights>
	router    - method establishes a chain of handlers calls; the reuslt of method is array of handler names
	sendfile  - exemplar of <Crop::File::Send> allowes to download file <Crop::File> from inner url (for Nginx)
	session   - exemplar of <Crop::HTTP::Session>
	tik       - start time of request as <Crop::DateTime> object; server sets a corresponding tok at done time
	user      - user object
	workqueue - array of handlers names establishes executing order
	xslt      - hash of parsed XSLT templates
	
	The 'stable' attribute means 'do not cleanup after request has done'.
=cut
our %Attributes = (
	auth      => {default => 1, stable => 1},
	client    => {mode => 'read'},
	content   => undef,
	cwd       => {stable => 1},
	data      => undef,
	json      => {stable => 1},
	handler   => {stable => 1},
	headers   => undef,
	iflow     => undef,
	oflow     => {mode => 'read'},
	output_t  => {default => 'XSLT', stable => 1},
	page      => undef,
	redirect  => undef,
	request   => {mode => 'read', stable => 1},
	rights    => {mode => 'read'},
	router    => {mode => 'write', stable => 1},  # the same all the time, altough result changes
	sendfile  => {mode => 'read/write'},
	session   => {mode => 'read', stable => 1},   # temporary hack!!! needed by $S->session->restore_param in a script
	tik       => {mode => 'read'},
	user      => undef,
	workqueue => undef,
	xslt      => {stable => 1},
);

=begin nd
Variable: our $Server
	Singlton.
	
	<Crop> 'uses' this class, so Server object must be available from outer classes by accessing directly
	without use of methods of this class.
	
	Getter is <instance ( )>.
=cut
our $Server;

=begin nd
Variable: my $Interrupted
	Signal to interrupt the Server has received.

Variable: my $AtWork
	Server at work should not be killed.
=cut
my ($Interrupted, $AtWork);

# Try the Server to be terminated correctly as possible
$SIG{TERM} = $SIG{INT} = \&interrupt;

=begin nd

lib/Crop/Server.pm  view on Meta::CPAN

		
		$self->{session}->id_client($client->id);
	}
	
	$self->{request}->id_session($session->id);
	$self->{request}->cookie_out($session->cookie);

	# parse the input flow before the dispatcher starts their work since it operate on input parameters
	$self->{iflow} = {};
	$self->{oflow} = {};
	
	# init data persistent across all the handlers in request
	$self->{data} = {};

	# parse input params
	$self->_parse_input;
	my $json;
	if (defined $self->{request}->content_t and $self->{request}->content_t eq 'application/json') {
		$json = $self->{iflow}{POSTDATA};
	} elsif (exists $self->{iflow}{json} and keys %{$self->{iflow}} == 1) {
		$json = $self->{iflow}{json};
	}
	$self->_parse_json($json) if $json;

	# Authentication
	if ($self->{auth}) {
		$self->_authenticate or warn 'AUTH: Authentication failed';
	}

	# define handlers order
	$self->{workqueue} = defined $self->{router} ? $self->{router}->($self) : ['DEFAULT'] or warn 'NOHANDLER|CRIT: No any handler match the request';
	$self->{workqueue} = [$self->{workqueue}] unless ref $self->{workqueue};  # make arrayref, so router may return handler name as a plain string

	# page could be redefined by handler
	$self->{page} = DEFAULT_TPL;
}

=begin nd
Function: interrupt ($signal)
	Handler of TERM or INT signals.
	
	Interrupt Server gracefully.

	The Apache web server sends TERM for '$ apachectl graceful' command.

	This function uses global 'my' variables instead of server attributes for cut dependency of Server constructor.
	
Parameters:
	$signal - signal
=cut
sub interrupt {
	my $signal = shift;

	warn "SERVER|NOTICE: The $signal signal received";

	$AtWork ? $Interrupted = 1 : die 'SERVER|NOTICE: Server stoped';
};

=begin nd
Method: _init_httprequest ( )
	Create <Crop::HTTP::Request> object from client data.
	
	Pure virtual method.
=cut
sub _init_httprequest { warn 'Crop::Server::_init_httprequest() must be redefined by a subclass' }

=begin nd
Method: instance ( )
	Get Singlton.

Returns:
	$Server object as an singlton.
=cut
sub instance { $Server }

=begin nd
Method: _is_json_correct ($json)
	Check incomming JSON for correctness.

	Input should consists of hashref where items are scalar either hashref.

	Tree traverse uses a loop+stack.

Returns:
	1     - is correct
	undef - otherwise
=cut
sub _is_json_correct {
	my ($self, $json) = @_;

	# 'left' contains a names of json objects of current node were not processed
	# 'node' is the current item of parsing; if left=undef, node were not processed
	my @stack = {left => undef, node => $json};

	while (my $frame = pop @stack) {
		my $node = $frame->{node};
		next unless ref $node;
		
		if (ref $node eq 'HASH') {
			# remember keys of child nodes at the begining of parsing current node
			$frame->{left} = [keys %$node] unless defined $frame->{left};

			@{$frame->{left}} or next;  # all childs is done
			my $key = pop @{$frame->{left}};

			# frame with remaining nodes goes back to the stack for a later parsing
			push @stack, $frame;

			# no info about this node, so 'left' is undef
			push @stack, {left => undef, node => $node->{$key}};
		} elsif (ref $node eq 'ARRAY') {
# 			debug 'ARRAY_AT_JSON';
		} elsif (ref $node eq 'JSON::PP::Boolean') {
			# $$node = 0 or 1; boolean type
		} else {
			return warn 'INPUT: JSON parsing error';  # json is incorrect
		}
	}

	1;
}