view release on metacpan or  search on metacpan

contrib/AuthDigestDBI.pm  view on Meta::CPAN

package Apache::AuthDigestDBI;

use Apache ();
use Apache::Constants qw( OK AUTH_REQUIRED FORBIDDEN DECLINED SERVER_ERROR );
use DBI ();
use IPC::SysV qw( IPC_CREAT IPC_RMID S_IRUSR S_IWUSR );
use Apache::AuthDigest::API;
use Digest::MD5;
use strict;

# $Id: AuthDigestDBI.pm,v 1.1 2002/11/11 13:58:37 geoff Exp $

require_version DBI 1.00;

$Apache::AuthDigestDBI::VERSION = '0.89';

# 1: report about cache miss
# 2: full debug output
$Apache::AuthDigestDBI::DEBUG = 0;


# configuration attributes, defaults will be overwritten with values from .htaccess.

my %Config = (
    'Auth_DBI_data_source'      => '',
    'Auth_DBI_username'         => '',
    'Auth_DBI_password'         => '',
    'Auth_DBI_pwd_table'        => '',
    'Auth_DBI_uid_field'        => '',
    'Auth_DBI_pwd_field'        => '',
    'Auth_DBI_pwd_whereclause'  => '',
    'Auth_DBI_grp_table'        => '',
    'Auth_DBI_grp_field'        => '',
    'Auth_DBI_grp_whereclause'  => '',
    'Auth_DBI_log_field'        => '',
    'Auth_DBI_log_string'       => '',
    'Auth_DBI_authoritative'    => 'on',
    'Auth_DBI_nopasswd'         => 'off',
    'Auth_DBI_encrypted'        => 'on',
    'Auth_DBI_encryption_salt'  => 'password',
    'Auth_DBI_uidcasesensitive' => 'on',
    'Auth_DBI_pwdcasesensitive' => 'on',
    'Auth_DBI_placeholder'      => 'off',
);

# stores the configuration of current URL.
# initialized  during authentication, eventually re-used for authorization.
my $Attr = { };


# global cache: all records are put into one string.
# record separator is a newline. Field separator is $;.
# every record is a list of id, time of last access, password, groups (authorization only).
# the id is a comma separated list of user_id, data_source, pwd_table, uid_field.
# the first record is a timestamp, which indicates the last run of the CleanupHandler followed by the child counter.

my $Cache = time . "$;0\n";

# unique id which serves as key in $Cache.
# the id is generated during authentication and re-used for authorization.
my $ID;


# minimum lifetimes of cache entries in seconds.
# setting the CacheTime to 0 will not use the cache at all.

my $CacheTime = 0;

# supposed to be called in a startup script.
# sets CacheTime to a user defined value.

sub setCacheTime {
    my $class      = shift;
    my $cache_time = shift;
    # sanity check
    $CacheTime = $cache_time if ($cache_time =~ /\d+/);
}


# minimum time interval in seconds between two runs of the PerlCleanupHandler.
# setting CleanupTime to 0 will run the PerlCleanupHandler after every request.
# setting CleanupTime to a negative value will disable the PerlCleanupHandler.

my $CleanupTime = -1;

# supposed to be called in a startup script.
# sets CleanupTime to a user defined value.

sub setCleanupTime {
    my $class        = shift;
    my $cleanup_time = shift;
    # sanity check
    $CleanupTime = $cleanup_time if ($cleanup_time =~ /\-*\d+/);
}


# optionally the string with the global cache can be stored in a shared memory segment.
# the segment will be created from the first child and it will be destroyed if the last child exits.
# the reason for not handling everything in the main server is simply, that there is no way to setup 
# an ExitHandler which runs in the main server and which would remove the shared memory and the semaphore.
# hence we have to keep track about the number of children, so that the last one can do all the cleanup.
# creating the shared memory in the first child also has the advantage, that we don't have to cope
# with changing the ownership.
# if a shm-function fails, the global cache will automatically fall back to one string per process.

my $SHMKEY  =     0; # unique key for shared memory segment and semaphore set
my $SEMID   =     0; # id of semaphore set
my $SHMID   =     0; # id of shared memory segment
my $SHMSIZE = 50000; # default size of shared memory segment

# shortcuts for semaphores
my $obtain_lock  = pack("sss", 0,  0, 0) . pack("sss", 0, 1, 0);
my $release_lock = pack("sss", 0, -1, 0);

# supposed to be called in a startup script.
# sets SHMSIZE to a user defined value and initializes the unique key, used for the shared memory segment and for the semaphore set.
# creates a PerlChildInitHandler which creates the shared memory segment and the semaphore set.
# creates a PerlChildExitHandler which removes the shared memory segment and the semaphore set upon server shutdown.
# keep in mind, that this routine runs only once, when the main server starts up.

sub initIPC {
    my $class   = shift;
    my $shmsize = shift;

    # make sure, this method is called only once
    return if $SHMKEY;

    # ensure minimum size of shared memory segment
    $SHMSIZE = $shmsize if $shmsize >= 500;

    # generate unique key based on path of AuthDBI.pm
    foreach my $file (keys %INC) {
        if ($file eq 'Apache/AuthDBI.pm') {
            $SHMKEY = IPC::SysV::ftok($INC{$file}, 1);
            last;
        }
    }

    # provide a handler which initializes the shared memory segment (first child)
    # or which increments the child counter. 
    if(Apache->can('push_handlers')) {
        Apache->push_handlers("PerlChildInitHandler" => \&childinit);
    }

    # provide a handler which decrements the child count or which destroys the shared memory 
    # segment upon server shutdown, which is defined by the exit of the last child.
    if(Apache->can('push_handlers')) {
        Apache->push_handlers("PerlChildExitHandler" => \&childexit);
    }
}


# authentication handler

sub authen {

    my ($r) = @_;
    my ($key, $val, $dbh);

    my $prefix = "$$ Apache::AuthDigestDBI::authen";

    if ($Apache::AuthDigestDBI::DEBUG > 1) {
        my ($type) = '';
        $type .= 'initial ' if $r->is_initial_req;
        $type .= 'main'     if $r->is_main;
        print STDERR "==========\n$prefix request type = >$type< \n";
    }

    return OK unless $r->is_initial_req; # only the first internal request

    print STDERR "REQUEST:\n", $r->as_string if $Apache::AuthDigestDBI::DEBUG > 1;
	
	my $auth = 'digest';

	# here the dialog pops up and asks you for username and password
	my ($status, $response, $res, $passwd_sent);
	if ($r->header_in("Authorization") =~ /^Basic (.*)/i) {
		$auth = 'Basic';
		my $username;
		($username, $passwd_sent) = split ':', old_decode_base64($1);
		$r->connection->user($username);
	}

	if ($auth eq 'digest') {

		$r = Apache::AuthDigest::API->new($r);
		($status, $response) = $r->get_digest_auth_response;		
		return $status unless $status == OK;
		$passwd_sent = 'digest';
		
	} else {
	
		#($res, $passwd_sent) = $r->get_basic_auth_pw;
		#print STDERR "$prefix get_basic_auth_pw: res = >$res<, password sent = >$passwd_sent<\n" if $Apache::AuthDigestDBI::DEBUG > 1;
		#return $res if $res; # e.g. HTTP_UNAUTHORIZED
		
		return AUTH_REQUIRED unless $passwd_sent;
		
	}

    # get username
    my ($user_sent) = $r->connection->user;
    print STDERR "$prefix user sent = >$user_sent<\n" if $Apache::AuthDigestDBI::DEBUG > 1;

    # do we use shared memory for the global cache ?
    print STDERR "$prefix cache in shared memory, shmid $SHMID, shmsize $SHMSIZE, semid $SEMID \n" if ($SHMID and $Apache::AuthDigestDBI::DEBUG > 1);

    # get configuration
    while(($key, $val) = each %Config) {
        $val = $r->dir_config($key) || $val;
        $key =~ s/^Auth_DBI_//;
        $Attr->{$key} = $val;
        printf STDERR "$prefix Config{ %-16s } = %s\n", $key, $val if $Apache::AuthDigestDBI::DEBUG > 1;
    }

    # parse connect attributes, which may be tilde separated lists
    my @data_sources = split(/~/, $Attr->{data_source});
    my @usernames    = split(/~/, $Attr->{username});
    my @passwords    = split(/~/, $Attr->{password});
    $data_sources[0] = '' unless $data_sources[0]; # use ENV{DBI_DSN} if not defined

    # obtain the id for the cache
    my $data_src = $Attr->{data_source};
    $data_src =~ s/\(.+\)//go; # remove any embedded attributes, because of trouble with regexps
    $ID = join ',', $user_sent, $data_src, $Attr->{pwd_table}, $Attr->{uid_field};

    # if not configured decline
    unless ($Attr->{pwd_table} && $Attr->{uid_field} && $Attr->{pwd_field}) {
        printf STDERR "$prefix not configured, return DECLINED\n" if $Apache::AuthDigestDBI::DEBUG > 1;
        return DECLINED;
    }

    # do we want Windows-like case-insensitivity?
    $user_sent   = lc($user_sent)   if $Attr->{uidcasesensitive} eq "off";
    $passwd_sent = lc($passwd_sent) if $Attr->{pwdcasesensitive} eq "off";

    # check whether the user is cached but consider that the password possibly has changed
    my $passwd = '';
    my $salt   = '';
    if ($CacheTime) { # do we use the cache ?
        if ($SHMID) { # do we keep the cache in shared memory ?
            semop($SEMID, $obtain_lock) or print STDERR "$prefix semop failed \n";
            shmread($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmread failed \n";
            substr($Cache, index($Cache, "\0")) = '';
            semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
        }
        # find id in cache
        my ($last_access, $passwd_cached, $groups_cached);
        if ($Cache =~ /$ID$;(\d+)$;(.+)$;(.*)\n/) {
            $last_access   = $1;
            $passwd_cached = $2;
            $groups_cached = $3;
            printf STDERR "$prefix cache: found >$ID< >$last_access< >$passwd_cached< \n" if $Apache::AuthDigestDBI::DEBUG > 1;
			if ($auth eq 'digest') {
				$salt = $response->{'realm'};
				my $passwd_to_check = Digest::MD5::md5_hex(join ':', $user_sent, $salt, $passwd_cached);
				$passwd = $passwd_cached if $r->compare_digest_response($response, $passwd_to_check);
			} else {
				$salt = $Attr->{encryption_salt} eq 'userid' ? $user_sent : $passwd_cached;
				my $passwd_to_check = $Attr->{encrypted} eq 'on' ? crypt($passwd_sent, $salt) : $passwd_sent; 
				# match cached password with password sent 
				$passwd = $passwd_cached if $passwd_to_check eq $passwd_cached;
			}
        }
    }