App-MFILE-WWW/lib/App/MFILE/WWW/Resource.pm
# *************************************************************************
# Copyright (c) 2014-2017, SUSE LLC
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
# this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# 3. Neither the name of SUSE LLC nor the names of its contributors may be
# used to endorse or promote products derived from this software without
# specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# *************************************************************************
# ------------------------
# This package defines how our web server handles the request-response
# cycle. All the "heavy lifting" is done by Web::Machine and Plack.
# ------------------------
package App::MFILE::WWW::Resource;
use strict;
use warnings;
use App::CELL qw( $CELL $log $meta $site );
use Data::Dumper;
use Encode qw( decode_utf8 encode_utf8 );
use File::Temp qw( tempfile );
use HTTP::Request::Common qw( GET PUT POST DELETE );
use JSON;
use LWP::UserAgent;
use Params::Validate qw(:all);
use Try::Tiny;
# methods/attributes not defined in this module will be inherited from:
use parent 'Web::Machine::Resource';
# user agent lookup table
our $ualt = {};
=head1 NAME
App::MFILE::WWW::Resource - HTTP request/response cycle
=head1 SYNOPSIS
In PSGI file:
use Web::Machine;
Web::Machine->new(
resource => 'App::MFILE::WWW::Resource',
)->to_app;
=head1 DESCRIPTION
This is where we override the default versions of various methods defined by
L<Web::Machine::Resource>.
=cut
=head1 METHODS
=head2 context
This method is where we store data that needs to be shared among
routines in this module.
=cut
sub context {
my $self = shift;
$self->{'context'};
}
=head2 remote_addr
=cut
sub remote_addr {
my $self = shift;
return $self->request->{'env'}->{'REMOTE_ADDR'};
}
=head2 session
=cut
sub session {
my $self = shift;
if ( @_ ) {
$self->request->{'env'}->{'psgix.session'} = shift;
}
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;
return 1;
}
# login attempt
if ( $r->method eq 'POST' and
$self->context->{'request_body'} and
$self->context->{'request_body'}->{'method'} and
$self->context->{'request_body'}->{'method'} =~ m/^LOGIN/i ) {
$log->debug( "is_authorized: Login attempt - pass it on" );
return 1;
}
# bypass login dialog?
if ( $site->MFILE_WWW_BYPASS_LOGIN_DIALOG ) {
$log->warn( "Bypassing login dialog! Using default credentials" );
#
# since the credentials are set in the configuration file, we only
# need to check them once - the result of this check is placed in
# META_LOGIN_BYPASS_STATE
#
if ( not defined $meta->META_LOGIN_BYPASS_STATE ) {
$meta->set('META_LOGIN_BYPASS_STATE', 0);
$session->{'ip_addr'} = $remote_addr;
$session->{'last_seen'} = time;
my $bypass_status = $self->validate_user_credentials( {
'nam' => $site->MFILE_WWW_DEFAULT_LOGIN_CREDENTIALS->{'nam'},
'pwd' => $site->MFILE_WWW_DEFAULT_LOGIN_CREDENTIALS->{'pwd'},
} );
if ( $bypass_status->level() eq 'OK' ) {
$meta->set('META_LOGIN_BYPASS_STATE', 1);
}
}
return $meta->META_LOGIN_BYPASS_STATE;
}
# unauthorized session
$log->debug( "is_authorized fall-through: " . $r->method . " " . $self->request->path_info );
return ( $r->method eq 'GET' ) ? 1 : 0;
}
=head2 _is_fresh
Takes a single argument, the PSGI session, which is assumed to contain a
C<last_seen> attribute containing the number of seconds since epoch when the
session was last seen.
=cut
sub _is_fresh {
my ( $session ) = validate_pos( @_, { type => HASHREF } );
return 0 unless my $last_seen = $session->{'last_seen'};
return ( time - $last_seen > $site->MFILE_WWW_SESSION_EXPIRATION_TIME )
? 0
: 1;
}
=head2 known_content_type
Looks at the 'Content-Type' header of POST requests, and generates
a "415 Unsupported Media Type" response if it is anything other than
'application/json'.
=cut
sub known_content_type {
my ( $self, $content_type ) = @_;
#$log->debug( "known_content_type: " . Dumper $content_type );
# for GET requests, we don't care about the content
return 1 if $self->request->method eq 'GET';
# some requests may not specify a Content-Type at all
return 0 if not defined $content_type;
# unfortunately, Web::Machine sometimes sends the content-type
# as a plain string, and other times as an
# HTTP::Headers::ActionPack::MediaType object
if ( ref( $content_type ) eq '' ) {
return ( $content_type =~ m/application\/json/ ) ? 1 : 0;
}
if ( ref( $content_type ) eq 'HTTP::Headers::ActionPack::MediaType' ) {
$log->debug( "Content type is a HTTP::Headers::ActionPack::MediaType object!" );
return $content_type->match( 'application/json' ) ? 1 : 0;
}
return 0;
}
=head2 malformed_request
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 .= ' });';
$r .= " node.addEventListener('error', function() {";
$r .= " m = 'module ' + moduleName + ' could not be loaded';";
$r .= " console.log(m);";
$r .= " t.innerHTML = m;";
$r .= ' });';
$r .= '},';
# path config
$r .= 'paths: {';
$r .= ' "app": "../' . $site->MFILE_APPNAME . '",'; # sibling to baseUrl
$r .= ' "QUnit": "qunit"'; # in baseUrl
$r .= '},';
# QUnit needs some coaxing to work together with RequireJS
$r .= 'shim: {';
$r .= ' "QUnit": {';
$r .= ' exports: "QUnit",';
$r .= ' init: function () {';
$r .= ' QUnit.config.autoload = false;';
$r .= ' QUnit.config.autostart = false;';
$r .= ' }';
$r .= ' }';
$r .= '},';
# default waitSeconds is just 7, which is too little for production
$r .= 'waitSeconds: 30';
# end of require.config
$r .= "});";
# initialize configuration parameters that we need on JavaScript side
$r .= 'requirejs.config({ config: {';
$r .= '\'cf\': { ';
# appName, appVersion
$r .= 'appName: \'' . $site->MFILE_APPNAME . '\',';
$r .= 'appVersion: \'' . $meta->META_MFILE_APPVERSION . '\',';
# standaloneMode (boolean; false means "derived distro mode")
$r .= 'standaloneMode: \'' . ( $meta->META_WWW_STANDALONE_MODE ? 'true' : 'false' ) . '\',';
# currentUser
$r .= "currentUser: " . ( $ce ? to_json( $ce ) : 'null' ) . ',';
$r .= "currentUserPriv: " . ( $cepriv ? "\'$cepriv\'" : 'null' ) . ',';
# loginDialog
$r .= 'loginDialogChallengeText: \'' . $site->MFILE_WWW_LOGIN_DIALOG_CHALLENGE_TEXT . '\',';
$r .= 'loginDialogMaxLengthUsername: ' . $site->MFILE_WWW_LOGIN_DIALOG_MAXLENGTH_USERNAME . ',';
$r .= 'loginDialogMaxLengthPassword: ' . $site->MFILE_WWW_LOGIN_DIALOG_MAXLENGTH_PASSWORD . ',';
# session data
$r .= 'displaySessionData: ' . ( $site->MFILE_WWW_DISPLAY_SESSION_DATA ? 'true' : 'false' ) . ',';
if ( $site->MFILE_WWW_DISPLAY_SESSION_DATA ) {
$r .= 'sessionID: \'' . $self->session_id . '\',';
$r .= 'sessionLastSeen: \'' . ( exists $self->session->{'last_seen'} ? $self->session->{'last_seen'} : 'never' ) . '\',';
}
# REST server URI
if ( defined( $site->DOCHAZKA_WWW_BACKEND_URI ) ) {
$r .= 'restURI: \'' . $site->DOCHAZKA_WWW_BACKEND_URI . '\',';
}
# dummyParam in last position so we don't have to worry about comma/no comma
$r .= 'dummyParam: null,';
# unit tests running?
$r .= "testing: " . ( $testing ? 'true' : 'false' );
$r .= '} } });';
$r .= '</script>';
return $r;
}
=head2 login_status
Once the username and password are known (either from C<process_post> via the
login AJAX request generated by the login dialog, or from the site
configuration via the MFILE_WWW_BYPASS_LOGIN_DIALOG mechanism), the
C<validate_user_credentials> method is called. That method is implemented by
the derived application, so it can validate user credentials however it likes.
The C<validate_user_credentials> method is then expected to call this method -
C<login_status> - to generate a status object from the results of the user
credentials validation.
Now, C<App::MFILE::WWW> does expect the C<validate_user_credentials> method to
provide the results of user credentials validation in a peculiar format,
hinging on the argument C<$code>, where a value of 200 indicates successful
validation and any other value indicates a failure.
=cut
sub login_status {
my ( $self, $code, $message, $body_json ) = @_;
my $status;
if ( $code == 200 ) {
$self->session->{'ip_addr'} = $self->remote_addr;
my $cu = $body_json->{'payload'}->{'emp'};
delete $cu->{'passhash'};
delete $cu->{'salt'};
$self->session->{'currentUser'} = $cu;
$self->session->{'currentUserPriv'} = $body_json->{'payload'}->{'priv'};
$self->session->{'last_seen'} = time;
$log->debug(
"Login successful, currentUser is now " .
Dumper( $body_json->{'payload'}->{'emp'} ) .
" and privilege level is " . $body_json->{'payload'}->{'priv'}
);
$status = $CELL->status_ok( 'MFILE_WWW_LOGIN_OK', payload => $body_json->{'payload'} );
} else {
$self->session({});
$log->debug( "Login unsuccessful, reset session" );
$status = $CELL->status_not_ok(
'MFILE_WWW_LOGIN_FAIL: %s',
args => [ $code ],
payload => { code => $code, message => $message },
);
}
$self->response->header( 'Content-Type' => 'application/json' );
$self->response->body( to_json( $status->expurgate ) );
return $status;
}
=head2 ua
Returns the LWP::UserAgent object obtained from the lookup table.
Creates it first if necessary.
=cut
sub ua {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::ua()" );
my $id = $self->session_id;
$log->debug( "ua: session_id is $id" );
# already in lookup table
if ( exists $ualt->{$id} ) {
$log->debug( "Session $id already has a LWP::UserAgent object" );
return $ualt->{$id};
}
# not in lookup table yet
my $tf = "";
( undef, $tf ) = tempfile();
$ualt->{$id} = LWP::UserAgent->new;
$ualt->{$id}->cookie_jar({ file => $tf });
$log->info("New user agent created with cookies in $tf");
return $ualt->{$id};
}
=head2 rest_req
Algorithm: send request to REST server, get JSON response, decode it, return
it.
Takes a single _mandatory_ parameter: a LWP::UserAgent object
Optionally takes PARAMHASH:
server => [URI OF REST SERVER] default is 'http://0:5000'
method => [HTTP METHOD TO USE] default is 'GET'
nick => [NICK FOR BASIC AUTH] optional
password => [PASSWORD FOR BASIC AUTH] optional
path => [PATH OF REST RESOURCE] default is '/'
req_body => [HASHREF] optional
Returns HASHREF containing:
hr => HTTP::Response object (stripped of the body)
body => [BODY OF HTTP RESPONSE, IF ANY]
=cut
sub rest_req {
my $self = shift;
# process arguments
my $ua = $self->ua();
die "Bad user agent object" unless ref( $ua ) eq 'LWP::UserAgent';
my %ARGS = validate( @_, {
server => { type => SCALAR, default => 'http://localhost:5000' },
method => { type => SCALAR, default => 'GET', regex => qr/^(GET|POST|PUT|DELETE)$/ },
nick => { type => SCALAR, optional => 1 },
password => { type => SCALAR, default => '' },
path => { type => SCALAR, default => '/' },
req_body => { type => HASHREF, optional => 1 },
} );
$ARGS{'path'} =~ s/^\/*/\//;
my $r;
{
no strict 'refs';
$r = &{ $ARGS{'method'} }( $ARGS{'server'} . encode_utf8( $ARGS{'path'} ),
Accept => 'application/json' );
}
if ( $ARGS{'nick'} ) {
$r->authorization_basic( $ARGS{'nick'}, $ARGS{'password'} );
}
if ( $ARGS{'method'} =~ m/^(POST|PUT)$/ ) {
$r->header( 'Content-Type' => 'application/json' );
if ( my $body = $ARGS{'req_body'} ) {
my $tmpvar = JSON->new->utf8(0)->encode( $body );
$r->content( encode_utf8( $tmpvar ) );
}
}
# request is ready - send it and get response
my $response = $ua->request( $r );
# process response
my $body_json = $response->decoded_content;
$log->debug( "rest_req: decoded JSON body " . Dumper $body_json );
$response->content('');
my $body;
try {
$body = JSON->new->decode( $body_json );
} catch {
$body = { 'code' => $body, 'text' => $body };
};
return {
hr => $response,
body => $body
};
}
1;