package Example;
use warnings; # only a foolhearty and foolish Perl programmer
use strict; # doesn't include these in their modules
use Data::Dumper; # these are useful to have these around for debugging
use Carp; # purposes, but not 100% necessary
use base 'CGI::Application::Framework'; # This absolutely must remain!
# ======================================================================
# ======================================================================
# These are used according to the needs of the logic given below.
# You'll almost definitely want to create your own Class::DBI subclass
# to handle database interactions, and if you want timeout-based
# logic then Time::HiRes is probably a good one to keep around.
# Other than that, go nuts and use what you need to use.
# ======================================================================
use Time::HiRes;
use CDBI::Example::example;
# ======================================================================
########################################################################
# This merges the values in the config file into the template
# for all of the example programs
########################################################################
sub template_pre_process {
my $self = shift;
my ($template) = @_;
# Change the internal template parameters by reference
my $template_params = $template->get_param_hash;
my $config = $self->conf->context;
foreach (keys %$config) {
unless (exists $template_params->{$_}) {
$template_params->{$_} = $config->{$_};
}
}
return $self->SUPER::template_pre_process(@_);
}
########################################################################
########################################################################
#####
##### The following subroutines are all needed by Framework.pm.
##### Your application will, at some point in time or another, crash
##### if you do not provide the subs such that they do what they're
##### supposed to do. Probably, the crash will happen very soon
##### indeed.
#####
########################################################################
########################################################################
sub _login_authenticate {
my $self = shift;
# ===============================================================
# Framework.pm expects this subroutine to return a list
# with 2 values:
#
# 1st value -- 0 or 1, 0 being failure to login-authenticate
# a user, 1 being success
# --> 1 means that both the username and
# password matched
# --> 0 means that they didn't
#
# 2nd value -- undef, or a $user object
# --> undef means that no such user could
# be found
# --> $user object means that a user with
# the given username was found
#
# The combination that these return values create is interpreted
# by Framework.pm as follows:
#
# (0, undef) --> Unknown user
# (0, $user) --> user was found, incorrect password given
# (1, $user) --> user was found, password given correct
#
# ** (1, undef) --> not possible! this will never happen **
#
# Note that you are responsible for creating a login.html
# HTML::Template file (or just plain HTML file I guess
# but that's a dumb idea) that is on the template search path
# that will provide something logically equivalent to username
# and password form fields, that you will use here. You can
# name them what you want to here; Framework.pm makes
# no assumptions regarding what they should be called.
#
# Technically, you don't even need username and password fields.
# If you can creatively figure out a way to authenticate without
# these concepts then that's up to you. Framework.pm
# doesn't depend on username and password concepts.
# ===============================================================
# ---------------------------------------------------------------
# Note that picking up the query param 'username' comes from a
# web login attempt.
# ---------------------------------------------------------------
my $user = undef;
my $username = $self->query->param('username');
($user) = CDBI::Example::example::Users->search(
username => $username
)
if length($username);
# ---------------------------------------------------------------
# Note that, in this example, _password_authenticate_user generates
# the 2-element list that is finally returned to Framework.pm
return $self->_password_authenticate_user($user);
}
sub _relogin_authenticate {
my $self = shift;
# ===============================================================
# Framework.pm expects this subroutine to return a list
# with 2 values:
#
# 1st value -- 0 or 1, 0 being failure to login-authenticate
# a user, 1 being success
# --> 1 means that both the username and
# password matched
# --> 0 means that they didn't
#
# 2nd value -- undef, or a $user object
# --> undef means that no such user could
# be found
# --> $user object means that a user with
# the given username was found
#
# The combination that these return values create is interpreted
# by Framework.pm as follows:
#
# (0, undef) --> Unknown user
# (0, $user) --> user was found, incorrect password given
# (1, $user) --> user was found, password given correct
#
# ** (1, undef) --> not possible! this will never happen **
#
# Note that you are responsible for creating a relogin.html
# HTML::Template file (or just plain HTML file I guess
# but that's a dumb idea) that is on the template search path
# that will provide something logically equivalent to a password
# form field, that you will use here. You can name them what
# you want to here; Framework.pm makes no assumptions
# regarding what they should be called.
#
# Technically, you don't even need a password field. If you can
# creatively figure out a way to authenticate without these
# concepts then that's up to you. Framework.pm doesn't
# depend on username and password concepts.
# ===============================================================
# ---------------------------------------------------------------
# Since we are reauthenticating from within the application we
# have the username (and uid) stuck within the session, so we
# retrieve it from there.
# ---------------------------------------------------------------
my $user = undef;
$user = CDBI::Example::example::Users->retrieve
(
$self->session->{uid}
);
# ---------------------------------------------------------------
# Note that, in this example, _password_authenticate_user generates
# the 2-element list that is finally returned to Framework.pm
return $self->_password_authenticate_user($user);
}
sub _login_profile {
# --------------------------------------------------
# This is a Data::FormValidate definition, needed by
# CGI::Application::Plugin::ValidateRM
#
# It is invoked from Framework.pm. The
# specifics of this should match the needs of your
# login.html form-displaying HTML::Template.
# --------------------------------------------------
return {
required => [ qw ( username password ) ],
msgs => {
any_errors => 'some_errors', # just want to set a true value here
prefix => 'err_',
},
};
# --------------------------------------------------
}
sub _relogin_profile {
# --------------------------------------------------
# This is a Data::FormValidate definition, needed by
# CGI::Application::Plugin::ValidateRM
#
# It is invoked from Framework.pm. The
# specifics of this should match the needs of your
# relogin.html form-displaying HTML::Template.
# --------------------------------------------------
return {
required => [ qw ( password ) ],
msgs => {
any_errors => 'some_errors', # just want to set a true value here
prefix => 'err_',
},
};
# --------------------------------------------------
}
sub _login_failed_errors {
my $self = shift;
my $is_login_authenticated = shift;
my $user = shift;
# ------------------------------------------------------------------
# It has already been determined that the user did not successfully
# log into the application. So, create some error messages for
# the HTML template regarding the 'login' mode to display. This
# subroutine returns $err which is a hashref to key/value pairs
# where the key is the name of the HTML::Template TMPL_VAR that
# should be populated in the event of a certain kind of error, and
# the value is the error message it should display.
# Framework.pm provides $is_login_authenticated and $user
# parameters to this subroutine so that this sub can perform
# the necessary login checks. Note that this $user is the some
# one that is created within the _login_authenticate subroutine,
# also in this package. _login_authenticate provides it to
# Framework.pm, which gives it back here. Note that
# $is_login_authenticated should always == 0. (XXX fixme -- so
# why even bother giving it to this subroutine? Note sure...)
#
# Note that this isn't the same as that the login form was not
# well-constructed. Determining what is and what is not a
# syntactically valid login form, and the generation of any
# needed error messages thereof, is handled by the aspect of
# Framework.pm that calls uses _login_profile, so make
# sure that whatever you need to do along these lines is reflected
# there.
# ------------------------------------------------------------------
my $errs = undef;
if ( $user && (!$is_login_authenticated) ) {
$errs->{'err_password'} = 'Incorrect password for this user';
} elsif ( ! $user ) {
$errs->{'err_username'} = 'Unknown user';
} else {
die "Can't happen! ";
}
$errs->{some_errors} = '1';
return $errs;
}
sub _relogin_failed_errors {
my $self = shift;
my $is_login_authenticated = shift;
my $user = shift;
# ------------------------------------------------------------------
# It has already been determined that the user did not successfully
# reauthenticate. So, create some error messages for
# the HTML template regarding the 'relogin' mode to display. This
# subroutine returns $err which is a hashref to key/value pairs
# where the key is the name of the HTML::Template TMPL_VAR that
# should be populated in the event of a certain kind of error, and
# the value is the error message it should display.
# Framework.pm provides $is_login_authenticated and $user
# parameters to this subroutine so that this sub can perform
# the necessary login checks. Note that this $user is the some
# one that is created within the _relogin_authenticate subroutine,
# also in this package. _relogin_authenticate provides it to
# Framework.pm, which gives it back here. Note that
# $is_login_authenticated should always == 0. (XXX fixme -- so
# why even bother giving it to this subroutine? Note sure...)
# ------------------------------------------------------------------
my $errs = undef;
if ( $user && (!$is_login_authenticated) ) {
$errs->{err_password}
= 'Incorrect password for this user';
} elsif ( ! $user ) {
$errs->{err_username} = 'Unknown username';
$self->log_confess("Can't happen! ");
}
$errs->{some_errors} = '1';
return $errs;
}
sub _relogin_test {
my $self = shift;
my $config = $self->conf($self->config_name)->context;
# ------------------------------------------------------------
# Do whatever you have to do to check to see if a transfer
# from run mode -to- run mode within an application is good.
# The return value that Framework.pm expects back
# should be:
#
# 1 - the relogin test has been successfully passed
# (implying no relogin authentication check)
#
# 0 - the relogin test has been failed
# (implying a relogin authentication check is forced)
#
# For example, a good candidate is to check for a "timeout".
# If the user hasn't loaded a page within the application in
# some duration of time then return 1 -- meaning that a
# reauthentication isn't necessary. If a reauthentication is
# necessary then return 0.
# ------------------------------------------------------------
my $now = &Time::HiRes::time;
my $then = $self->session->{_timestamp};
if ( ($now - $then) < $config->{'session_timeout'} ) {
# -------------------------------------------
# timeout hasn't happened, so things are good
# -------------------------------------------
return 1;
# -------------------------------------------
} else {
# --------------------------------------
# timeout has happened -- return failure
# --------------------------------------
return 0;
# --------------------------------------
}
$self->log_confess("I shouldn't be able to get here ");
}
sub _initialize_session {
my $self = shift;
my $user = shift;
# --------------------------------------------------------------------
# This code is located in this file because different subclasses of
# Framework.pm might have different session initialization needs.
# --------------------------------------------------------------------
# --------------------------------------------------------------------
# Note that the Framework.pm superclass also initializes some of
# its own session parameters, called "_session_id", "_timeout" and
# "_cgi_query". As long as you don't screw with (i.e. write to)
# these session parameters here (or anywhere else in your application)
# then you'll be okay. Well, don't delete your session either, again
# here or anywhere else in your program(s).
# --------------------------------------------------------------------
# --------------------------------------------------------------------
# Set whatever session variables make sense in your application (or
# really in your collection of applications that use this base class)
# given that a first-time successful login has just occured.
# --------------------------------------------------------------------
$self->session->{user} = $user;
$self->session->{uid} = $user->uid;
$self->session->{user_id} = $user->uid;
$self->session->{username} = $user->username;
$self->session->{fullname} = $user->fullname;
# --------------------------------------------------------------------
# ------------------------------------------------------
# nothing in particular needed in this return, so may as
# well provide a true vale
# ------------------------------------------------------
return 1;
# ------------------------------------------------------
}
sub _relogin_tmpl_params {
my $self = shift;
# -----------------------------------------------------------------
# This is used to provide TMPL_VAR parameters to the "relogin"
# form, as needed by the Framework superclass. In this case,
# the logical things to provide to the relogin form are uid and
# username; your application logic might differ. Likely you
# should keep all of this information the session composed within
# the $self object, and you probably should have populated the data
# into the session in the _initialize_session subroutine.
# -----------------------------------------------------------------
# --------------------------------------------------------------------
# The format of the return value of the subroutine should be a list,
# where each element of the list is a hash-ref, where the keys are the
# names of TMPL_VARs and the values are what value should be inserted
# in to that TMPL_VAR
#
# E.g. ( { tmpl_var_name_A => 'tmpl_var_value_A' },
# { tmpl_var_name_B => 'tmpl_var_value_B' },
# { day_of_week => 'Wednesday' },
# { city => 'Toronto' },
# { country => 'Canada' } )
# --------------------------------------------------------------------
my @pairs = ();
foreach my $key ( qw ( username ) ) {
push @pairs, { $key => $self->session->{$key} };
}
return @pairs;
}
sub _login_tmpl_params {
my $self = shift;
# ----------------------------------------------------------------
# This is used to provide TMPL_VAR parameters to the "login" form,
# as needed by the Framework superclass.
#
# Honestly, there isn't much use for this subroutine, and it's
# basically a hook in case someone ever has a need for it.
# ----------------------------------------------------------------
# --------------------------------------------------------------------
# In case you do come up with a use for this subroutine, the format of
# the return value should be a list, where each element of the list is
# a hash-ref, where the keys are the names of TMPL_VARs and the values
# are what value should be inserted in to that TMPL_VAR
#
# E.g. ( { tmpl_var_name_A => 'tmpl_var_value_A' },
# { tmpl_var_name_B => 'tmpl_var_value_B' },
# { day_of_week => 'Wednesday' },
# { city => 'Toronto' },
# { country => 'Canada' } )
# --------------------------------------------------------------------
return ();
}
########################################################################
########################################################################
#####
##### The following subroutines do not need to be provided (as named)
##### by Framework.pm. You can edit these, rename them, etc.
##### as needed.
#####
########################################################################
########################################################################
sub _password_authenticate_user {
my $self = shift;
my $user = shift;
if ( $user ) {
# ------------------------------------------------------------
# There was a user with this username or uid found, so now
# do a password check. Note that passwords should properly
# be encrypted within the database and so the password check
# should be testing some hash algorithm (e.g. Digest::MD5)
# of the query-string password parameter with the value
# stored in the database (which was hashed with the same
# technique at some earlier time)
#
# You might want to do a better test on $user to see if it is
# appropriate for your password check than what is done here.
# ------------------------------------------------------------
if ( $self->query->param('password') eq $user->password() ) {
return (1, $user); # password check good
} else {
return (0, $user); # password check failed
}
# ------------------------------------------------------------
} else {
# ----------------------------------------------------------
# No valid user was provided to this sub, so return an error
# code (0) and undef, signifying that no user was found
# ----------------------------------------------------------
return (0, undef);
# ----------------------------------------------------------
}
$self->log_confess(
"I shouldn't be able to get here!\n"
. Data::Dumper->Dump([$user],[qw(*user)])
. " "
);
}
sub make_navbar {
my $self = shift;
my %tmplvars = ();
my $url = $self->query->url(-full=>1);
$url .= $ENV{'PATH_INFO'} if $ENV{'PATH_INFO'};
$url =~ s/example_(\d+[a-z]?)/example_1/g;
$tmplvars{'EXAMPLE_1'} = $self->make_link
(
url => $url,
qs_args => {
rm => 'main_display',
}
);
$url =~ s/example_(\d+[a-z]?)/example_2a/g;
$tmplvars{'EXAMPLE_2'} = $self->make_link
(
url => $url,
qs_args => {
rm => 'main_display_mutt',
}
);
$url =~ s/example_(\d+[a-z]?)/example_3/g;
$tmplvars{'EXAMPLE_3'} = $self->make_link
(
url => $url,
qs_args => {
rm => 'navbar',
}
);
$url =~ s/example_(\d+[a-z]?)/example_4/g;
$tmplvars{'EXAMPLE_4'} = $self->make_link
(
url => $url,
qs_args => {
rm => 'main_view',
}
);
$url =~ s/example_(\d+[a-z]?)/example_5/g;
$tmplvars{'EXAMPLE_5'} = $self->make_link
(
url => $url,
qs_args => {
rm => 'show_user_table',
}
);
return $self->template->fill(\%tmplvars);
}
1;