view release on metacpan or  search on metacpan

lib/App/MFILE/HTTP.pm  view on Meta::CPAN

=head1 NAME

App::MFILE::HTTP - general REST request forwarder for MFILE-based clients



=head1 SYNOPSIS

    use App::MFILE::HTTP qw( rest_req );



=head1 DESCRIPTION

Module where C<rest_req> and other shared code resides.



=head1 EXPORTS

=cut

our @EXPORT_OK = qw(
    rest_req
    _is_authorized
);



=head1 FUNCTIONS


=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 {

    # process arguments
    my $ua = shift;
    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
    };
}


=head2 _is_authorized

This function does the actual work for C<is_authorized> in the Dispatch.pm
module of an C<App::MFILE::WWW>-based application.

This function belongs in Dispatch.pm - it is here only to prevent code
duplication.

=cut

sub _is_authorized {

lib/App/MFILE/HTTP.pm  view on Meta::CPAN

    my $r = $self->request;
    #my $session = $r->{'env'}->{'psgix.session'};
    my $session = $self->session;
    #my $remote_addr = $r->{'env'}->{'REMOTE_ADDR'};
    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;
    }

    # login bypass
    $meta->set('META_LOGIN_BYPASS_STATE', 0) if not defined $meta->META_LOGIN_BYPASS_STATE;
    if ( $site->MFILE_WWW_BYPASS_LOGIN_DIALOG and not $meta->META_LOGIN_BYPASS_STATE ) {
        $log->notice("Bypassing login dialog! Using default credentials");
        $session->{'ip_addr'} = $remote_addr;
        $session->{'last_seen'} = time;
        my $bypass_result = $self->_login_dialog( {
            'nam' => $site->MFILE_WWW_DEFAULT_LOGIN_CREDENTIALS->{'nam'},
            'pwd' => $site->MFILE_WWW_DEFAULT_LOGIN_CREDENTIALS->{'pwd'},
        } );
        $meta->set('META_LOGIN_BYPASS_STATE', 1);
        return $bypass_result;
    }

    # 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;
}


1;