view release on metacpan or  search on metacpan

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

		name		=> 'AuthEnvSet',
		args_how	=> Apache2::Const::TAKE2,
		errmsg		=> 'AuthEnvSet EnvVar Format',
	},
	{
		name		=> 'AuthEnvChange',
		args_how	=> Apache2::Const::TAKE2,
		errmsg		=> 'AuthEnvChange EnvVar <subsitution>'
	},
	{
		name		=> 'AuthEnvDenial',
		args_how	=> Apache2::Const::TAKE1,
		errmsg		=> 'AuthEnvDenial <UNAUTHORISED|UNAUTHORIZED|NOT_FOUND|FORBIDDEN>'
	},
	{
		name		=> 'AuthEnvLogInfo',
		args_how	=> Apache2::Const::FLAG,
		errmsg		=> 'AuthEnvLogInfo On/Off',
	},
	{
		name		=> 'AuthEnvLogDebug',
		args_how	=> Apache2::Const::FLAG,
		errmsg		=> 'AuthEnvLogInfo On/Off',
	},
);

# Register the directives.
Apache2::Module::add(__PACKAGE__, \@directives);

# Debugging only.
sub debug { 1; }

# errors.
sub err { warn @_; }

# Log information
sub info { 1; }

# Create an object; not used by mod_perl2
sub new
{
        # Create an object.
	my $this = shift;
	my $class = ref($this) || $this;
	my $self = { };
	bless $self, $class;

	$self;
}

###################### Directives ###########################################

# Set the environment variable to use for authentication
# and set the system to authenticate and authorise.
sub AuthEnvUser
{
	my ($cfg, $parms, $fmt, @args) = @_;

	my $line = join(':', $parms->directive->filename, $parms->directive->line_num);

	# Check that the format contains something to expand.
	# Warn if it's fixed.
	unless ($fmt =~ /%\{.*\}/)
	{
		# NB the request object is not available when called in 
		# global config files (eg httpd.conf).
  		err("AuthEnvUser format '$fmt' has no expansion at $line");

		#return Apache2::Const::HTTP_FORBIDDEN;
	}

	# Loading the configuration handles for auth*.
	# This can be done anywhere so there shouldnever be a problem.
	eval {
            $parms->add_config([
		'PerlAuthenHandler Apache2::AuthEnv::authenticate',
		'PerlAuthzHandler  Apache2::AuthEnv::authorise',
	]);
	};
 	warn "$line: $@" if ($@);

	# Force auth* stages to be done by loading the configuration.
	# May not be allowed in this part of the httpd conf files.
	# So trap!
	eval {
		$parms->add_config([
			'AuthType AuthEnv',
			'Require valid-user',
		]);
	};

	# Should never be a problem because the directive is 
	# restricted to location, directory and .htaccess only.
	# Trap the error.
	if ($@) {
		if ($@ =~ /not allowed/i)
		{
			# Directive not allowed in this part of httpd configuration.
  			warn "AuthEnvUser not allowed here at $line";
		}
		else
		{
			# Unknown failure.
  			warn "AuthEnvUser: $@ at $line";
		}

		exit 2;
	}

	# Save value for user name format.
	$cfg->{AuthEnvUser} = $fmt;

	# Make sure the the user gets set later.
	push @{$cfg->{set}}, ['set', 'REMOTE_USER', $fmt];

	# Initialise the authorise rule list.
	$cfg->{authorise} = ();

	1;
}

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

sub AuthEnvLogDebug
{
	my ($cfg, $parms, $onoff) = @_;

	$cfg->{LogDebug} = $onoff;

	1;
}

###################### End of directives #####################################

# Merge configuration objects together so the the various 
# Apache config files override each other.
sub merge
{
        my ($base, $add) = @_;

	my $merged = new Apache2::AuthEnv;

	# Merge environment variables to set.
	$merged->{set} = $base->{set};
	push @{$merged->{set}}, @{$add->{set}};
	delete $base->{set};
	delete $add->{set};

	for my $k (keys %$base) { $merged->{$k} = $base->{$k}; } 
	for my $k (keys %$add)  { $merged->{$k} = $add->{$k};  }

	$merged;
}

# 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
		no warnings;
		eval 'sub info { 1; };';
	}
	
	# set debugging on or off.
	if (exists $cfg->{LogDebug} && $cfg->{LogDebug})
	{
		# debug on
		no warnings;
		eval 'sub debug { warn @_; };';
	}
	else
	{
		# info off
		no warnings;
		eval 'sub debug { 1; };';
	}

	# Import CGI environment.
	$r->subprocess_env unless $r->is_perl_option_enabled('SetupEnv');

        # expand $AuthEnvUser format; fail if a variable doesn't
        # not exist.

	# Check that AuthEnvUser is set.
	return Apache2::Const::HTTP_UNAUTHORIZED unless exists $cfg->{AuthEnvUser};

	# Set the AE version environment.
	$r->subprocess_env('HTTP_AE_VERSION', $VERSION);

	# Set the environment and the REMOTE_USER along the way.
	for my $s (@{$cfg->{set}})
	{
		my ($act, $v, $f) = @$s;

		# Set an environment variable.
	
		if ($act eq 'dbimport')
		{
			my ($act, $prefix, $file, $var) = @$s;
			my $fail = 0; # count non-existant variables.
			$var =~ s/%\{([^\}]+)\}/&fillout($r, $1, \$fail)/gxe;
			next if $fail;

			# Load user data.
			my $user = dblookup($file, $var);

			# Load the environment.
			for my $k (keys %$user)
			{
				debug("db env key '$k' for URL ", $r->uri);
				$r->subprocess_env($prefix . uc($k), $user->{$k});
			}
		}
		elsif ($act eq 'set')
		{
			my $fail = 0; # count non-existant variables.

			#debug($r->uri, ": change '$f'");

			$f =~ s/%\{([^\}]+)\}/&fillout($r, $1, \$fail)/gxe;

			# something wasn't defined.
			return Apache2::Const::HTTP_UNAUTHORIZED if $fail;

			$r->subprocess_env($v, $f);
		}
		# Change an environment variable.
		elsif ($act eq 'change')
		{
			my $val = $r->subprocess_env($v);

			# Run the modification in a safe environment.
			my $cpt = new Safe;
			${$cpt->varglob('val')} = $val;
			$cpt->reval("\$val =~ $f");

			if ($@)
			{
				# failure to run.
				err("change '$f' failed ($@) ", $r->uri);
				return Apache2::Const::HTTP_UNAUTHORIZED;