File Coverage

blib/lib/Apache/AuthCookie.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Apache::AuthCookie;

use strict;

use Carp;
use CGI::Util ();
use mod_perl qw(1.07 StackedHandlers MethodHandlers Authen Authz);
use Apache::Constants qw(:common M_GET M_POST FORBIDDEN REDIRECT);
use vars qw($VERSION);

# $Id: AuthCookie.pm,v 2.16 2001/06/01 15:50:27 mschout Exp $
$VERSION = '3.00';

sub recognize_user ($$) {
  my ($self, $r) = @_;
  my $debug = $r->dir_config("AuthCookieDebug") || 0;
  my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);
  return unless $auth_type && $auth_name;
  return unless $r->header_in('Cookie');

  my ($cookie) = $r->header_in('Cookie') =~ /${auth_type}_${auth_name}=([^;]+)/;
  $r->log_error("cookie ${auth_type}_${auth_name} is $cookie") if $debug >= 2;
  return unless $cookie;

  if (my ($user) = $auth_type->authen_ses_key($r, $cookie)) {
    $r->log_error("user is $user") if $debug >= 2;
    $r->connection->user($user);
  }
  return OK;
}


sub login ($$) {
  my ($self, $r) = @_;
  my $debug = $r->dir_config("AuthCookieDebug") || 0;

  my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);
  my %args = $r->method eq 'POST' ? $r->content : $r->args;
  unless (exists $args{'destination'}) {
    $r->log_error("No key 'destination' found in posted data");
    return SERVER_ERROR;
  }

  # Get the credentials from the data posted by the client
  my @credentials;
  while (exists $args{"credential_" . ($#credentials + 1)}) {
    $r->log_error("credential_" . ($#credentials + 1) . " " .
		  $args{"credential_" . ($#credentials + 1)}) if ($debug >= 2);
    push(@credentials, $args{"credential_" . ($#credentials + 1)});
  }

  # Exchange the credentials for a session key.
  my $ses_key = $self->authen_cred($r, @credentials);
  $r->log_error("ses_key " . $ses_key) if ($debug >= 2);

  $self->send_cookie($ses_key);

  if ($r->method eq 'POST') {
    $r->method('GET');
    $r->method_number(M_GET);
    $r->headers_in->unset('Content-Length');
  }
  unless ($r->dir_config("${auth_name}Cache")) {
    $r->no_cache(1);
    $r->err_header_out("Pragma" => "no-cache");
  }
  $r->header_out("Location" => $args{'destination'});
  return REDIRECT;
}

sub logout($$) {
  my ($self,$r) = @_;
  my $debug = $r->dir_config("AuthCookieDebug") || 0;

  my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);

  # Send the Set-Cookie header to expire the auth cookie.
  my $str = $self->cookie_string( request => $r,
											 key     => "$auth_type\_$auth_name",
								          value 	=> '',
											 expires => 'Mon, 21-May-1971 00:00:00 GMT' );
  $r->err_headers_out->add("Set-Cookie" => "$str");
  $r->log_error("set_cookie " . $r->err_header_out("Set-Cookie")) if $debug >= 2;
  unless ($r->dir_config("${auth_name}Cache")) {
    $r->no_cache(1);
    $r->err_header_out("Pragma" => "no-cache");
  }

  #my %args = $r->args;
  #if (exists $args{'redirect'}) {
  #  $r->err_header_out("Location" => $args{'redirect'});
  #  return REDIRECT;
  #} else {
  #  $r->status(200);
  #  return OK;
  #}
}

sub authenticate ($$) {
  my ($auth_type, $r) = @_;
  my ($authen_script, $auth_user);
  my $debug = $r->dir_config("AuthCookieDebug") || 0;

  $r->log_error("auth_type " . $auth_type) if ($debug >= 3);
  return OK unless $r->is_initial_req; # Only authenticate the first internal request

  if ($r->auth_type ne $auth_type) {
    # This location requires authentication because we are being called,
    # but we don't handle this AuthType.
    $r->log_error("AuthType mismatch: $auth_type =/= ".$r->auth_type) if $debug >= 3;
    return DECLINED;
  }

  # Ok, the AuthType is $auth_type which we handle, what's the authentication
  # realm's name?
  my $auth_name = $r->auth_name;
  $r->log_error("auth_name " . $auth_name) if $debug >= 2;
  unless ($auth_name) {
    $r->log_reason("AuthName not set, AuthType=$auth_type", $r->uri);
    return SERVER_ERROR;
  }

  # Get the Cookie header. If there is a session key for this realm, strip
  # off everything but the value of the cookie.
  my ($ses_key_cookie) = ($r->header_in("Cookie") || "") =~ /$auth_type\_$auth_name=([^;]+)/;
  $ses_key_cookie = "" unless defined($ses_key_cookie);

  $r->log_error("ses_key_cookie " . $ses_key_cookie) if ($debug >= 1);
  $r->log_error("uri " . $r->uri) if ($debug >= 2);

  if ($ses_key_cookie) {
    if ($auth_user = $auth_type->authen_ses_key($r, $ses_key_cookie)) {
      # We have a valid session key, so we return with an OK value.
      # Tell the rest of Apache what the authentication method and
      # user is.

      $r->connection->auth_type($auth_type);
      $r->connection->user($auth_user);
      $r->log_error("user authenticated as $auth_user")	if $debug >= 1;

		# Returning $TICKET to the environment so you can customize webpages
		# Based on authentication level.
		$r->subprocess_env('TICKET', $ses_key_cookie);

      return OK;
    } else {
      # There was a session key set, but it's invalid for some reason. So,
      # remove it from the client now so when the credential data is posted
      # we act just like it's a new session starting.

      my $str = $auth_type->cookie_string(
		  request => $r,
		  key     => "$auth_type\_$auth_name",
		  value   => '',
		  expires => 'Mon, 21-May-1971 00:00:00 GMT'
		);
      $r->err_headers_out->add("Set-Cookie" => "$str");
      $r->log_error("set_cookie " . $r->err_header_out("Set-Cookie")) if $debug >= 2;
		#$r->subprocess_env('AuthCookieReason', 'Bad Cookie');

		# Instead of 'Bad Cookie', lets return something more useful.
		# $ses_key_cookie has a unique value if ERROR, but undef if ! ERROR.
      $r->subprocess_env('AuthCookieReason', $ses_key_cookie) if $ses_key_cookie =~ /ERROR/;
		$r->subprocess_env('AuthCookieReason', 'ERROR! Your session has expired, or your login does not have the proper access level for this webpage.') if $ses_key_cookie !~ /ERROR/;
    }
  } else {
	 #$r->subprocess_env('AuthCookieReason', 'no_cookie');

	 # Instead of 'no_cookie, let's return something more useful.
    $r->subprocess_env('AuthCookieReason', 'Please enter your user name and password.');
  }

  # They aren't authenticated, and they tried to get a protected
  # document.  Send them the authen form.
  return $auth_type->login_form;
}


sub login_form {
  my $r = Apache->request or die "no request";
  my $auth_name = $r->auth_name;

  # There should be a PerlSetVar directive that gives us the URI of
  # the script to execute for the login form.

  my $authen_script;
  unless ($authen_script = $r->dir_config($auth_name . "LoginScript")) {
    $r->log_reason("PerlSetVar '${auth_name}LoginScript' not set", $r->uri);
    return SERVER_ERROR;
  }
  #$r->log_error("Redirecting to $authen_script");
  $r->custom_response(FORBIDDEN, $authen_script);

  return FORBIDDEN;
}

sub authorize ($$) {
  my ($auth_type, $r) = @_;
  my $debug = $r->dir_config("AuthCookieDebug") || 0;

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

  if ($r->auth_type ne $auth_type) {
    $r->log_error($auth_type . " auth type is " .
		  $r->auth_type) if ($debug >= 3);
    return DECLINED;
  }

  my $reqs_arr = $r->requires or return DECLINED;

  my $user = $r->connection->user;
  unless ($user) {
    # user is either undef or =0 which means the authentication failed
    $r->log_reason("No user authenticated", $r->uri);
    return FORBIDDEN;
  }

  my ($forbidden);
  foreach my $req (@$reqs_arr) {
    my ($requirement, $args) = split /\s+/, $req->{requirement}, 2;
    $args = '' unless defined $args;
    $r->log_error("requirement := $requirement, $args") if $debug >= 2;

    next if $requirement eq 'valid-user';
    if($requirement eq 'user') {
      next if $args =~ m/\b$user\b/;
      $forbidden = 1;
      next;
    }

    # Call a custom method
    my $ret_val = $auth_type->$requirement($r, $args);
    $r->log_error("$auth_type->$requirement returned $ret_val") if $debug >= 3;
    next if $ret_val == OK;

    # Nothing succeeded, deny access to this user.
    $forbidden = 1;
    last;
  }
   #return $forbidden ? FORBIDDEN : OK;

   # Was returning generic Apache FORBIDDEN here.  We want to return to login.pl with error message.
   $r->subprocess_env('AuthCookieReason', 'ERROR! Your login does not have the proper permission for this webpage.') if $forbidden;
 	$r->log_error("AuthCookie, ERROR! Login not in list for this directory using require user ...") if $forbidden;
   return $auth_type->login_form if $forbidden;

   return OK;
}

sub send_cookie {
  my ($self, $ses_key) = @_;
  my $r = Apache->request();

  my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);
  my $cookie = $self->cookie_string( request => $r,
											    key     => "$auth_type\_$auth_name",
												 value   => $ses_key );
  $r->err_header_out("Set-Cookie" => $cookie);
}

sub cookie_string {
  my $self = shift;

  # if passed 3 args, we have old-style call.
  if (scalar(@_) == 3) {
    carp "deprecated old style call to ".__PACKAGE__."::cookie_string()";
    my ($r, $key, $value) = @_;
    return $self->cookie_string(request=>$r, key=>$key, value=>$value);
  }
  # otherwise assume named parameters.
  my %p = @_;
  for (qw/request key/) {
    croak "missing required parameter $_" unless defined $p{$_};
  }
  # its okay if value is undef here.

  my $r = $p{request};

  my $string = sprintf '%s=%s', @p{'key','value'};

  my $auth_name = $r->auth_name;

  if (my $expires = $p{expires} || $r->dir_config("${auth_name}Expires")) {
    $expires = CGI::Util::expires($expires);
    $string .= "; expires=$expires";
  }

  if (my $path = $r->dir_config("${auth_name}Path")) {
    $string .= "; path=$path";
  }
  #$r->log_error("Attribute ${auth_name}Path not set") unless $path;

  if (my $domain = $r->dir_config("${auth_name}Domain")) {
    $string .= "; domain=$domain";
  }

  $string .= '; secure' if $r->dir_config("${auth_name}Secure");

  return $string;
}

sub key {
  my $self = shift;
  my $r = Apache->request;

  my $allcook = ($r->header_in("Cookie") || "");
  my ($type, $name) = ($r->auth_type, $r->auth_name);
  return ($allcook =~ /(?:^|\s)${type}_$name=([^;]*)/)[0];
}

1;

__END__