File Coverage

blib/lib/WWW/Authen/Simple.pm

Criterion	Covered	Total	%
statement	21	204	10.2
branch	0	130	0.0
condition	0	36	0.0
subroutine	7	28	25.0
pod	14	15	93.3
total	42	413	10.1

package WWW::Authen::Simple;

# $Source: /usr/local/cvs/WWW-Authen-Simple/pm/Simple.pm,v $
# $Revision: 1.24 $
# $Date: 2004/05/12 03:21:32 $
# $Author: jmiller $

use 5.00503;
use strict;
use Digest::MD5 ();
use Carp;
use CGI qw(:standard);
use lib './';

use vars qw($VERSION $REVISION);

$REVISION = sprintf "%d.%03d", q$Revision: 1.24 $ =~ /(\d+)/g;
$VERSION = '1.22';

# Config for table layout and such.
# we'll provide methods to override this, so that WWW:A:S can
# adapt to other systems
my $conf = {
	session_table	=> {
		_table	=> 'sessions',	# table name
		login	=> 'username', 	# username field
		address	=> 'address',	# remote address field
		ticket	=> 'ticket',	# session ticket field
		point	=> 'point', 	# timestamp point field
		},
	user_table	=> {
		_table	=> 'Users', 	# table name
		uid   	=> 'uid',   	# user unique id field
		login	=> 'login', 	# username field
		passwd	=> 'passwd',	# password field
		status	=> 'disabled',	# status field
		# sub ref to determine if status value is active
		_active_status	=> sub { return 1 if ($_[0] != 1); },
		# sub ref to determine if status value is disabled
		_disabled_status	=> sub { return 1 if ($_[0] == 1); },
		},
	# group statement is used to get the groups. It should
	# fetch a groupname, groupid, and an accessbit.
	# If you don't want to use the accessbit field, just stick
	# the groupid field there as well.
	# %uid% will be replaced with a quoted uid value for the user.
	# here's an alternate statement, to give you some ideas:
	#   SELECT groupname, gid, gid FROM Users WHERE uid = %uid%
	group_statement	=> 'SELECT g.Name, ug.gid, ug.accessbit
	                    FROM Groups g, UserGroups ug
	                    WHERE g.gid = ug.gid AND ug.uid = %uid%',
	# subroutine ref used to encrypt password for db storage
	'crypt'	=> sub { return Digest::MD5::md5_base64($_[0]); }
	};

sub new
{
    my ($this) = shift;
    my $class = ref($this) || $this;
    my $self = {};
    bless( $self, $class );

	my %opts = @_;

	$self->conf($conf);
	my $debug = (defined($opts{debug}) && ($opts{debug} =~ /^\d+$/))
                ? $opts{debug} : 0;
    $self->debug($debug);

	my $expire_seconds = (defined($opts{expire_seconds})  && ($opts{expire_seconds} =~ /^\d+$/))
				? $opts{expire_seconds} : 3600;
	$self->expire_seconds($expire_seconds);

	my $cleanup_seconds = (defined($opts{cleanup_seconds}) && ($opts{cleanup_seconds} =~ /^\d+$/))
				? $opts{cleanup_seconds} : 43200;
	$self->cleanup_seconds($cleanup_seconds);

	$self->cookie_domain($opts{cookie_domain});
	$self->db($opts{db}) if($opts{db});

	return $self;
}

sub db
{
    ref(my $self = shift) or croak "instance variable needed";
    if (@_)
    {
        $self->{_db} = $_[0];
        return $self->{_db};
    } else {
        return $self->{_db};
    }
}

sub cookie_domain
{
    ref(my $self = shift) or croak "instance variable needed";
    if (@_)
    {
        $self->{_cookie_domain} = $_[0];
        return $self->{_cookie_domain};
    } else {
        return $self->{_cookie_domain};
    }
}

sub expire_seconds
{
    ref(my $self = shift) or croak "instance variable needed";
    if (@_)
    {
        croak "expire must be a possitive integer" unless ($_[0] =~ /^\d+$/);
        $self->{_expire_seconds} = $_[0];
        return $self->{_expire_seconds};
    } else {
        return $self->{_expire_seconds};
    }
}

sub cleanup_seconds
{
    ref(my $self = shift) or croak "instance variable needed";
    if (@_)
    {
        croak "expire must be a possitive integer" unless ($_[0] =~ /^\d+$/);
        $self->{_cleanup_seconds} = $_[0];
        return $self->{_cleanup_seconds};
    } else {
        return $self->{_cleanup_seconds};
    }
}

sub debug
{
    ref(my $self = shift) or croak "instance variable needed";
    if (@_)
    {
        $self->{_debug} = $_[0];
        return $self->{_debug};
    } else {
        return $self->{_debug};
    }
}


sub cleanup
{
	ref(my $self = shift) or croak "instance variable needed";

	my $cleanup_point = time() - $self->cleanup_seconds();
	$self->db->do( 'DELETE FROM '.
		$self->conf->{session_table}{_table} .
		' WHERE '.
		$self->conf->{session_table}{point} .
		' < ' .
		$self->db->quote($cleanup_point) );
}

sub username
{
	ref(my $self = shift) or croak "instance variable needed";
	return $self->{_store}{username} if($self->{_store}{username});
	return undef;
}

sub uid
{
	ref(my $self = shift) or croak "instance variable needed";
	return $self->{_store}{uid} if($self->{_store}{username});
	return undef;
}

sub logged_in
{
	ref(my $self = shift) or croak "instance variable needed";

	return 1 if($self->{_store}{username});
	return undef unless(($self->{_store}{login_called}) && ($self->{_store}{username}));
	return 0;
}

sub groups
{
	ref(my $self = shift) or croak "instance variable needed";

	# load groups for this user if we haven't loaded them already
	unless (defined $self->{_store}{_groups})
	{
		$self->_load_groups();
	}

	my @return_array;

	foreach my $group (keys %{$self->{_store}{_groups}})
	{
		push(@return_array,$group); # group could be a name or gid
	}

	return @return_array;
}

sub _load_groups
{
	ref(my $self = shift) or croak "instance variable needed";

	my $group_statement = $self->conf->{group_statement};
	# inject uid
	my $q_uid = $self->db->quote( $self->{_store}{uid} );
	$group_statement =~ s/\%uid\%/$q_uid/g;
	my $get_groups = $self->db->prepare( $group_statement )
		or croak "Unable to prepare group select statement '$group_statement'";
	$get_groups->execute
		or croak "Unable to execute group select statement '$group_statement'";
	while (my ($name,$gid,$accessbit) = $get_groups->fetchrow_array)
	{
		$self->{_store}{_groups}{$name} = $accessbit;
		$self->{_store}{_groups}{$gid} = $accessbit;
	}
	$get_groups->finish;
}

sub in_group
{
	ref(my $self = shift) or croak "instance variable needed";

	my ($group,$rw) = @_;

	my $rwbit;
	if ($rw && ($rw =~ /^\d+$/))
	{	# it's a number
		$rwbit = $rw;
	} elsif ($rw && ($rw =~ /^(r|w)/i)) {
		# it's a name (should be either "r", "w", or "rw"
		$rwbit += 1 if ($rw =~ /r/i);
		$rwbit += 2 if ($rw =~ /w/i);
	} else {
		# just return the bits, since they didn't ask for something
		$rwbit = 0;
	}

	# load groups for this user if we haven't loaded them already
	unless (defined $self->{_store}{_groups})
	{
		$self->_load_groups();
	}

	# $group can be either a gid or a group name.
	# we just make sure we don't name any of our groups w/ numbers
	if (defined $self->{_store}{_groups}{$group})
	{	# they're in the group they asked for
		# either return the accessbits,
		# or true/false if they specified a $rw bit
		if ($rwbit)
		{	# we check the access bit in here (using bitwise AND)
			warn "in_group(G[$group] rw[$rwbit])\n\tstored rwbit[".$self->{_store}{_groups}{$group}."]\n\tRV[".(($self->{_store}{_groups}{$group} & $rwbit) == $rwbit)."]\n" if $self->debug();
			return (($self->{_store}{_groups}{$group} & $rwbit) == $rwbit);
		} else {
			# just return the access bit
			return $self->{_store}{_groups}{$group};
		}
	} else {
		return 0; # zero is no read, no write
	}
}

sub login
{

	ref(my $self = shift) or croak "instance variable needed";
	my ($login,$passwd) = @_;

	my $cgi = new CGI;

	my $remote_address = $ENV{REMOTE_ADDR};
	$self->{_store}{login_called} = 1;

	if ($login && $passwd)
	{	# if neither are null, they're trying to login.
		my ($uid,$local_passwd,$status) = $self->_get_user_info($login);

		# invalid login (user doesn't exist)
		return (0,$login) unless $uid;
		# invalid login (account is disabled)
		return (0,$login) if &{$self->conf->{user_table}{_disabled_status}}($status);

		my $crypt_passwd = $self->_getcrypt($passwd);
		if ($crypt_passwd eq $local_passwd)
		{
			# they're authenticated... need to update local session, set cookie ticket for them, and return "1" for logged in
			my $new_ticket = $self->_ticket;
			my $point = time;
			$self->{_store}{username} = $login;
			$self->{_store}{uid} = $uid;
			$self->_set_session($login,$remote_address,$new_ticket,$point);
			return (1,$login,$uid);
		} else {
			return (0,$login); # invalid login (passwd doesn't match)
		}
	}

	my $remote_login = $cgi->cookie('login');
	my $remote_ticket = $cgi->cookie('ticket');
	if ($remote_login && $remote_ticket)
	{	# they've logged in before (or are spoofing)
		my $get_ticket = $self->db->prepare(
			'SELECT '.
			$self->conf->{session_table}{ticket} .', '.
			$self->conf->{session_table}{point} .
			' FROM '.
			$self->conf->{session_table}{_table} .
			' WHERE '.
			$self->conf->{session_table}{login} .' = '.
			$self->db->quote($remote_login) .
			' AND '.
			$self->conf->{session_table}{address} .' = '.
			$self->db->quote($remote_address)
			) or croak "Unable to prepare get_ticket statement";
		$get_ticket->execute()
			or croak "Unable to execute get_ticket statement";

		my ($local_ticket,$local_point) = $get_ticket->fetchrow_array();
		$get_ticket->finish;

		my $point = time;
		if ($local_ticket && ($remote_ticket eq $local_ticket))
		{
			if ($local_point > ($point - $self->expire_seconds()))
			{	# valid ticket, continue sesson
				# keep using existing ticket, update point on it
				# set remote cookie's (so they don't time out)
				# return logged in signal

				# make sure they're not disabled
				my ($uid,$local_passwd,$status) = $self->_get_user_info($remote_login);

				return (0,$remote_login) if &{$self->conf->{user_table}{_disabled_status}}($status);

				my $point = time;
				$self->_set_session($remote_login,$remote_address,$local_ticket,$point);
				$self->{_store}{username} = $remote_login;
				$self->{_store}{uid} = $uid;
				return (1,$remote_login,$uid);
			} else {
				# login has expired
				return (-1,$remote_login); #login expired
			}
		} else {
			# invalid ticket (username cookie matched, ticket cookie didn't)
			return (0,$remote_login); # invalid login
		}
	} else {
		# didn't try to login, and no cookies set
		return (0,0);
	}
}

sub conf
{
	ref(my $self = shift) or croak "instance variable needed";
    if (@_)
    {
        $self->{_conf} = $_[0];
        return $self->{_conf};
    } else {
        return $self->{_conf};
    }
	return $self->{_conf};
}

sub _get_user_info
{
	ref(my $self = shift) or croak "instance variable needed";
	my $login = shift;
	my $get_user_info = $self->db->prepare(
		'SELECT '.
		$self->conf->{user_table}{uid} .', '.
		$self->conf->{user_table}{passwd} .', '.
		$self->conf->{user_table}{status} .
		' FROM '.
		$self->conf->{user_table}{_table} .
		' WHERE '.
		$self->conf->{user_table}{login} . ' = ' .
		$self->db->quote($login)  )
		or croak "Unable to prepare get_user_info statement";
	$get_user_info->execute
		or croak "Unable to execute get_user_info statement";
	my ($uid,$local_passwd,$status) = $get_user_info->fetchrow_array();
	$get_user_info->finish;
	return ($uid,$local_passwd,$status);
}

sub logout
{
	ref(my $self = shift) or croak "instance variable needed";

	my $cgi = new CGI;
	my $login = $self->username() || $cgi->cookie('login');
	my $remote_address = $ENV{REMOTE_ADDR};
	if ($login && $remote_address)
	{
		$self->_set_session($login,$remote_address,'*',0);
	}
	# clear out the stored data
	$self->{_store}{username} = '';
	$self->{_store}{uid} = '';
	# leave _groups hash ref so that we don't try to reload them
	# but clear all access bits, removing the users access
	foreach my $group (keys %{$self->{_store}{_groups}})
	{
		$self->{_store}{_groups}{$group} = '0';
	}
}

sub _set_cookie
{
	ref(my $self = shift) or croak "instance variable needed";

	my ($login,$ticket,$point) = @_;
	my ($login_cookie,$ticket_cookie);

	my $base_cookie = '; domain=' . $self->cookie_domain();
	if ($point == 0)
	{	# if they hit logout, then try to expire their local cookie
		$base_cookie .= '; max-age=0';
	} else {
		$base_cookie .= '; max-age=' . $self->expire_seconds();
	}
	$base_cookie .= '; path=/';
	$base_cookie .= '; version=1';

	print 'Set-Cookie: login=' . $login . $base_cookie . "\n";
	print 'Set-Cookie: ticket=' . $ticket . $base_cookie . "\n";
}

sub _set_session
{
	ref(my $self = shift) or croak "instance variable needed";

	my ($login,$address,$ticket,$point) = @_;

	$self->_set_cookie($login,$ticket,$point);

	# set local session
	my $get_ticket = $self->db->prepare(
		'SELECT '.
		$self->conf->{session_table}{ticket} .
		' FROM '.
		$self->conf->{session_table}{_table} .
		' WHERE '.
		$self->conf->{session_table}{login} . ' = '.
		$self->db->quote($login) .
		' AND '.
		$self->conf->{session_table}{address} . ' = '.
		$self->db->quote($address)  )
		or croak "Unable to prepare get_ticket statement";
	$get_ticket->execute()
		or croak "Unable to execute get_ticket statement";
	my ($local_ticket) = $get_ticket->fetchrow_array();
	$get_ticket->finish;

	if ($local_ticket)
	{	# a session has already been stored for this user/addy
		$self->db->do(
			'UPDATE '.
			$self->conf->{session_table}{_table} .
			' SET '.
			$self->conf->{session_table}{ticket} .' = '.
			$self->db->quote($ticket) .', '.
			$self->conf->{session_table}{point} .' = '.
			$self->db->quote($point) .
			' WHERE '.
			$self->conf->{session_table}{login} .' = '.
			$self->db->quote($login) .
			' AND '.
			$self->conf->{session_table}{address} .' = '.
			$self->db->quote($address)  )
			or croak "Unable to update session table for login[$login] address[$address]";
	} else {
		# set a new local session
		$self->db->do(
			'INSERT INTO '.
			$self->conf->{session_table}{_table} .
			' ('.
			$self->conf->{session_table}{login} .', '.
			$self->conf->{session_table}{address} .', '.
			$self->conf->{session_table}{ticket} .', '.
			$self->conf->{session_table}{point} .
			') VALUES ('.
			$self->db->quote($login) .', '.
			$self->db->quote($address) .', '.
			$self->db->quote($ticket) .', '.
			$self->db->quote($point) .')'
			) or croak "Unable to insert session for login[$login] address[$address]";
	}
}

sub _ticket
{
	my $length = 128;
	my $ticket;
	while($length-- > 0)
	{
		$ticket .= chr(rand(256));
	}
	return Digest::MD5::md5_hex($ticket);
}

sub _getcrypt
{
	ref(my $self = shift) or croak "instance variable needed";
	my $pass = shift;
	return &{$self->conf->{'crypt'}}($pass);
}

1;
__END__