Adding CGI::Session::Auth Profile Info

awohld has asked for the wisdom of the Perl Monks concerning the following question:

I'm using CGI::Session::Auth and CGI::Application

I modified the CGI::Session::Auth module to login against my companies Microsoft Active Directory.

I can get hash_ref info about the logged in user by using a method "->getUserInfo" against my MS Active Directory module. I want to store this hash_ref into the "profile" section of CGI::Session::Auth object.

When I try it, my "$self->{profile}{user_info}" data is coming back as Undef. What do I do here to get this to work?

Auth.pm

###########################################################
# CGI::Session::Auth
# Authenticated sessions for CGI scripts
###########################################################
#
# $Id: Auth.pm 28 2007-09-02 12:49:06Z geewiz $
#

package CGI::Session::Auth;
use base qw(Exporter);
use lib( '/www/perl_modules');

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


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

our $VERSION = do { q$Revision: 28 $ =~ /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 ', @{$clas
+sParams{$classParam}}) . " object"
           unless grep { $params->{$classParam}->isa($_) } @{$classPar
+ams{$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: ", $s
+elf->{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
###
###########################################################

###########################################################
[download]

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

     #  load my Active Directory object
     my $ad_handle = com::corp::ActiveDirectory->new('WIN');    

     if ( $ad_handle->login($username,$password) ) {

        $self->_info("User '$username' logged in");
        $self->{userid} = "guest";

        #  send user info via ->getUserInfo hash_ref
        $self->_loadProfile($self->{userid}, $ad_handle->getUserInfo);

        return 1;
     }

  
    return 0;
}

###########################################################
[download]

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, $user_info) = @_;
    
    # store some dummy values
    $self->{userid} = $userid;
    $self->{profile}{username} = 'guest';
    $self->{profile}{user_info} = $user_info;

}

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

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};
}
[download]

testapp.pl

#!/usr/bin/perl -w

package testapp;
use base qw( CGI::Application );

use strict;
use CGI;
use CGI::Session;
use CGI::Session::Auth;
use CGI::Carp;
use Data::Dumper::HTML qw(dumper_html);


sub setup {
    my $self = shift;
    
    $self->start_mode('free');
    $self->mode_param('cmd');
    $self->run_modes(
        'free' => 'showFreePage',
        'secret' => 'showSecretPage',
        'logout' => 'showLogoutPage',
    );

    # new session object
    my $session = new CGI::Session(undef, $self->query, {Directory=>'/
+tmp'});
    $self->param('_session' => $session);
    
    # new authentication object
    my $auth = new CGI::Session::Auth({
        CGI => $self->query,
        Session => $session
    });
    $self->param('_auth' => $auth);
    $auth->authenticate();
    
    # send session cookie    
    $self->header_props( -cookie => $auth->sessionCookie() );
}

sub _auth {
    my $self = shift;
    
    return $self->param('_auth');
}

sub showFreePage {
    my $self = shift;

    return <<HTML;
<html>
<head><title>Free page</title></head>
<body>
<h1>Free accessible page</h1>
<p><a href="testapp.pl?cmd=secret">Secret page</a></p>
</body>
</html>
HTML
}

sub showSecretPage {
    my $self = shift;

    if (! $self->_auth->loggedIn) {
        $self->showLoginPage;
    }
    else {
        $self->showSecretData;
    }
}

sub showLoginPage {
    my $self = shift;

    
    return <<HTML;
<html>
<head><title>Not logged in</title></head>
<body>
<h1>You are not logged in</h1>
<p>Please log in to see the secret page:</p>
<form action="testapp.pl" method="POST">
<input type="hidden" name="cmd" value="secret">
<p><input type="text" size="30" name="log_username" value="username"><
+/p>
<p><input type="text" size="30" name="log_password" value="password"><
+/p>
<p><input type="submit"></p>
</form>
</body>
</html>
HTML
}

sub showSecretData {
    my $self = shift;

my $var = dumper_html($self->_auth);
    
    return <<HTML;
<html>
<head><title>Secret page</title></head>
<body>
<h1>Secret data</h1>
<p>$var</p>
<p>There's more than one way to do it!</p>
<p><a href="testapp.pl?cmd=logout">Log out</a></p>
</body>
</html>
HTML
}

sub showLogoutPage {
    my $self = shift;
    
    $self->_auth->logout();
    
    return <<HTML;
<html>
<head><title>Logged out</title></head>
<body>
<h1>You have logged out.</h1>
<p><a href="testapp.pl?cmd=secret">Secret page</a></p>
</body>
</html>
HTML
}

1;

package main;

my $app = new testapp;
$app->run();
[download]

Comment on Adding CGI::Session::Auth Profile Info Select or Download Code

Replies are listed 'Best First'.
Re: Adding CGI::Session::Auth Profile Info by shmem (Chancellor) on Nov 02, 2007 at 12:34 UTC
What do I do here to get this to work? Whithout having grokked the whole source, I'd suggest changing the following line in `sub _loadProfile`: `- $self->{profile}{user_info} = $user_info; + $self->{profile}{user_info} = $user_info if $user_info;` [download] since there are calls to `_loadProfile` with just one parameter. Are those intended as such? And why are you storing stuff into that HoH object in a sub called `_loadProfile`? Looks obfuscated. --shmem _($_=" "x(1<<5)."?\n".q·/)Oo. G°\ / /\_¯/(q / ---------------------------- \__(m.====·.(_("always off the crowd"))."· ");sub _{s./.($e="'Itrs `mnsgdq Gdbj O`qkdq")=~y/"-y/#-z/;$e.e && print}	[reply] [d/l] [select]
Re^2: Adding CGI::Session::Auth Profile Info by awohld (Hermit) on Nov 03, 2007 at 05:02 UTC
Actually my code above worked, I had to logout and in for it to work and I was just refreshing the page. I was loading that HoH into the profile just to get it to work, I ended up stripping out the keys and values and loading them into the profile.	[reply]