view release on metacpan or  search on metacpan

AuthzCache.pm  view on Meta::CPAN

  my $require_groups = undef;

  # Get configuration
  my $casesensitive = $r->dir_config('AuthzCache_CaseSensitive') || 'on';
  my $cache_time_limit = $r->dir_config('AuthzCache_CacheTime') ||
    $r->dir_config('AuthzCache_Timeout') || $Cache::Cache::EXPIRES_NEVER;
  my $cache_dir = $r->dir_config('AuthzCache_Directory') || '/tmp';
  my $cache_umask = $r->dir_config('AuthzCache_Umask') || '007';
  my $auth_name = $r->auth_name;
  my $requirement = $r->dir_config('AuthzRequire') || 'inAGroup';
  $r->log->debug("manage_cache: cache_time_limit=$cache_time_limit, ",
		 "cache_dir=$cache_dir, cache_umask=$cache_umask, ",
		 "auth_name=$auth_name");
  $requirement = REQUIRE_OPTS->{lc($requirement)} || 1;

  # Get username
  my $user_sent = $r->connection->user;
  $r->log->debug("handler: username=$user_sent");

  # Clear for paranoid security precautions
  $r->subprocess_env(REMOTE_GROUP => undef);
  undef($r->headers_in->{'REMOTE_GROUP'});
  $r->notes('AuthzCache' => undef);

  # Get required groups
  for my $req (@$requires) {
    my ($require, $rest) = split /\s+/, $req->{requirement}, 2;
    if ($require eq "user") { return OK
                                if grep $user_sent eq $_, split /\s+/, $rest }
    elsif ($require eq "valid-user") { return OK }
    elsif ($require eq 'group') {
      @$require_groups = Text::ParseWords::parse_line('\s+', 0, $rest);
    }
  }

  # Do we want Windows-like case-insensitivity?
  if ($casesensitive eq 'off') {
    $user_sent = lc($user_sent);
  }

  # Create the cache if needed
  my $cache = Cache::FileCache->new({ namespace          => $auth_name,
				      default_expires_in => $cache_time_limit,
				      cache_root         => $cache_dir,
				      directory_umask    => $cache_umask });
  my $user_groups = $cache->get($user_sent);

  # Is the user in the cache
  if ($user_groups) {
    $r->log->debug("handler: using cached groups for $user_sent");

    my $success_groups = '';
  OUTTER: foreach my $req_group (@$require_groups) {
      my $succeeded = 0;
    INNER: foreach my $user_group (@$user_groups) {
	$r->log->debug("handler: comparing $req_group to $user_group");
	if ($casesensitive eq 'off' &&
	    lc($req_group) eq lc($user_group)) {
	  # Password matches so end stage
	  # The required patch was not introduced in 1.26. It is no longer
	  # promised to be included in any timeframe. Commenting out.
	  # if ($mod_perl::VERSION < 1.26) {
	    # Since set_handlers() doesn't work properly until
	    # 1.26 (according to Doug MacEachern) I have to work
	    # around it by cobbling together cheat sheets for the
	    # subsequent handlers in this phase. I get the
	    # willies about the security implications in a
	    # general environment where you might be using
	    # someone else's handlers upstream or downstream...
	  $r->log->debug("handler: user in cache and case-insensitive ",
			 "groups $req_group and $user_group match; ",
			 "appending to success list");
	  if ($requirement == 1) {
	    $r->subprocess_env(REMOTE_GROUP => $user_group);
	    $r->headers_in->{'REMOTE_GROUP'} = $user_group;
	    $r->notes('AuthzCache' => 'hit');
	    return OK;
	  } else {
	    $success_groups .= "\"$user_group\" ";
	    $succeeded = 1;
	    last INNER;
	  }
	  # } else {
	  #  $r->log->debug("handler: user in cache and case-insensitive ",
	  # 		   "groups $req_group and $user_group match; ",
	  #		   "returning OK and clearing PerlAuthzHandler");
	  #  $r->set_handlers(PerlAuthzHandler => undef);
	  #}
	} elsif ($req_group eq $user_group) {
	  # Password matches so end stage
	  # The required patch was not introduced in 1.26. It is no longer
	  # promised to be included in any timeframe. Commenting out.
	  # if ($mod_perl::VERSION < 1.26) {
	    # Since set_handlers() doesn't work properly until
	    # 1.26 (according to Doug MacEachern) I have to work
	    # around it by cobbling together cheat sheets for the
	    # subsequent handlers in this phase. I get the
	    # willies about the security implications in a
	    # general environment where you might be using
	    # someone else's handlers upstream or downstream...
	  $r->log->debug("handler: user in cache and case-sensitive ",
			 "groups $req_group and $user_group match; ",
			 "appending to success list");
	  if ($requirement == 1) {
	    $r->subprocess_env(REMOTE_GROUP => $user_group);
	    $r->headers_in->{'REMOTE_GROUP'} = $user_group;
	    $r->notes('AuthzCache' => 'hit');
	    return OK;
	  } else {
	    $success_groups .= "\"$user_group\" ";
	    $succeeded = 1;
	    last INNER;
	  }
	  # } else {
	  #  $r->log->debug("handler: user in cache and case-insensitive ",
	  # 		   "groups $req_group and $user_group match; ",
	  #		   "returning OK and clearing PerlAuthzHandler");
	  #  $r->set_handlers(PerlAuthzHandler => undef);
	  #}
	} # IF
      } # INNER
      if ($requirement == 3 && !$succeeded) {
	$r->log->debug("handler: group $req_group not in cache for ",
		       "inAllGroups requirement; returning DECLINED");
	return DECLINED;
      }
      $succeeded = 0;
    } # OUTTER
    if ($success_groups ne '') {
      chop($success_groups);
      $r->log->debug("handler: user in cache; returning OK and setting ",
		     "environment to $success_groups and notes");
      $r->subprocess_env(REMOTE_GROUP => $success_groups);
      $r->headers_in->{'REMOTE_GROUP'} = $success_groups;
      $r->notes('AuthzCache' => 'hit');
      return OK;
    }
  } # USER_GROUPS

  # User not in cache
  $r->log->debug("handler: user/group not in cache; returning DECLINED");
  return DECLINED;
}

###############################################################################
###############################################################################
# manage_cache: insert new entries into the cache
###############################################################################
###############################################################################
sub manage_cache {
  my $r = shift;
  return OK unless $r->is_initial_req; # only the first internal request
  my $requires = $r->requires;
  return OK unless $requires;

  # Get username
  my $user_sent = $r->connection->user;

  # Get required groups and proceed with caching only if groups were required
  for my $req (@$requires) {
    my ($require, $rest) = split /\s+/, $req->{requirement}, 2;
    if ($require eq "user") { return OK
                                if grep $user_sent eq $_, split /\s+/, $rest }
    elsif ($require eq "valid-user") { return OK }
  }

  my ($group_sent, $cache_result) = undef;
  # The required patch was not introduced in 1.26. It is no longer
  # promised to be included in any timeframe. Commenting out.
  # if ($mod_perl::VERSION < 1.26) {
    # I shouldn't need to use the below lines as this module
    # should never be called if there was a cache hit.  Since
    # set_handlers() doesn't work properly until 1.26 (according
    # to Doug MacEachern) I have to work around it by cobbling
    # together cheat sheets for the previous handlers in this
    # phase. I get the willies about the security implications in
    # a general environment where you might be using someone
    # else's handlers upstream or downstream...
  $group_sent = $r->subprocess_env("REMOTE_GROUP") ||
    $r->headers_in->{'REMOTE_GROUP'};
  $cache_result = $r->notes('AuthzCache');
  if ($group_sent && $cache_result eq 'hit') {
    $r->log->debug("manage_cache: upstream cache hit for ",
		   "username=$user_sent, group=$group_sent");
    return OK;
  # }
  }

  # Get configuration
  my $casesensitive = $r->dir_config('AuthzCache_CaseSensitive') || 'on';
  my $cache_time_limit = $r->dir_config('AuthzCache_CacheTime') ||
    $r->dir_config('AuthzCache_Timeout') || $Cache::Cache::EXPIRES_NEVER;
  my $cache_dir = $r->dir_config('AuthzCache_Directory') || '/tmp';
  my $cache_umask = $r->dir_config('AuthzCache_Umask') || '007';
  my $auth_name = $r->auth_name;
  $r->log->debug("manage_cache: cache_time_limit=$cache_time_limit, ",
		 "cache_dir=$cache_dir, cache_umask=$cache_umask, ",
		 "auth_name=$auth_name");

  # Do we want Windows-like case-insensitivity?
  if ($casesensitive eq 'off') {
    $user_sent = lc($user_sent);
    $group_sent = lc($group_sent);
  }

  # Add groups to the cache
  my $groups = []; # perl-5.8 chokes on declaring an array dereference
  @$groups = Text::ParseWords::parse_line('\s+', 0, $group_sent);
  my $cache = Cache::FileCache->new({ namespace          => $auth_name,
				      default_expires_in => $cache_time_limit,
				      cache_root         => $cache_dir,
				      directory_umask    => $cache_umask });
  my $user_groups = $cache->get($user_sent);
  if (ref($user_groups)) {
    $cache->set($user_sent, [(@{$groups}, @{$user_groups})], $cache_time_limit);
  } else {
    $cache->set($user_sent, $groups, $cache_time_limit);
  }
  $r->log->debug("manage_cache: added $user_sent:$group_sent to the cache");

  return OK;
}

if (Apache->module("Apache::Status")) {
  Apache::Status->menu_item('AuthzCache' => 'AuthzCache Menu Item',
			    \&status_menu);
}

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