File Coverage

blib/lib/CAS/Apache/Auth.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package CAS::Apache::Auth;

use warnings FATAL => 'all', NONFATAL => 'redefine';
use strict;

=head1 NAME

CAS::Apache::Auth - The great new CAS::Apache::Auth!

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';
#use Apache2::RequestRec ();
#  use Apache2::RequestIO ();

# AUTH_REQUIRED DECLINED DONE FORBIDDEN NOT_FOUND OK REDIRECT SERVER_ERROR
use Apache2::Const qw(OK AUTH_REQUIRED FORBIDDEN HTTP_UNAUTHORIZED);

use Apache2::Access ();
use Apache2::RequestUtil ();
use base qw(CAS::Apache CAS);
use CGI ();
use Apache2::Response ();

=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use CAS::Apache::Auth;

    my $foo = CAS::Apache::Auth->new();
    ...

=head1 METHODS

=head2 function1

=cut

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self  = $class->SUPER::new(@_);

	# now, db caching doesn't work well in mod_perl as is - generates a lot
	# of 'Commands out of sync' errors
	$self->{dbh} = undef;

	return $self;
} # new


# because this package doesn't cache the db connection itself, depending on
# ApACHE::DBI to do it, we need to have a local version of the dbh method to
# reconnect
sub dbh {
	my $self = shift;
	return &{$self->{cas_db_connect}};
} # dbh


sub authen {
	my $self = shift;
	my $r = shift;
	my $user = shift || '';
	my $password = shift || '';
	$self->gripe("Apache::Auth::authen called");

	my $cookie_name = $self->client->{Cookie_Name};
	my $cookies = my $session_key = undef;
	$cookies = $r->headers_in->{Cookie} || '';
	if ($cookies =~ /$cookie_name=(\w{32})/) {
		$session_key = $1;
		$self->gripe("User already logged in: $cookie_name=$session_key");
		return OK;
	} # if key, assume user logged in, let authz do the rest

	unless ($user && $password) {
		my $base_cas_dir = $r->dir_config('CAS_BASE_URI') || '';
		my $request = $r->unparsed_uri;
		my $login = "/$base_cas_dir/public/login?return=$request";
		$r->custom_response(AUTH_REQUIRED, $login);
		$self->gripe("No username or password provided - send to login page: "
			. $login);
		return AUTH_REQUIRED;
	} # if no username or password provided, send to login page

	my $rem_ip = $r->connection->remote_ip;

	warn "Authenticating: USERNAME => $user, PASSWORD => $password, IP => $rem_ip";
	$session_key = $self->authenticate({USERNAME => $user,
		PASSWORD => $password, IP => $rem_ip});

	unless (defined $session_key) {
		# get messages and throw error - really this should go to custom page
		my $messages = $self->messages;
		$r->note_auth_failure;
		$self->gripe("Authen failed: $messages");
		return HTTP_UNAUTHORIZED;
	} # unless authentication succeeded

	# we set the cookie in err headers in case of internal redirect
	$r->err_headers_out->add('Set-Cookie' => "$cookie_name=$session_key; PATH=/");
	$self->gripe("User autheticated, Set-Cookie $cookie_name=$session_key");

	$self->_clear_result;
	return OK;
}


sub authz {
	my $self = shift;
	my $r = shift;
	return OK unless $r->is_initial_req;

	my $base_dir = $r->dir_config('CAS_BASE_URI') || '';
	my $request = $r->uri;
	my $full_request = $r->unparsed_uri;
	# what if it isn't under /public?!
	my $login = "/$base_dir/public/login?return=$full_request";
	$r->custom_response(AUTH_REQUIRED, $login);

	my $cookie_name = $self->client->{Cookie_Name};
	my $cookies = $r->headers_in->{Cookie} || '';
	$cookies    =~ /$cookie_name=(\w{32})/;
	my $session_key  = $1 || '';
	$self->gripe("cookies = $cookies");

	unless ($session_key) {
		# check header in case initial auth/internal redirect
		$session_key = $r->headers_out->{'Set-Cookie'};

		# need to check err_headers separately?

		if ($session_key) {
			$session_key =~ /$cookie_name=(\w*)/;
			$session_key  = $1 || '';
		} # must be first authz after authen

		else {
			my $CGI = new CGI;
			my %params = $CGI->Vars;
			$session_key = $params{$cookie_name};
		} # not internal redirect, get desperate and check CGI param?

		$self->gripe("cookie_name $cookie_name found $session_key.")
			if $self->debug;

		unless ($session_key) {
			$self->gripe("No cookie named $cookie_name found.");
			return AUTH_REQUIRED;
		} # if no session key, have user log in
	} # if no cookie

	# Some s may be configured so that all files under that location
	# need only to check against a single resource.
	my $there_is_only_one = $r->dir_config('SinglePermissionTree') || 0;
	if ($there_is_only_one) { $request = $base_dir }

	# And still other s may want to use only the top level file or
	# subdirectory. This could be useful for handlers or pages that parse the
	# remainder of the URL as arguments, or where the subdirectoires are all
	# assigned to individual users, who own everything therein
	my $down_one_only = $r->dir_config('OneStepOnly') || 0;
	if ($down_one_only) {
		$request =~ s{$base_dir(/[^/]+).+}{$base_dir$1};
	} # filter out sub'directories'

	my $rem_ip = $r->connection->remote_ip;
	warn "Authorizing: SESSION => $session_key, RESOURCE => $request, MASK => 8, IP => $rem_ip";
	my $is_authorized = $self->authorize({SESSION => $session_key,
		RESOURCE => $request, MASK => 8, IP => $rem_ip, DEBUG => 1});
	$self->gripe("SESSION => $session_key, "
		. "RESOURCE => $request, MASK => 8, IP => $rem_ip");

	unless (defined $is_authorized){
		# Check if authorization indicates new authentication required (like
		# if the session timed out
		my $messages = $self->messages;
		if ($self->response_is('AUTH_REQUIRED')) {
			$r->err_headers_out->set('Set-Cookie' => "$cookie_name=; PATH=/");
			$self->gripe("authorization returned AUTH_REQUIRED: $messages")
				if $self->debug;
			$self->_clear_result;
			return AUTH_REQUIRED;
		} # if authen needed

		$self->gripe("Authorization failed: $messages");
		$self->_clear_result;
		return FORBIDDEN;
	}

	$self->_clear_result;
	return OK;
} # authz



=head1 AUTHOR

Sean P. Quinlan, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc CAS::Apache

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * RT: CPAN's request tracker

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2006 Sean P. Quinlan, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of CAS::Apache::Auth