CGI::Session::Auth::DBI - Authenticated sessions for CGI scripts

  use CGI;
  use CGI::Session;
  use CGI::Session::Auth::DBI;

  my $cgi = new CGI;
  my $session = new CGI::Session(undef, $cgi, {Directory=>'/tmp'});
  my $auth = new CGI::Session::Auth::DBI({
      CGI => $cgi,
      Session => $session,
      DSN => 'dbi:mysql:host=localhost,database=cgiauth',
  });
  $auth->authenticate();

  if ($auth->loggedIn) {
      showSecretPage;
  }
  else {
      showLoginPage;
  }

###########################################################
# CGI::Session::Auth::DBI
# Authenticated sessions for CGI scripts
###########################################################
#
# $Id: DBI.pm 25 2006-02-21 12:07:26Z geewiz $
#

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

use 5.008;
use strict;
use warnings;
use Carp;
use DBI;

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

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

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

sub new {
    
    ##
    ## build new class object
    ##
    
    my $class = shift;
    my ($params) = shift;
    
    $class = ref($class) if ref($class);
    
    # initialize parent class
    my $self = $class->SUPER::new($params);
    
    #
    # class specific parameters
    #

	# parameter 'DBHandle': use an initialized DBI database handle
    if ($params->{DBHandle}) {
      $self->{dbh} = $params->{DBHandle};
    } else {
      # parameter 'DSN': DBI data source name
      my $dsn = $params->{DSN} || croak("No DSN parameter");
      # parameter 'DBUser': database connection username
      my $dbuser = $params->{DBUser} || '';
      # parameter 'DBPasswd': database connection password
      my $dbpasswd = $params->{DBPasswd} || "";
      # parameter 'DBAttr': optional database connection attributes
      my $dbattr = $params->{DBAttr} || {};
      # database handle
      $self->{dbh} = DBI->connect($dsn, $dbuser, $dbpasswd, $dbattr) or croak("DB error: " . $DBI::errstr);
    }
    
    # parameter 'EncryptPW': passwords are MD5-encrypted (default 0)
    $self->{encryptpw} = $params->{EncryptPW} || 0;
    # parameter 'UserTable': name of user data table
    $self->{usertable} = $params->{UserTable} || 'auth_user';
    $self->{usernamefield} = $params->{UsernameField} || 'username';
    $self->{passwordfield} = $params->{PasswordField} || 'passwd';
    $self->{useridfield} = $params->{UserIDField} || 'userid';
    # parameter 'GroupTable': name of user data table
    $self->{grouptable} = $params->{GroupTable} || 'auth_group';
    $self->{groupfield} = $params->{GroupField} || 'groupname';
    $self->{groupuseridfield} = $params->{GroupUserIDField} || 'userid';
    # parameter 'IPTable': name of ip network table
    $self->{iptable} = $params->{IPTable} || 'auth_ip';
    $self->{ipuseridfield} = $params->{IPUserIDField} || 'userid';
    $self->{ipaddressfield} = $params->{IPAddressField} || 'network';
    $self->{ipmaskfield} = $params->{IPNetMaskField} || 'netmask';
    
    #
    # class members
    #
    
    # blessed are the greek
    bless($self, $class);
    
    return $self;
}

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

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

sub _login {
    
    ##
    ## check username and password
    ##
    
    my $self = shift;
    my ($username, $password) = @_;
    
    $self->_debug("username: $username, password: $password");

    if ($self->{encryptpw}) {
		$password = $self->_encpw($password);
		$self->_debug("Encrypted password: $password");
	}

    my $result = 0;
    
    my $query = sprintf(
        "SELECT * FROM %s WHERE %s = ? AND %s = ?",
        $self->{usertable},
        $self->{usernamefield},
        $self->{passwordfield},
    );
    $self->_debug("query: $query");
    # search for username
    my $sth = $self->_dbh->prepare($query);
    $sth->execute($username, $password) or croak $self->_dbh->errstr;
    if (my $rec = $sth->fetchrow_hashref) {
        $self->_debug("found user entry");
        $self->_extractProfile($rec);
        $result = 1;
        $self->_info("user '$username' logged in");
    }
    $sth->finish;
    
    return $result;
}

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

sub _ipAuth {
    
    ##
    ## authenticate by the visitors IP address
    ##
    
    my $self = shift;
    
    require NetAddr::IP;
    
    my $remoteip = new NetAddr::IP($self->_cgi->remote_host);
    $self->_debug("checking remote IP $remoteip");
    
    my $result = 0;
    
    my $query = sprintf(
        "SELECT %s, %s, %s FROM %s",
        $self->{ipuseridfield},
        $self->{ipaddressfield},
        $self->{ipmaskfield},
        $self->{iptable}
    );
    $self->_debug("query: $query");
    
    # search for username
    my $sth = $self->_dbh->prepare($query);
    $sth->execute or croak $self->_dbh()->errstr;
    while (my $rec = $sth->fetchrow_hashref) {
        
        $self->_debug("compare IP network ", $rec->{$self->{ipaddressfield}}, "/", $rec->{$self->{ipmaskfield}});
        
        if ($remoteip->within(new NetAddr::IP( $rec->{$self->{ipaddressfield}}, $rec->{$self->{ipmaskfield}}))) {
            $self->_debug("we have a winner!");
            # get user record
            my $user = $self->_getUserRecord($rec->{$self->{ipuseridfield}});
            $self->_extractProfile($user);
            $result = 1;
            last;
        }
        else {
            $self->_debug("no member of this network");
        }
        
    }
    $sth->finish;
    
    return $result;
}

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

sub _loadProfile {
    
    ##
    ## get user profile from database by userid
    ##
    
    my $self = shift;
    my ($userid) = @_;
    
    my $query = sprintf(
        "SELECT * FROM %s WHERE %s = ?",
        $self->{usertable},
        $self->{useridfield}
    );
    $self->_debug("query: $query");
    my $sth = $self->_dbh->prepare($query);
    $sth->execute($userid) or croak $self->_dbh()->errstr;
    if (my $rec = $sth->fetchrow_hashref) {
        $self->_debug("Found user entry");
        $self->_extractProfile($rec);
    }
    $sth->finish;
}

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

sub saveProfile {

    ##
    ## save probably modified user profile
    ##

    my $self = shift;
    
    my $query = "UPDATE " . $self->{usertable} . " SET ";
    my @values;
    my $first = 1;
	foreach (keys %{$self->{profile}}) {
		if ($_ ne $self->{useridfield}) {
			$query .= (($first) ? '' : ', ') . $_ . " = ?";
			push @values, $self->{profile}{$_};
			$first = 0;
		}
	}
	$query .= " WHERE " . $self->{useridfield} . " = ?";
	$self->_debug("update query: ", $query);

    my $sth = $self->_dbh()->prepare($query);
    $sth->execute(@values, $self->{userid}) or croak $self->_dbh()->errstr;
	    
}

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

sub isGroupMember {
    
    ##
    ## check if user is in given group
    ##
    
    my $self = shift;
    my ($group) = @_;
    
    $self->_debug("group: $group");
    
    my $result = 0;
    
    my $query = sprintf(
        "SELECT * FROM %s WHERE %s = ? AND %s = ?",
        $self->{grouptable},
        $self->{groupuseridfield},
        $self->{groupfield}
    );
    $self->_debug("query: $query");
    $self->_debug("values: $self->{userid}, $group");
    # search for username
    my $sth = $self->_dbh->prepare($query);
    $sth->execute($self->{userid}, $group) or croak $self->_dbh->errstr;
    if (my $rec = $sth->fetchrow_hashref) {
        $self->_debug("found group entry");
        $result = 1;
    }
    $sth->finish;
    
    return $result;
}

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

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

sub _dbh {
    
    ##
    ## return database handle
    ##
    
    my $self = shift;
    
    return $self->{dbh};
}

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

sub _extractProfile {
    
    ##
    ## get user profile from database record
    ##
    
    my $self = shift;
    my ($rec) = @_;
    
    $self->{userid} = $rec->{$self->{useridfield}};
    foreach ( keys %$rec ) {
        $self->{profile}{$_} = $rec->{$_};
    }
};

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

sub _getUserRecord {
    
    ##
    ## get user data by user id
    ##
    
    my $self = shift;
    my ($userid) = @_;
    
    $self->_debug("get data for userid: ", $userid);
    
    my $query = sprintf(
        "SELECT * FROM %s WHERE %s = ?",
        $self->{usertable},
        $self->{useridfield}
    );
    $self->_debug("query: $query");
    # search for username
    my $sth = $self->_dbh->prepare($query);
    $sth->execute($userid) or croak $self->_dbh->errstr;
    
    return $sth->fetchrow_hashref;
}

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

1;
__END__