view release on metacpan or  search on metacpan

lib/App/MFILE/WWW/Resource.pm  view on Meta::CPAN

    return $self->request->{'env'}->{'psgix.session'};
}


=head2 session_id

=cut

sub session_id {
    my $self = shift;
    return $self->request->{'env'}->{'psgix.session.options'}->{'id'};
}


=head2 service_available

This is the first method called on every incoming request.

=cut

sub service_available {
    my $self = shift;
    $log->debug( "Entering " . __PACKAGE__ . "::service_available()" );
    $log->info( "Incoming " . $self->request->method . " request for " . $self->request->path_info );
    $self->{'context'} = {};
    return 1;
}


=head2 content_types_provided

For GET requests, this is where we add our HTML body to the HTTP response.

=cut
 
sub content_types_provided { 
    [ { 'text/html' => '_render_response_html' }, ] 
}

sub _render_response_html { 
    my ( $self ) = @_;
    $log->debug( "Entering " . __PACKAGE__ . "::_render_response_html" );

    my $r = $self->request;
    my $session = $r->{'env'}->{'psgix.session'};
    my $ce = $session->{'currentUser'};
    my $cepriv = $session->{'currentUserPriv'};
    my $entity;
    if ( $r->path_info =~ m/test/i ) {
        $log->debug( "Running unit tests" );
        $entity = $self->test_html();
    } else {
        $log->debug( "Running the app" );
        $entity = $self->main_html( $ce, $cepriv );
    }
    return $entity;
}



=head2 charsets_provided

This method causes L<Web::Machine> to encode the response body in UTF-8. 

=cut

sub charsets_provided { 
    [ 'utf-8' ]; 
}



=head2 default_charset

Really use UTF-8 all the time.

=cut

sub default_charset { 
    'utf-8'; 
}



=head2 allowed_methods

Determines which HTTP methods we recognize.

=cut

sub allowed_methods {
    [ 'GET', 'POST', ]; 
}



=head2 uri_too_long

Is the URI too long?

=cut

sub uri_too_long {
    my ( $self, $uri ) = @_;

    ( length $uri > $site->MFILE_URI_MAX_LENGTH )
        ? 1
        : 0;
}


=head2 is_authorized

Since all requests go through this function at a fairly early stage, we
leverage it to validate the session.

=cut

sub is_authorized {
    my ( $self ) = @_;

    $log->debug( "Entering " . __PACKAGE__ . "::is_authorized()" );

    my $r = $self->request;
    my $session = $self->session;
    my $remote_addr = $self->remote_addr;
    my $ce;

    #$log->debug( "Environment is " . Dumper( $r->{'env'} ) );
    $log->debug( "Session is " . Dumper( $session ) );

    # authorized session
    if ( $ce = $session->{'currentUser'} and
         $session->{'ip_addr'} and
         $session->{'ip_addr'} eq $remote_addr and
         _is_fresh( $session ) )
    {
        $log->debug( "is_authorized: Authorized session, employee " . $ce->{'nick'} );
        $session->{'last_seen'} = time;

lib/App/MFILE/WWW/Resource.pm  view on Meta::CPAN

This test examines the request body. It can either be empty or contain
valid JSON; otherwise, a '400 Malformed Request' response is returned.
If it contains valid JSON, it is converted into a Perl hashref and 
stored in the 'request_body' attribute of the context.

=cut

sub malformed_request {
    my ( $self ) = @_;
    
    # get the request body, which is UTF-8 ENCODED, so we decode it
    # into a normal Perl scalar
    my $body = decode_utf8( $self->request->content );

    return 0 if not defined $body or $body eq '';
    return 0 if defined $self->context and exists $self->context->{'request_body'};

    $log->debug( "malformed_request: incoming content body ->$body<-" );

    # there is a request body -- attempt to convert it
    my $result = 0;
    try {
        $self->context->{'request_body'} = JSON->new->utf8(0)->decode( $body );
    } 
    catch {
        $log->error( "Caught JSON error: $_" );
        $result = 1;
    };

    if ( $result == 0 ) {
        $log->debug( "malformed_request: body after JSON decode " . 
            ( ( $self->context->{'request_body'}->{'method'} eq 'LOGIN' ) 
                ? 'login/logout request' 
                : Dumper $self->context->{'request_body'} ) );
    }

    return $result;
}


=head3 main_html

Takes the session object and returns HTML string to be displayed in the user's
browser.

FIXME: might be worth spinning this off into a separate module.

=cut

sub main_html {
    my ( $self, $ce, $cepriv ) = @_;
    $log->debug( "Entering " . __PACKAGE__ . "::main_html" );

    $cepriv = '' unless defined( $cepriv );
    $log->debug( "Entering " . __PACKAGE__ . "::main_html() with \$ce " .
                 Dumper($ce) . " and \$cepriv " . $cepriv );

    my $r = '<!DOCTYPE html>';
    $r .= '<html>';
    $r .= '<head>';
    $r .= '<meta charset="utf-8">';
#    $r .= '<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate">';
#    $r .= '<meta http-equiv="Pragma" content="no-cache">';
#    $r .= '<meta http-equiv="Expires" content="0">';
    $r .= "<title>App::MFILE::WWW " . $meta->META_MFILE_APPVERSION . "</title>";
    $r .= '<link rel="stylesheet" type="text/css" href="/css/start.css" />';

    # Bring in RequireJS with testing == 0 (false)
    $r .= $self->_require_js(0, $ce, $cepriv);

    $r .= '</head>';
    $r .= '<body>';
    $r .= '<div id="myLoadProgress" class="loadProgress">Loading RequireJS...</div>';

    # Start the main app logic
    $r .= '<script>require([\'main\']);</script>';

    $r .= '</body>';
    $r .= '</html>';
    return $r;
}


=head3 test_html

Generate html for running (core and app) unit tests. The following JS files are
run (in this order):

=over

=item test.js (in mfile-www core)

=item test.js (in app, e.g. dochazka-www)

=item test-go.js (in mfile-www core)

=back

=cut

sub test_html {
    my ( $self ) = @_;
    $log->debug( "Entering " . __PACKAGE__ . "::test_html" );

    my $r = '';
    
    $r = '<!DOCTYPE html>';
    $r .= '<html>';
    $r .= '<head>';
    $r .= '<meta charset="utf-8">';
    $r .= '<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate">';
    $r .= '<meta http-equiv="Pragma" content="no-cache">';
    $r .= '<meta http-equiv="Expires" content="0">';
    $r .= "<title>App::MFILE::WWW " . $meta->META_MFILE_APPVERSION . " (Unit testing)</title>";
    $r .= '<link rel="stylesheet" type="text/css" href="/css/qunit.css" />';

    # Bring in RequireJS with testing == 1 (true)
    $r .= $self->_require_js(1);

    $r .= '</head><body>';
    $r .= '<div id="myLoadProgress" class="loadProgress">Loading RequireJS...</div>';
    $r .= '<div id="qunit"></div>';
    $r .= '<div id="qunit-fixture"></div>';

    # Run unit tests; see:
    # - test.js (in mfile-www core)
    # - app/test.js (in app; e.g. dochazka-www
    # - test-go.js (in mfile-www core)
    $r .= '<script>require([\'test\', \'app/test\', \'test-go\']);</script>';

    $r .= '</body></html>';
    return $r;
}


# HTML necessary for RequireJS
sub _require_js {
    my ( $self, $testing, $ce, $cepriv ) = @_;

    my $r = '';

    $r .= "<script src='" . $site->MFILE_WWW_JS_REQUIREJS . "'></script>";

    $r .= '<script>';

    # configure RequireJS
    $r .= 'require.config({';

    # baseUrl is where we have all our JavaScript files
    $r .= 'baseUrl: "' . $site->MFILE_WWW_REQUIREJS_BASEURL . '",';

    # map 'jquery' module to 'jquery-private.js'
    # (of course, the real 'jquery.js' must be present in 'js/')
    $r .= 'map: {';
    $r .= "    '*': { 'jquery': 'jquery-private' },";
    $r .= "    'jquery-private': { 'jquery': 'jquery' }";
    $r .= '},';

    # callbacks for showing module loading progress
    $r .= 'onNodeCreated: function(node, config, moduleName, url) {';
    $r .= "    var t = document.getElementById('myLoadProgress'),";
    $r .= "        m = '';";
    $r .= "    m = 'module ' + moduleName + ' is about to be loaded';";
    $r .= "    console.log(m);";
    $r .= "    t.innerHTML = m;";
    $r .= "    node.addEventListener('load', function() {";
    $r .= "        m = 'module ' + moduleName + ' has been loaded';";
    $r .= "        console.log(m);";
    $r .= "        t.innerHTML = m;";
    $r .= '    });';