File Coverage

lib/App/Context/HTTP.pm

Criterion	Covered	Total	%
statement	40	229	17.4
branch	10	138	7.2
condition	0	38	0.0
subroutine	9	19	47.3
pod	6	10	60.0
total	65	434	14.9

#############################################################################
## $Id: HTTP.pm 13887 2010-04-06 13:36:42Z spadkins $
#############################################################################

package App::Context::HTTP;
$VERSION = (q$Revision: 13887 $ =~ /(\d[\d\.]*)/)[0];  # VERSION numbers generated by svn

use App;
use App::Context;

@ISA = ( "App::Context" );

use App::UserAgent;
use Time::HiRes qw(gettimeofday tv_interval);
use Date::Format;

use strict;

=head1 NAME

App::Context::HTTP - context in which we are currently running

=head1 SYNOPSIS

   # ... official way to get a Context object ...
   use App;
   $context = App->context();
   $config = $context->config();   # get the configuration
   $config->dispatch_events();     # dispatch events

   # ... alternative way (used internally) ...
   use App::Context::HTTP;
   $context = App::Context::HTTP->new();

=cut

#############################################################################
# DESCRIPTION
#############################################################################

=head1 DESCRIPTION

A Context class models the environment (aka "context)
in which the current process is running.
For the App::Context::HTTP class, this models any of the
web application runtime environments which employ the HTTP protocol
and produce HTML pages as output.  This includes CGI, mod_perl, FastCGI,
etc.  The difference between these environments is not in the Context
but in the implementation of the Request and Response objects.

=cut

#############################################################################
# PROTECTED METHODS
#############################################################################

=head1 Protected Methods:

The following methods are intended to be called by subclasses of the
current class.

=cut

#############################################################################
# _init()
#############################################################################

=head2 _init()

The _init() method is called from within the standard Context constructor.

The _init() method sets debug flags.

    * Signature: $context->_init($args)
    * Param:     $args            hash{string} [in]
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage:

    $context->_init($args);

=cut

sub _init {
    &App::sub_entry if ($App::trace);
    my ($self, $args) = @_;
    $args = {} if (!defined $args);

    eval {
        $self->{user_agent} = App::UserAgent->new($self);
    };
    $self->add_message("Context::HTTP::_init(): $@") if ($@);

    &App::sub_exit() if ($App::trace);
}

sub _default_session_class {
    &App::sub_entry if ($App::trace);
    my $session_class = "App::Session::HTMLHidden";
    &App::sub_exit($session_class) if ($App::trace);
    return($session_class);
}

#############################################################################
# PROTECTED METHODS
#############################################################################

=head1 Protected Methods

These methods are considered protected because no class is ever supposed
to call them.  They may however be called by the context-specific drivers.

=cut

sub dispatch_events_begin {
    &App::sub_entry if ($App::trace);
    my ($self) = @_;
    my $events = $self->{events};
    my $request = $self->request();

    my $session_id = $request->get_session_id();
    my $session = $self->session($session_id);
    $self->set_current_session($session);

    my $request_events = $request->get_events();
    if ($request_events && $#$request_events > -1) {
        push(@$events, @$request_events);
    }
    $self->init_profiler_log();

    &App::sub_exit() if ($App::trace);
}

sub dispatch_events {
    &App::sub_entry if ($App::trace);
    my ($self) = @_;

    my ($content_length);
    my $content_description = "Unknown";

    $self->dispatch_events_begin();
    my $events = $self->{events};

    my $options  = $self->{options};
    my $app      = $options->{app} || "app";
    my $profiler = $options->{"app.Context.profiler"};
    my ($app_scope, $app_scope_id_type, $app_scope_id, $content_name);

    eval {
        my $user = $self->user();
        my $authorization = $self->authorization();
        my ($event, $service_type, $service_name, $method, $args, $return_results, $return_event_results, $event_results);
        my $results = "";
        # my $display_current_widget = 1;

        if ($#$events > -1) {
            if ($profiler) {
                $self->profile_start("event");
            }
            while ($#$events > -1) {
                $event = shift(@$events);
                ($service_type, $service_name, $method, $args, $return_event_results) = @$event;
                if ($authorization->is_authorized("/App/$service_type/$service_name/$method", $user)) {
                    $event_results = $self->call($service_type, $service_name, $method, $args);
                    if ($return_event_results) {
                        $results = $event_results;
                        $return_results = 1;
                    }
                    $user = $self->user();
                }
            }
            if ($profiler) {
                my $args_str  = (ref($args) eq "ARRAY") ? join(",", @$args) : $args;
                $app_scope    = "$service_type($service_name).$method($args_str)";
                $self->profile_stop("event");
            }
        }
        $service_type = $self->so_get("default","ctype","SessionObject");
        $service_name = $self->so_get("default","cname");

        if ($authorization->is_authorized("/App/$service_type/$service_name", $user)) {
            # do nothing
        }
        else {
            if ($self->session_object_exists("login_${app}")) {
                $service_name = "login_${app}";
            }
            else {
                $service_name = "login";
            }
        }

        $results = $self->service($service_type, $service_name) if (!$return_results);

        my $response = $self->response();
        my $ref = ref($results);
        if (!$ref || $ref eq "ARRAY" || $ref eq "HASH") {
            $app_scope = "results [$ref]";
            if ($profiler) {
                $self->update_profiler_log($app_scope, $service_name, $app_scope_id_type, $app_scope_id);
            }
            $response->content($results);
        }
        elsif ($results->isa("App::Service")) {
            ($app_scope, $app_scope_id_type, $app_scope_id, $content_name) = $results->content_description();
            $content_name ||= $service_name;
            if ($profiler) {
                $self->update_profiler_log($app_scope, $content_name, $app_scope_id_type, $app_scope_id);
            }
            $response->content($results->content());
            $response->content_type($results->content_type());
        }
        else {
            $app_scope = "$service_type($service_name).internals()";
            if ($profiler) {
                $self->update_profiler_log($app_scope, $service_name, $app_scope_id_type, $app_scope_id);
            }
            $response->content($results->internals());
        }

        if ($profiler) {
            $self->profile_start("xfer", 1);
        }
        $content_length = $self->send_response();

        if ($profiler) {
            $self->{profile_state}{app_scope} = $app_scope;
            $self->{profile_state}{content_length} = $content_length;
        }
    };
    if ($@) {
        $content_length = $self->send_error($@);
        if ($profiler) {
            $self->{profile_state}{app_scope} = "ERROR [$app_scope]: $@";
            $self->{profile_state}{content_length} = $content_length;
        }
    }

    if ($self->{options}{debug_context}) {
        print STDERR $self->dump();
    }

    $self->dispatch_events_finish();
    &App::sub_exit() if ($App::trace);
}

sub dispatch_events_finish {
    &App::sub_entry if ($App::trace);
    my ($self) = @_;
    $self->restore_default_session();
    $self->shutdown();  # assume we won't be doing anything else (this can be overridden)
    &App::sub_exit() if ($App::trace);
}

sub send_error {
    &App::sub_entry if ($App::trace);
    my ($self, $errmsg) = @_;
    my $str = <
Content-type: text/plain

-----------------------------------------------------------------------------
AN ERROR OCCURRED in App::Context::HTTP->dispatch_events()
-----------------------------------------------------------------------------
$errmsg

-----------------------------------------------------------------------------
Additional messages from earlier stages may be relevant if they exist below.
-----------------------------------------------------------------------------
$self->{messages}
EOF
    my $content_length = length($str);
    print $str;
    &App::sub_exit($content_length) if ($App::trace);
    return($content_length);
}

#############################################################################
# request()
#############################################################################

=head2 request()

    * Signature: $context->request()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage:

    $context->request();

The request() method gets the current Request being handled in the Context.

=cut

sub request {
    &App::sub_entry if ($App::trace);
    my $self = shift;

    if (! defined $self->{request}) {

        #################################################################
        # REQUEST
        #################################################################

        my $request_class = $self->get_option("request_class");
        if (!$request_class) {
            my $gateway = $ENV{GATEWAY_INTERFACE};
            # TODO: need to distinguish between PerlRun, Registry, libapreq, other
            if ($ENV{MOD_PERL}) {  # mod_perl: Registry
                $request_class = "App::Request::CGI";
            }
            elsif ($ENV{HTTP_USER_AGENT}) {  # running as CGI script?
                $request_class = "App::Request::CGI";
            }
            else {
                $request_class = "App::Request::CGI";
            }
        }

        eval {
            $self->{request} = App->new($request_class, "new", $self, $self->{options});
        };
        # ignore the failure to find a request. no request is currently available. method will return undef.
    }

    &App::sub_exit($self->{request}) if ($App::trace);
    return $self->{request};
}

#############################################################################
# send_response()
#############################################################################

=head2 send_response()

    * Signature: $context->send_response()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage:

    $context->send_response();

=cut

sub send_response {
    &App::sub_entry if ($App::trace);
    my $self = shift;

    my ($serializer, $response, $content, $content_type, $content_length, $headers);
    $response = $self->response();
    $content  = $response->content();

    # NOTE: $content will be a scalar if HTML is being returned
    if (ref($content)) {
        my $request    = $self->request();
        my $returntype = $request->get_returntype();
        $serializer = $self->serializer($returntype);
        $content = $serializer->serialize($content);
        $content_type = $serializer->serialized_content_type();
    }

    $content_type = $response->content_type() if (!$content_type);
    $content_type = "text/plain" if (!$content_type);
    $headers      = "Content-type: $content_type\n";

    if (defined $self->{headers}) {
        $headers .= $self->{headers};
        delete $self->{headers}
    }

    if ($self->{options}{gzip}) {
        my $user_agent = $self->user_agent();
        my $gzip_ok    = $user_agent->supports("http.header.accept-encoding.x-gzip");

        if ($gzip_ok) {
            $headers .= "Content-encoding: gzip\n";
            use Compress::Zlib;
            $content = Compress::Zlib::memGzip($content);
        }
    }
    $content_length = length($content);

    if ($self->{messages}) {
        my $msg = $self->{messages};
        $self->{messages} = "";
        $msg =~ s//\n/g;
        print "Content-type: text/plain\n\n", $msg, "\n";
    }
    else {
        print $headers, "\n", $content;
    }
    &App::sub_exit($content_length) if ($App::trace);
    return($content_length);
}

#############################################################################
# set_header()
#############################################################################

=head2 set_header()

    * Signature: $context->set_header()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage:

    $context->set_header();

=cut

sub set_header {
    &App::sub_entry if ($App::trace);
    my ($self, $header) = @_;
    if ($self->{headers}) {
        $self->{headers} .= $header;
    }
    else {
        $self->{headers} = $header;
    }
    &App::sub_exit() if ($App::trace);
}

#############################################################################
# user_agent()
#############################################################################

=head2 user_agent()

The user_agent() method returns a UserAgent objects which is primarily
useful to see what capabilities the user agent (browser) supports.

    * Signature: $user_agent = $context->user_agent();
    * Param:  void
    * Return: $user_agent    App::UserAgent
    * Throws:
    * Since:  0.01

    Sample Usage:

    $user_agent = $context->user_agent();

=cut

sub user_agent {
    &App::sub_entry if ($App::trace);
    my $self = shift;
    my $user_agent = $self->{user_agent};
    &App::sub_exit($user_agent) if ($App::trace);
    return($user_agent);
}

#############################################################################
# PUBLIC METHODS
#############################################################################

=head1 Public Methods:

=cut

#############################################################################
# user()
#############################################################################

=head2 user()

The user() method returns the username of the authenticated user.
The special name, "guest", refers to the unauthenticated (anonymous) user.

    * Signature: $username = $self->user();
    * Param:  void
    * Return: string
    * Throws:
    * Since:  0.01

    Sample Usage:

    $username = $context->user();

In a request/response environment, this turns out to be a convenience
method which gets the authenticated user from the current Request object.

=cut

sub user {
    &App::sub_entry if ($App::trace);
    my $self = shift;
    my $user = $self->{effective_user} || $self->{user};

    if (!$user) {
        my $options = $self->{options};
        my ($effective_user);
        my $authenticated = 0;
        if ($options->{app_auth_required}) {
            # Bypass Basic Authentication, /../..?u=username&p=password
            my $password = $self->so_get("default","p");
            $user = $self->so_get("default","u");

            if (defined $password && defined $user) {
                my $authentication = $self->authentication();
                if ( $authentication->validate_password($user, $password) ) {
                    $authenticated = 1;
                    $effective_user = $self->so_get("default","eu");
                }
            }
        }
        else {
            $user = $self->request()->user();

            my $p_pass = $self->so_get("default","p");
            my $u_user = $self->so_get("default","u");
            if (defined $p_pass && defined $u_user) {
                my $authentication = $self->authentication();
                if ( $authentication->validate_password($u_user, $p_pass) ) {
                    $authenticated = 1;
                    $user = $self->so_get("default","u");
                    $effective_user = $self->so_get("default","u");
                }
                else {
                    $user = 'guest';
                    $effective_user = 'guest';
                }
            }

            $authenticated = 1;
            $effective_user = $self->so_get("default","u");
        }

        $user = "guest" if (!$authenticated);
        $ENV{REMOTE_USER} = $user;
        $self->{user} = $user;
        if ($user && $authenticated) {
            my $switchable_users = $self->get_option("switchable_users");
            if ($switchable_users && $switchable_users =~ /\b$user\b/) {
                # check more carefully ...
                if ($switchable_users eq $user ||
                    $switchable_users =~ /:$user:/ ||
                    $switchable_users =~ /^$user:/ ||
                    $switchable_users =~ /:$user$/) {
                    if ($effective_user) {
                        $user = $effective_user;
                        $self->{effective_user} = $effective_user;
                    }
                }
            }
        }
        $self->so_set("default", "user", $user);
    }

    &App::sub_exit($user) if ($App::trace);
    return $user;
}

sub set_user {
    &App::sub_entry if ($App::trace);
    my ($self, $user) = @_;
    $self->{user} = $user;
    delete $self->{effective_user};
    &App::sub_exit() if ($App::trace);
}

1;