view release on metacpan or  search on metacpan

lib/App/Dochazka/WWW/Dispatch.pm  view on Meta::CPAN

use warnings;

use App::CELL qw( $CELL $log $meta $site );
use Data::Dumper;
use JSON;
use Params::Validate qw(:all);
use Try::Tiny;

# methods/attributes not defined in this module will be inherited from:
use parent 'App::MFILE::WWW::Resource';



=head1 NAME

App::MFILE::WWW::Dispatch - app dispatch stub



=head1 SYNOPSIS

TBD



=head1 DESCRIPTION

This is where we override the default version of the is_authorized method
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

POST requests are assumed to be AJAX calls. Their entity bodies must be valid
JSON with the following simple structure:

    { method: HTTP_METHOD, path: RESOURCE, body: BODY_JSON }

where HTTP_METHOD is any HTTP method accepted by the REST server, RESOURCE is a
valid path to a REST server resource, and BODY_JSON is the content body to be
sent in the HTTP request to the REST server. Provided the request is properly
authorized and the body is well-formed, the request is forwarded to the REST
server via the L<App::MFILE> package's C<rest_req> routine and the REST
server's response is sent back to the user's browser, where it is processed by
the JavaScript code.

In derived-distro mode, this structure is expected to be translated into a
"real" HTTP request, to be forwarded via the LWP::UserAgent object stored in
the session data. The status object received in the response is then passed
back to the JavaScript side.

There is one special case: the POST request from the login dialog looks like this:

    { method: "LOGIN", path: "login", body: { nam: "foo", pwd: "bar" } }

Login requests receive special handling.

=cut

sub process_post {
    my $self = shift;
    $log->debug( "Entering " . __PACKAGE__ . "::process_post()" );

    my $r = $self->request;
    my $session = $self->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, $path, $body );

    if ( exists $ajax->{'method'} ) {
        $method = $ajax->{'method'};
    } else {
        $log->crit( 'POST request received, but missing mandatory attribute "method" - ' .
                    'here is the entire request body: ' . Dumper( $ajax ) );
        return 0;
    }
    if ( exists $ajax->{'path'} and $ajax->{'path'} ) {
        $path = $ajax->{'path'};
    } else {
        $log->crit( 'POST request received, but missing mandatory attribute "path" - ' .
                    'here is the entire request body: ' . Dumper( $ajax ) );
        return 0;
    }
    $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;
    }

    # two possibilities: login/logout attempt or normal AJAX call
    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 );
        }
    }

    # - normal AJAX call
    $log->debug( "Calling rest_req $method $path on session ID " . $self->session_id );
    $session->{'last_seen'} = time;
    my $rr = $self->rest_req( {