File Coverage

blib/lib/CGI/Session/Auth.pm

Criterion	Covered	Total	%
statement	44	118	37.2
branch	9	30	30.0
condition	3	14	21.4
subroutine	11	26	42.3
pod	8	10	80.0
total	75	198	37.8

###########################################################
# CGI::Session::Auth
# Authenticated sessions for CGI scripts
###########################################################
#
# $Id: Auth.pm 32 2007-09-02 13:04:22Z geewiz $
#

package CGI::Session::Auth;
use base qw(Exporter);

use 5.008;
use strict;
use warnings;
use Carp;
use Digest::MD5 qw( md5_hex );

our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);

our $VERSION = do { q$Revision: 32 $ =~ /Revision: (\d+)/; sprintf "1.%03d", $1; };

###########################################################
###
### general methods
###
###########################################################

###########################################################

sub new {

    ##
    ## class constructor
    ## see POD below
    ##

    my $class = shift;
    my ($params) = @_;

    $class = ref($class) if ref($class);
    # check required params
    my %classParams = (
        Session => ['CGI::Session'],
        CGI => ['CGI', 'CGI::Simple'],
    );
    foreach my $classParam (keys %classParams) {
        croak "Missing $classParam parameter" unless exists $params->{$classParam};
        croak "$classParam parameter is not a " . join(' or ', @{$classParams{$classParam}}) . " object"
           unless grep { $params->{$classParam}->isa($_) } @{$classParams{$classParam}};
    }

    my $self = {

    	#
    	# general parameters
    	#

        # parameter "Session": CGI::Session object
        session => $params->{Session},
        # parameter "CGI": CGI object
        cgi => $params->{CGI},
        # parameter "LoginVarPrefix": prefix of login form variables (default: 'log_')
        lvprefix => $params->{LoginVarPrefix} || 'log_',
        # parameter "IPAuth": enable IP address based authentication (default: 0)
        ipauth => $params->{IPAuth} || 0,
        # parameter "Log": enable logging (default: 0)
        log => $params->{Log} || 0,

		#
		# class members
		#

        # the current URL
        url => $params->{CGI}->url,
        # logged-in status
        logged_in => 0,
        # user id
        userid => '',
        # user profile data
        profile => {},
        # Log::Log4perl logger, see "log" above
		logger => undef,
    };

    bless $self, $class;

    if ( $self->{log}) {
    	require Log::Log4perl;
		$self->{logger} = Log::Log4perl->get_logger($class);
		$self->_debug("logging enabled");
    }

    return $self;
}

###########################################################

sub authenticate {

	##
    ## authenticate current visitor
	##

    my $self = shift;

    # is this already a session by an authorized user?
    if ( $self->_session->param("~logged-in") ) {
        $self->_debug("User is already logged in in this session");
        # set flag
        $self->_loggedIn(1);
        # load user profile
        my $userid = $self->_session->param('~userid');
        $self->_loadProfile($userid);
        return 1;
    }
    else {
        $self->_debug("User is not logged in in this session");
        # reset flag
        $self->_loggedIn(0);
    }

    # maybe someone's trying to log in?
    my $lg_name = $self->_cgi->param( $self->{lvprefix} . "username" );
    my $lg_pass = $self->_cgi->param( $self->{lvprefix} . "password" );

    if ($lg_name && $lg_pass) {
        # Yes! Login data coming in.
        $self->_debug("User trying to log in");
        if ($self->_login( $lg_name, $lg_pass )) {
            $self->_debug("login successful, userid: ", $self->{userid});
            $self->_loggedIn(1);
            $self->_session->param("~userid", $self->{userid});
            $self->_session->clear(["~login-trials"]);
            return 1;
        }
        else {
            # the login seems to have failed :-(
            $self->_debug("Login failed");
            my $trials = $self->_session->param("~login-trials") || 0;
            return $self->_session->param("~login-trials", ++$trials);
        }
    }

    # or maybe we can authenticate the visitor by his IP address?
    if ($self->{ipauth}) {
        # we may check the IP
        if ($self->_ipAuth()) {
            $self->_debug("IP authentication successful, userid: ", $self->{userid});
            $self->_loggedIn(1);
            $self->_session->param("~userid", $self->{userid});
            $self->_session->clear(["~login-trials"]);
            return 1;
        }
    }

}

###########################################################

sub sessionCookie {

    ##
    ## make cookie with session id
    ##

    my $self = shift;

    my $cookie = $self->_cgi->cookie($self->_session->name() => $self->_session->id );
    return $cookie;
}

###########################################################

sub loggedIn {

    ##
    ## get internal logged-in flag
    ##

    my $self = shift;

    return $self->_loggedIn;
}

###########################################################

sub profile {

    ##
    ## accessor to user profile fields
    ##

    my $self = shift;
    my $key = shift;

    if (@_) {
        my $value = shift;
        $self->{profile}{$key} = $value;
        $self->_debug("set profile field '$key' to '$value'");
    }

    return $self->{profile}{$key};
}

###########################################################

sub hasUsername {

    ##
    ## check for given user name
    ##

    my $self = shift;
    my ($username) = @_;

    return ($self->{profile}{username} eq $username);
}

###########################################################

sub logout {

    ##
    ## revoke users logged-in status
    ##

    my $self = shift;

    $self->_loggedIn(0);
    $self->_info("User '", $self->{profile}{username}, "' logged out");
}

###########################################################

sub uniqueUserID {

    ##
    ## generate a unique 32-character user ID
    ##

    my ($username) = @_;

    return md5_hex(localtime, $username);
}

###########################################################
###
### backend specific methods
###
###########################################################

###########################################################

sub _login {

    ##
    ## check login credentials and load user profile
    ##

    my $self = shift;
    my ($username, $password) = @_;

    # allow only the guest user, for real applications use a subclass
    if ( ($username eq 'guest') && ( $password eq 'guest' ) ) {
        $self->_info("User '$username' logged in");
        $self->{userid} = "guest";
        $self->_loadProfile($self->{userid});
        return 1;
    }

    return 0;
}

###########################################################

sub _ipAuth {

    ##
    ## authenticate by the visitors IP address
    ##

    return 0;
}

###########################################################

sub _loadProfile {

    ##
    ## load the user profile for a given user id
    ##

    my $self = shift;
    my ($userid) = @_;

    # store some dummy values
    $self->{userid} = $userid;
    $self->{profile}{username} = 'guest';
}

###########################################################

sub saveProfile {

    ##
    ## save probably modified user profile
    ##

}

###########################################################

sub isGroupMember {

    ##
    ## check if user is in given group
    ##

    # abstract class w/o group functions, for real applications use a subclass
    return 0;
}

###########################################################
###
### internal methods
###
###########################################################

###########################################################

sub _debug {

	##
	## log debug message
	##

	my $self = shift;

	$self->{logger}->debug(@_) if $self->{logger};
}

###########################################################

sub _info {

	##
	## log info message
	##

	my $self = shift;

	$self->{logger}->info(@_) if $self->{logger};
}

###########################################################

sub _session {

    ##
    ## get reference on CGI::Session object
    ##

    my $self = shift;

    return $self->{session};
}

###########################################################

sub _cgi {

    ##
    ## get reference on CGI object
    ##

    my $self = shift;

    return $self->{cgi};
}

###########################################################

sub _encpw {

    ##
    ## encrypt password
    ##

    my ($self, $password) = @_;

    return md5_hex($password);
}

###########################################################

sub _loggedIn {

    ##
    ## accessor to internal logged-in flag and session parameter
    ##

    my $self = shift;

    if (@_) {
        # set internal flag
        if ($self->{logged_in} = shift) {
            # set session parameter
            $self->_session->param("~logged-in", 1);
        }
        else {
            # clear session parameter
            $self->_session->clear(["~logged-in"]);
        }
        $self->_debug("(re)set logged_in: ", $self->{logged_in});
    }

    # return internal flag
    return $self->{logged_in};
}

###########################################################

sub _url {

    my $self = shift;

    return $self->{url};
}

###########################################################
###
### end of code, module documentation below
###
###########################################################

1;
__END__