Apache::Request::Dispatcher - dispatches requests to a sub-class of Apache::Request::Controller

gestalt documentation Contained in the gestalt distribution.

Index

Code Index:

Apache::Request::Dispatcher - dispatches requests to a sub-class of Apache::Request::Controller

SYNOPSIS

Top

    <Location /myApplication>
      SetHandler perl-script
      Perlhander Apache::Request::Dispatcher
      SetEnv DispatcherConf /path/to/file.cfg
      setEnv APP_NAME myApplication
    </Location>

DESCRIPTION

Top

Apache::Request::Dispatcher is a mod_perl handler which handles Apache HTTP requests under mod_perl, and dispatches them to a sub-class of Apache::Request::Controller (after some initial request setup has been performed).

If required, it will establish a connection to a database using the DBI, retrieve (or create) session data for this request (using Apache::Session), initialise a template processor (using the Template-Toolkit).

The Dispatcher parses the URI of the request to determine which subclass of Apache::Request::Controller to then pass control to.

Parsing of the URI occurs as follows:

APP_NAME (environment set in Apache Config) is removed from the begining of the URI, so that:

    '/myApplication/SubClass/action'

becomes: 'SubClass/action'

or

    '/myApplication/Sub/Class/action'

becomes: 'Sub/Class/action'

This is then converted to a module name, and a method name, such as:

    Apache::Request::Controller::SubClass or
    Apache::Request::Controller::Sub::Class

with action() being the method name.

It should be noted that if the SubClass or Action name contain any thing other than [A-Za-z0-9_] then the request is declined.

The dispatcher then dynamically inherits from the module name, and then calls $self->action().

The action() method of the controller is then called in an object-oriented fashion, with a dispatcher object passed in as its first parameter.

This object contains the following hash elements:

    request  => $r,        # The Apache Request Object
    dbh      => $dbh,      # The Database Connection Object
    cfg      => $cfg,      # The AppConfig object
    template => $template, # The Template Processor
    apr      => $q,        # The CGI/libapreq object
    session  => \%session  # Any session data for this user

Depending on the configuration file, 'dbh' or 'session' may be undefined if they've been turned off.

an example controller method might be written as follows:

    package Apache::Request::Controller::SubClass;
    our @ISA = qw(Apache::Request::Controller);
    use strict;
    use Apache::Const qw(:common :methods :http);

    sub action
    {
        my $self = shift;

        my $thing = getThingByID($self->{'dbh'}, $self->{'apr'}->param('thingId'));

        $self->{'request'}->status(HTTP_OK);
        $self->{'request'}->content_type('text/html');

        $self->{'template'}->process('myTemplate', {thing => $thing});
        return OK;
    }
    1;

Special Actions

__cache()

Generally, the controllers that are dispatched to will generate dynamic content, and as such the dispatcher automatically sets the browsers caching policy to not cache any content. However, if your Controller sub-class has a method called __cache() then will be used to define the caching policy. The action name is given as a parameter to the __cache() method, and based on this, the __cache() method should return 1 to allow caching, or zero to prevent it.

For exmaple, if your Controller sub-class provides 2 actions, staticContent() and dynamicContent(), then your __cache() method can control the caching policy as follows:

    sub __cache
    {
        my $action = shift;

        my $policy = { staticContent  => 1,
                       dynamicContent => 0};
        return $policy->{$action} || 0; # Default to no caching.
    }

If your Controller sub-class wants to turn off caching globally, then you can just return zero regardless of what the action name is.

__index()

If the dispatcher cannot work out which action the request is for (this happens on a URI such as '/myApplication/SubClass') then the dispatcher checkes to see if the Controller SubClass has a 'default' action by calling __index(). If this method does not exist, then the request is declined. The __index() method should return the name of the default action, such as:

    sub __index
    {
        return 'listAllItems';
    }

Template Defaults

The template processor has the following defaults defined, and may be used by all templates:

DisplayNumber()

This template variable is a reference to a subroutine which will add comma's in the right place in numbers, for exmaple:

    [% DisplayNumber(1000) %] becomes 1,000
DisplayDate()

This template variable is a reference to a subroutine which will take a time value (in the form of seconds since the epoch) and display the actual date. You may optionally specify an strftime() format:

    [% DisplayDate( CURRENT_TIME, '%a %d %B %Y' ) %]
DisplayTime()

This template variable is a reference to a subroutine which will take a time value (in the form of seconds since the epoch) and displays the time-of-day. You may optionally specify an strftime() format:

    [% DisplayTime( CURRENT_TIME, '%a %d %B %Y' ) %]
DisplayDateTime()

This template variable is a reference to a subroutine which will take a time value (in the form of seconds since the epoch) and displays the date and time of day

    [% DisplayDateTime( CURRENT_TIME ) %]
DisplayDuration()

This template variable is a reference to a subroutine which will take a number of seconds as input, and output a string of the form 'H hours, M minutes and S seconds', eg:

    Last Modified: [% DisplayDuration( CURRENT_TIME - LAST_MODIFIED %]
APP_NAME

This template variable is a string which represents the application name, as defined by the environment variable APP_NAME.

REQUEST

This template variable is an Apache2::RequestRec object, so that the template can have access to the current URI etc. Its not really meant to be used to set any outgoing headers or any thing tho, as setting up the response should really be done in the Controller.

The Configuration File

The dispatcher can be used to dispatch to multiple controllers that dont even need to belong to the same application, and each can application can have its own database connection and set of templates. This is achieved by having Apache specify which configuration file to use based on the Location of the request URI. For example:

    <Location /myApplication>
      SetHandler perl-script
      Perlhander Apache::Request::Dispatcher
      SetEnv DispatcherConf /path/to/file.cfg
      setEnv APP_NAME myApplication
    </Location>

will specify that all requests with a root-URI of /myApplication will use the configuration file as specified in the DispatcherConf environment variable, which is /path/to/file.cfg in the above example.

The contents of this configuration file are as follows:

    db_dsn="DBI:Pg:database=myApplication;host=127.0.0.1"
    db_username=apache
    db_password=apache

    templatePath="/data/myApplication/templates"

    defaultController=WelcomePage

    # If you wish to use sessions, uncomment this and make sure you have
    # created the sessions table within the database db_dsn.
    useSessions="Apache::Session::Postgres"
    sessionTable="sessions"

where db_dsn, db_username, and db_password specifies the database connection options, templatePath specifies where the templates are all stored, and defaultController specifies which controller is the default, so that if a request for '/myApplication' is recieved, it will be converted to '/myApplication/WelcomePage', which will in turn get converted to Apache::Request::Controller::WelcomePage.

At a minimum, you have to have templatePath defined. If you dont specify a default Controller, then the top-level URI will not work.

AUTHOR

Top

Bradley Kite <bradley-cpan@kitefamily.co.uk>

If you wish to email me, then please remove the '-cpan' part of my email address as anything addressed to 'bradley-cpan' is assumed to be spam and is not read.

SEE ALSO

Top

Apache::Request::Controller, DB::Table, DB::Table::Row, DBI, perl

gestalt documentation Contained in the gestalt distribution. 
package Apache::Request::Dispatcher;

use strict;
use DBI;
use Template;
use AppConfig;
#use Exception qw(:all);

use Apache::Const qw(:common :methods :http);
use POSIX qw(strftime);
use Carp qw(cluck);
use Apache::Session::Postgres;

use Data::Dumper;

# TODO: Need to change these to Apache::Request (libapreq)
use CGI;
use CGI::Cookie;

our @ISA;


# /* handler */ {{{
sub handler
{
    my $r = shift;

    # Validate the URI
    my $uri     = $r->uri;

    # The app-name is allowed to contain funny characters, so we strip it off
    # before we check its validity.
    my $relativePath = substr($uri, length($r->location) + 1); # +1 for the training slash
    if (($relativePath ne '') && ($relativePath !~ /^[A-Za-z0-9_\/]+$/))
    {
        return DECLINED;
    }

    my $self = init($r);

    # Auth Levels: none (default), mixed (anon users allowed), login (must login)
    if ($self->{'cfg'}->authLevel eq 'login')
    {
        # Force the user to login
        unless ($self->{'session'}->{'auth'}->{'username'})
        {
            my $authController = join('/', $self->{'request'}->location, $self->{'cfg'}->authController);
            $self->{'request'}->headers_out->set(Location => $authController);
            return HTTP_MOVED_TEMPORARILY;
        }
    }

    # Start parsing the URI
    my @bits = split(/\/+/, $relativePath);

    my $webPrefix = 'Apache::Request::Controller';
    my $method    = pop @bits;
    my $pkgName   = join('::', $webPrefix, @bits);

    # Prevent access to the session table.
    if ($self->{'cfg'}->useSessions && $pkgName eq "Apache::Request::Controller::" . ucfirst($self->{'cfg'}->sessionTable))
    {
        return DECLINED;
    }

    # Show the "Index" page of the given component.
    if ($pkgName eq $webPrefix)
    {
        $pkgName .= '::' . $method;
        $method   = '';
    }

    if ($pkgName eq 'Apache::Request::Controller::' || $pkgName eq 'Apache::Request::Controller')
    {
        if ($self->{'cfg'}->defaultController)
        {
            unless ($uri =~ /\/$/)
            {
                $uri .= '/';
            }
            $uri .= $self->{'cfg'}->defaultController;
            #$r->uri($uri);
            $r->headers_out->set(Location => $uri);
            return HTTP_MOVED_TEMPORARILY;
        }
    }

    if ($method =~ /^\_/)
    {
        warn("Cannot dispatch to $pkgName\-\>$method (actions cannot start with a leading underscore)");
        return DECLINED;
    }

#    my $ret = try {
        unshift @ISA, ($pkgName);
        my $return;
        eval {
            if ($method eq '')
            {
                unless ($uri =~ /\/$/)
                {
                    $uri .= '/';
                }
                if ($self->can('__index'))
                {
                    $uri .= $self->__index();
                    $r->uri($uri);
                    $r->headers_out->set(Location => $uri);
                    $return  = HTTP_MOVED_TEMPORARILY;
                }
                else
                {
                    warn("Cannot figure out the default method of $pkgName. Please write an __index() method which returns it");
                    $return = DECLINED;
                }
            }
            elsif ($self->can($method))
            {
                if ($self->can('__cache'))
                {
                    eval "\$r->no_cache((${pkgName}::__cache}(\$method) ? 0 : 1));";
                    confess($@) if ($@);
                }
                else
                {
                    $r->no_cache(1);
                }
                $return = $self->$method();
            }
            else
            {
                warn("Cannot find $pkgName->$method, declining request");
                $return = DECLINED;
            }
        };
        if ($@)
        {
            my $err = sprintf('Cannot dispatch to %s->%s (%s)',
                               $pkgName, $method, $@);
            warn($err);
            # Exception->new('other')->raise($err);
            $self->{'dbh'}->rollback;
            return HTTP_INTERNAL_SERVER_ERROR;
        }
        if (($return == OK || $return == HTTP_MOVED_TEMPORARILY) && $self->{'request'}->is_initial_req())
        {
            # We only commit if we're the "main" (initial) request  (and if every thing is OK, of course)
            $self->{'session'}->{'_mtime'} = time();
            $self->{'dbh'}->commit();
        }
        elsif ($return != OK && $return != HTTP_MOVED_TEMPORARILY)
        {
            # We roll-back any time. This is so that if the main request works but then
            # makes a sub-request which fails, then the subrequest will roll-back the main
            # requests actions too. This is because the sub-request will present some sort
            # of error to the user, leading them to think that what they just did failed.
            $self->{'dbh'}->rollback;
        }
        return $return;
#    }
#    when 'template',
#    except
#    {
#        # If a template error occurs, then the http header etc. would
#        # have already have been sent.
#        my $err = shift;
#        $err->confess;
#        $self->{'template'}->process('error.tt2'. {ERROR => $err->stringify})
#          or do { print $err->stringify };
#        return OK;
#    }
#    when 'not_found',
#    except
#    {
#        my $err = shift;
#        $err->confess;
#        return DECLINED;
#    }
#    when 'other',
#    except
#    {
#        my $err = shift;
#        $err->confess;
#        return HTTP_INTERNAL_SERVER_ERROR;
#    }
#    finally
#    {
#        my $err = shift; 
#        my $retCode = shift;

#        if ($err)
#        {
#            $self->{'dbh'}->rollback;
#        }
#        else
#        {
#            $self->{'dbh'}->commit;
#        }
#        return $retCode;
#    };
#
#    return $ret;
}
# /* handler */ }}}

# /* init */ {{{
sub init
{
    my $r = shift;

    # Do some initial setup config.

    @ISA = ();

    my $q = new CGI;

    # TODO: Perhaps cache the config files using the key ($ENV{'DispatcherConf'}) into a
    #       global hash
    my ($cfg, $dbh, $template);
    unless ($cfg)
    {
        $cfg = AppConfig->new(qw(db_dsn=s db_username=s db_password=s
                                 templatePath=s defaultController=s
                                 useSessions=s sessionTable=s
                                 session_dsn=s session_username=s session_password=s
                                 authLevel=s authController=s));
        $cfg->file($ENV{'DispatcherConf'}) || die "Could not open config: $ENV{DispatcherConf}: $!";
    }

    if ($cfg->db_dsn)
    {
        $dbh = DBI->connect($cfg->db_dsn, $cfg->db_username, $cfg->db_password,
                            {AutoCommit => 0,
                             RaiseError => 0});
        unless ($dbh)
        {
            confess(sprintf("Could not connect to database %s: %s",
                            $cfg->db_dsn,
                            $DBI::errstr));
        }
    }

    my %session;
    if ($cfg->useSessions)
    {
        my $cookies = CGI::Cookie->fetch($r) || {};
        my $cookie  = $cookies->{'session_id'};

        $cfg->sessionTable('sessions') unless ($cfg->sessionTable);
        my $opts = {Handle => $dbh, Commit => 1, TableName => $cfg->sessionTable};

        if ($cookie)
        {
            my $cookieValue = $cookie->value;
            tie %session, $cfg->useSessions, $cookieValue, $opts;
        }
        else
        {
            tie %session, $cfg->useSessions, undef, $opts;
        }
        # TODO: Add some extra stuff to the config file to determine cookie
        #       options, such as expire time.
        $cookie = $q->cookie('-name'    => 'session_id',
                             '-value'   => $session{'_session_id'},
                             #'-expires' => '+1d', Per-Session is all thats needed.
                             '-path'    => $r->location . '/',
                             '-domain'  => $r->hostname,
                             '-secure'  => 0);
        $r->headers_out->set('Set-Cookie' => $cookie->as_string);
    }

    my $templatePath = $cfg->templatePath || '/data/templates';
    $template ||= new Template(INCLUDE_PATH => $templatePath,
                               RECURSION    => 1,
                               PRE_DEFINE   => { DisplayNumber   => \&T_DisplayNumber,
                                                 DisplayDate     => \&T_DisplayDate,
                                                 DisplayTime     => \&T_DisplayTime,
                                                 DisplayDateTime => \&T_DisplayDateTime,
                                                 DisplayDuration => \&T_DisplayDuration,
                                                 REQUEST         => $r,
                                                 SESSION         => \%session,
                                                 CFG             => $cfg});
    my $self = {request  => $r,
                dbh      => $dbh,
                cfg      => $cfg,
                template => $template,
                apr      => $q,
                session  => \%session};
    bless ($self, __PACKAGE__);

    return $self;
}
# /* init */ }}}

# /* Template Display Functions */ {{{
sub T_DisplayNumber
{
    my $number = reverse(shift);
    $number =~ s/(\d\d\d)(?!$)/$1\,/g;
    return scalar(reverse($number));
}

sub T_DisplayDateTime
{
    my $time = shift;

    return strftime('%a %d %B %T %Y', gmtime($time));
}

sub T_DisplayTime
{
    my $time   = shift;
    my $format = shift || '%a %d %B %Y';

    return strftime($format, gmtime($time));
}

sub T_DisplayDate
{
    my $time   = shift;
    my $format = shift || '%a %d %B %Y';

    return strftime($format, gmtime($time));
}

sub T_DisplayDuration
{
    my $duration = shift; # number of seconds

    my @bits = ({ NAME => 'Seconds',
                  NEXT => 60},
                { NAME => 'Minutes',
                  NEXT => 60 },
                { NAME => 'Hours',
                  NEXT => '24' },
                { NAME => 'Days',
                  NEXT => 7 },
                { NAME => 'Weeks' });
    my @results;
    do
    {
        my $remainder = ($duration % $bits[0]->{'NEXT'});
        unshift @results, sprintf("%d %s", $remainder,
                                        $bits[0]->{'NAME'}) if ($remainder > 0);
        $duration -= $remainder;
        $duration /= $bits[0]->{'NEXT'};
        shift @bits;
    }
    while (defined ($bits[0]) && defined ($bits[0]->{'NEXT'}));

    return join(' ', @results);
}
# /* Template Display Functions */ }}}

1;