view release on metacpan or  search on metacpan

lib/Apache2/AuthEnv.pm  view on Meta::CPAN

		err "AuthEnvAllowFile: Cannot read access allow file '$file' ($!) at $line.\n";
		return;
	}

	local ($/) = undef; # slurp.
	my $users = <FILE>;
	$users =~ s/#.*$//gm;
	
	for my $user (split/\s+/, $users)
	{
		next unless ($user ne '');
		push @{$cfg->{authorise}}, ['%{REMOTE_USER}', 1, 1, undef, $user, $line];
	}

	close FILE;
}

sub AuthEnvDenyFile
{
	my ($cfg, $parms, $file) = @_;
	my $line = join(':', $parms->directive->filename, $parms->directive->line_num);

	local *FILE;
	unless (open (FILE, '<', $file))
	{
		err "AuthEnvDenyFile: Cannot read access deny file '$file' ($!) at $line.\n";
		err "AuthEnv: Denying all!\n";

		# deny all from this point; just in case.
		&AuthEnvDenyAll($cfg, $parms);

		return;
	}

	local ($/) = undef; # slurp.
	my $users = <FILE>;
	$users =~ s/#.*$//gm;
	
	for my $user (split /\s+/s, $users)
	{
		next unless ($user ne '');
		push @{$cfg->{authorise}}, ['%{REMOTE_USER}', 0, 1, undef, $user, $line];
	}

	close FILE;
}

sub AuthEnvDbImport
{
	my ($cfg, $parms, $var, $db, $fmt) = @_;
	my $line = join(':', $parms->directive->filename, $parms->directive->line_num);

	# Check file is valid - i.e. exists and readable.
	unless ( -r $db )
	{
		#warn "DB file is '$db'.\n";
		warn "Cannot read database file at $line.\n";
		return 0;
	}

	# Untaint as file exists.
	$db = $1 if ($db =~ /^(.*)$/);

	push @{$cfg->{set}}, ['dbimport', $var, $db, $fmt, $line];
}

sub AuthEnvSet
{
	my ($cfg, $parms, $var, $fmt) = @_;
	my $line = join(':', $parms->directive->filename, $parms->directive->line_num);
	push @{$cfg->{set}}, ['set', $var, $fmt, $line];
}

sub AuthEnvChange
{
	my ($cfg, $parms, $var, $change) = @_;
	my $line = join(':', $parms->directive->filename, $parms->directive->line_num);
	push @{$cfg->{set}}, ['change', $var, $change, $line];
}

sub AuthEnvDenial
{
	my ($cfg, $parms, $code) = @_;

	if ($code =~ /FORBIDDEN/i)
	{
		$cfg->{Denial} = Apache2::Const::HTTP_FORBIDDEN;
	}
	elsif ($code =~ /UNAUTHORI[SZ]ED/i)
	{
		$cfg->{Denial} = Apache2::Const::HTTP_UNAUTHORIZED;
	}
	elsif ($code =~ /NOT.FOUND/i)
	{
		$cfg->{Denial} = Apache2::Const::NOT_FOUND;
	}
	else
	{
		# warning of bad denial code.
		my $line = join(':', $parms->directive->filename, $parms->directive->line_num);
		warn "Invalid argument to AuthEnvDenial at $line";

		# Set a default.
		$cfg->{Denial} = Apache2::Const::HTTP_FORBIDDEN;

		return 0;
	}

	1;
}

# Turn on information logging to the log files.
sub AuthEnvLogInfo
{
	my ($cfg, $parms, $onoff) = @_;

	$cfg->{LogInfo} = $onoff;

	1;
}

lib/Apache2/AuthEnv.pm  view on Meta::CPAN

}

# Turn on custom merging.
sub DIR_MERGE    { merge(@_) }
sub SERVER_MERGE { merge(@_) }


# Fill out a sub-format with the correct values.
# Take a context ($r), a format of environment variables (with optional default) and 
# a fail reference.
# Return the value of the first environment variable that exists, or the default if specified
# or '' and increament the failure variable reference.
sub fillout
{
	my ($r, $fmt, $fail) = @_;

	debug("Expanding '$fmt' for URL ", $r->uri);

	# Isolate the default value.
	my $default = ($fmt =~ s/:(\w*)$//) ? $1 : undef;

	# Run though each environment valriable in turn.
	for my $e (split(/\|/, $fmt))
	{
		# return value if it exists.
		return $r->subprocess_env($e) if defined($r->subprocess_env($e));
	}

	# Otherwise return the default value.
	return $default if defined $default;

	info "Failed to expand '$fmt' for URL ", $r->uri;

	# Failed.
 	$$fail++;

	'';
}

# Look a key up in the MLDBM database, with a function that can be cached.
sub dblookup2
{
	my ($file, $var) = @_;
	##warn("db key '$var' in file '$file'");

	my $null = freeze {};

	return $null unless defined $file;

	my $db = tie my %data,  'MLDBM', 
		-Filename => $file, 
		-Flags => DB_RDONLY,
	;

	unless ($db)
	{
		err("Cannot read database '$file' failed ($!) ");
		return $null;
	}

	# Side step any taint issues.
	# The datbase is a valid file.
	$db->RemoveTaint(1);

	# Return nothing if there is no entry.
	return $null unless exists $data{$var};

	# Return frozen data.
	freeze $data{$var};
}

# Wrap the lookup function.
tie my %mcache => 'Memoize::Expire',
        LIFETIME => 5,    # In seconds
;
memoize 'dblookup2', SCALAR_CACHE => [HASH => \%mcache ], LIST_CACHE => 'FAULT', ;

# This is a wrapper to manage the unthawing process correctly.
sub dblookup
{
	my $user = dblookup2(@_);
	$user = thaw $user;
}

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

# NB There is almost no environment to speak of at this time!

# Authenticate a user based on the presence of environemnt variables.
# Fail to authenticate if a environment variable doesn't exist.
# Promote environment variables in format to REMOTE_USER.
sub authenticate
{
	my ($r) = @_;

	# recover configuration.
        my $cfg = Apache2::Module::get_config(__PACKAGE__, $r->server, $r->per_dir_config);

	# Check that we are using the right AuthType directive.
	my $type = __PACKAGE__; $type =~ s/^.*:://;
	if ($r->auth_type ne $type)
	{
		err("Wrong authentication Type ", $r->auth_type);
		return Apache2::Const::HTTP_UNAUTHORIZED;
	}
	unless (defined $cfg->{AuthEnvUser})
	{
		err("AuthEnvUser not used! ", $r->auth_type);
		return Apache2::Const::HTTP_UNAUTHORIZED;
	}

	# set logging on or off.
	if (exists $cfg->{LogInfo} && $cfg->{LogInfo})
	{
		# info on
		no warnings;
		eval 'sub info { warn @_; };';
	}
	else
	{
		# info off