App-MFILE-WWW
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
lib/App/MFILE/WWW/Dispatch.pm view on Meta::CPAN
defined by L<Web::Machine::Resource>.
This module is only used in standalone mode. In derived distribution mode, the
application's dispatch module will be used, instead.
=cut
=head1 METHODS
=head2 process_post
In the standalone demo-application mode, POST requests are used to handle
login/logout requests generated by login-dialog.js.
Login requests look like this:
{ method: "LOGIN", path: "login", body: { nam: "foo", pwd: "bar" } }
and logout requests like this:
{ method: "LOGIN", path: "logout" }
In derived-distro mode, POST requests are also used to implement AJAX calls. See
the C<process_post> function in C<App::Dochazka::WWW::Dispatch> for a real
implementation.
=cut
sub process_post {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::process_post()" );
my $r = $self->request;
my $session = $r->{'env'}->{'psgix.session'};
my $ajax = $self->context->{'request_body'}; # request body (Perl string)
if ( ! $ajax ) {
$log->crit( 'POST request received, but without a body' );
return 0;
}
my $method = $ajax->{'method'};
my $path = $ajax->{'path'};
my $body = $ajax->{'body'} || {};
$log->debug( "process_post: method $method, path $path, body " . Dumper $body );
if ( ! $method or ! $path or ! $body ) {
$log->crit( 'POST request received, but missing mandatory attribute(s) - ' .
'here is the entire request body: ' . Dumper( $ajax ) );
return 0;
}
# POST is used only for login/logout ATM
if ( $method =~ m/^LOGIN/i ) {
$log->debug( "Incoming login/logout attempt" );
if ( $path =~ m/^login/i ) {
return $self->validate_user_credentials( $body );
} else {
return $self->_logout( $body );
}
}
$log->crit( "Asked to perform an AJAX call, but feature is not implemented!" );
return 0;
}
=head2 validate_user_credentials
Called from C<process_post> to process login requests (special AJAX requests)
originating from the JavaScript side (i.e. the login screen in
login-dialog.js, via login.js).
Returns a status object - OK means the login was successful; all other statuses
mean unsuccessful.
=cut
sub validate_user_credentials {
my ( $self, $body ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::validate_user_credentials()" );
my $r = $self->request;
my $session = $r->{'env'}->{'psgix.session'};
my $nick = $body->{'nam'};
my $password = $body->{'pwd'};
my $standalone = $meta->META_WWW_STANDALONE_MODE;
$log->debug( "Employee $nick login attempt" );
my ( $code, $message, $body_json );
if ( $standalone ) {
# check nam and pwd against MFILE_WWW_STANDALONE_CREDENTIALS_DATABASE
my $db = $site->MFILE_WWW_STANDALONE_CREDENTIALS_DATABASE;
$code = 401;
$message = 'Unauthorized';
for my $entry (@$db) {
if ( $nick eq $entry->{'nam'} ) {
if ( $password eq $entry->{'pwd'} ) {
$code = 200;
$message = 'OK';
$body_json = { payload =>
{
emp => { nick => $nick, eid => $entry->{'eid'} },
priv => $entry->{'priv'}
}
};
}
last;
}
}
} else {
$log->crit( "Not running in standalone mode" );
return $CELL->status_not_ok();
}
my $status = $self->login_status( $code, $message, $body_json );
$log->debug( "login_status() returned" . Dumper( $status ) );
return $status;
}
=head2 _logout
Called from C<process_post> to process logout requests (special AJAX requests)
originating from the JavaScript side.
=cut
sub _logout {
my ( $self, $body ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_logout()" );
$self->request->{'env'}->{'psgix.session'} = {};
$self->response->header( 'Content-Type' => 'application/json' );
$self->response->body( to_json( $CELL->status_ok( 'MFILE_WWW_LOGOUT_OK' )->expurgate ) );
return 1;
}
1;
view all matches for this distributionview release on metacpan - search on metacpan
( run in 0.895 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )