File Coverage

SecSess.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

#
# SecSess.pm - Perl module for Apache secure session management
#
# $Id: SecSess.pm,v 1.17 2002/05/22 05:40:33 pliam Exp $
#

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Apache::SecSess
# Copyright (c) 2001, 2002 John Pliam ([e-mail])
# This is open-source software.
# See file 'COPYING' in original distribution for complete details.
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

package Apache::SecSess;
use strict;

use MIME::Base64;
use Apache::Constants qw(:common :response M_GET M_POST);
use Apache::Log;
use Apache::URI;
use Apache::SecSess::Wrapper;

use vars qw($VERSION);

$VERSION = sprintf("%d.%02d", (q$Name: SecSess_Release_0_09 $ =~ /\d+/g));

sub new {
	my $class = shift;
	my $self = {@_};
	bless($self, $class);
	$self->_init;
}

sub _init {
	my $self = shift;

	my $wrapper = Apache::SecSess::Wrapper->new(
		file => $self->{secretFile}
	);
	unless (defined($wrapper)) { die "Cannot instantiate wrapper"; }
	$self->{wrapper} = $wrapper;

	return $self;
}

## authenticate session
sub authen ($$) {
	my($self, $r) = @_;
	my $log = $r->log;
	my($cred, $resp, $msg);

	## don't perform in subrequests
	unless ($r->is_initial_req) { return OK; }

	$log->debug(ref($self), "->authen():");

	$cred = $self->getCredentials($r);
	$resp = $self->validateCredentials($r, $cred);
	if (ref($resp)) {
		if ($msg = $resp->{message}) { $log->info($msg); }
		unless ($resp->{uri}) { return SERVER_ERROR; }
		$r->header_out(Location => $resp->{uri});
		return REDIRECT;
	}
	return OK;
}

## authorize request
sub authz ($$) {
	my($self, $r) = @_;
	my $log = $r->log;
	my($req, $resp, $msg);

	## don't perform in subrequests
	unless ($r->is_initial_req) { return OK; }

	$log->debug(ref($self), "->authz():");

	$req = $self->getRequirements($r);
	$resp = $self->authorizeRequest($r, $req);
	if (ref($resp)) {
		if ($msg = $resp->{message}) { $log->info($msg); }
		if ($resp->{forbidden}) { return FORBIDDEN; }
		unless ($resp->{uri}) { return SERVER_ERROR; }
		$r->header_out(Location => $resp->{uri});
		return REDIRECT;
	}
	return DECLINED;
}

## authenticate user & issue credentials
sub issue ($$) {
	my($self, $r) = @_;
	my $log = $r->log;
	my($resp, $msg);

	## don't perform in subrequests
	unless ($r->is_initial_req) { return OK; }

	$log->debug(ref($self), "->issue():");

	$resp = $self->verifyIdentity($r);
	if (ref($resp)) {
		if ($msg = $resp->{message}) { $log->info($msg); }
		if ($resp->{fill_form}) { return OK; }
		if ($resp->{auth_required}) { return AUTH_REQUIRED; }
		unless ($resp->{uri}) { return SERVER_ERROR; }
		$r->header_out(Location => $resp->{uri});
		return REDIRECT;
	}
	$resp = $self->issueCredentials($r);
	unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
	if ($msg = $resp->{message}) { $log->info($msg); }
	unless ($resp->{uri}) { return SERVER_ERROR; }
	$r->header_out(Location => $resp->{uri});
	return REDIRECT;
}

## renew credentials
sub renew ($$) {
	my($self, $r) = @_;
	my $log = $r->log;
	my($cred, $resp, $msg);

	## don't perform in subrequests
	unless ($r->is_initial_req) { return OK; }

	$log->debug(ref($self), "->renew():");

	$cred = $self->getCredentials($r);
	$resp = $self->validateCredentials($r, $cred);
	unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
	unless ($resp->{renew}) { # make sure credentials are sufficiently fresh
		$log->warn("Timeout before renewal."); # or replay attempt?
		if ($msg = $resp->{message}) { $log->info($msg); }
		unless ($resp->{uri}) { return SERVER_ERROR; }
		$r->header_out(Location => $resp->{uri});
		return REDIRECT;
	}
	$resp = $self->issueCredentials($r);
	unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
	if ($msg = $resp->{message}) { $log->info($msg); }
	unless ($resp->{uri}) { return SERVER_ERROR; }
	$r->header_out(Location => $resp->{uri});
	return REDIRECT;
}

## delete credentials
sub delete ($$) {
	my($self, $r) = @_;
	my $log = $r->log;
	my($resp, $msg);

	## don't perform in subrequests
	unless ($r->is_initial_req) { return OK; }

	$log->debug(ref($self), "->delete():");

	$resp = $self->deleteCredentials($r);
	unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
	if ($msg = $resp->{message}) { $log->info($msg); }
	return OK;
}

## change user ID (only for administrators)
sub changeid ($$) {
	my($self, $r) = @_;
	my $log = $r->log;
	my($cred, $resp, $msg, $uri, $uid);

	## don't perform in subrequests
	unless ($r->is_initial_req) { return OK; }

	$log->debug(ref($self), "->changeid():");

	## admin functions must be explicitly allowed in httpd.conf
	unless ($r->dir_config('SecSess::AllowRemoteAdmin') eq 'true') {
		$log->error('Remote administration not permitted.');
		return FORBIDDEN;
	}

	## get credentials and validate them in usual way
	$cred = $self->getCredentials($r);
	$resp = $self->validateCredentials($r, $cred);
	if (ref($resp)) {
		if ($msg = $resp->{message}) { $log->info($msg); }
		unless ($resp->{uri}) { return SERVER_ERROR; }
		$r->header_out(Location => $resp->{uri});
		return REDIRECT;
	}

	## make sure request is consistent and comes from an administrator
	$resp = $self->verifyAdminRequest($r);
	unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
	if ($msg = $resp->{message}) { $log->info($msg); }
	if ($resp->{forbidden}) { return FORBIDDEN; } # non-admin
	if ($resp->{fill_form}) { return OK; }
	unless ($uid = $resp->{newuid}) {
		unless ($uri = $resp->{uri}) { return SERVER_ERROR; }
		$r->header_out(Location => $uri);
		return REDIRECT;
	}

	## every looks good, set uid and issue new credentials
	$r->user($uid);
	$resp = $self->issueCredentials($r);
	unless (ref($resp)) { $log->error($resp); return SERVER_ERROR; }
	if ($msg = $resp->{message}) { $log->info($msg); }
	unless ($resp->{uri}) { return SERVER_ERROR; }
	$r->header_out(Location => $resp->{uri});
	return REDIRECT;
}

#
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
#		Common Code: methods called from subclasses
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
#

#
# constants (not sure which should be dir_config'd in future ...)
#

## tag and cookie attributes
sub authRealm { my $self = shift; return $self->{authRealm}; }
sub cookieDomain { my $self = shift; return $self->{cookieDomain}; }

## security attributes
sub minSessQOP { my $self = shift; return $self->{minSessQOP}; }
sub minAuthQOP { my $self = shift; return $self->{minAuthQOP}; }
sub sessQOP { my $self = shift; return $self->{sessQOP}; }
sub authQOP { my $self = shift; return $self->{authQOP}; }

## session expiration and timeout attributes
sub lifeTime { my $self = shift; return $self->{lifeTime}; }
sub idleTime { my $self = shift; return $self->{idleTime}; }
sub renewRate { my $self = shift; return $self->{renewRate}; }

## session states
sub authenURL { my $self = shift; return $self->{authenURL}; }
sub defaultURL { my $self = shift; return $self->{defaultURL}; }
sub timeoutURL { my $self = shift; return $self->{timeoutURL}; }
sub renewURL { my $self = shift; return $self->{renewURL}; }
sub errorURL { my $self = shift; return $self->{errorURL}; }
sub issueURL { my $self = shift; return $self->{issueURL}; }
sub chainURLS { my $self = shift; return $self->{chainURLS}; }

## admin form
sub adminURL { my $self = shift; return $self->{adminURL}; }

#
# routines
#

## validate common hash credentials from
sub validateCredentials {
	my $self = shift;
	my($r, $cred) = @_;
	my $log = $r->log;
	my($uri, $requri, $resp, $uid);

    $log->debug(ref($self), "->validateCredentials():");

	## were illegitimate credentials found?
	unless (defined($cred)) { # probably a key-change, treat as timeout
		# but possibly tampering, so log as warning
		$log->warn("Decryption Error");
		$uri = $self->timeoutURL;
		return {
			message => "Decryption failure, redirecting to '$uri'.",
			uri => "$uri?type=notvalid"
		};
	}

	## were any credentials found at all?
	unless (ref($cred)) {
		$uri =  sprintf('%s?url=%s',
			$self->authenURL,
			$self->requested_uri($r)
		);
		return {
			message => "$cred Redirecting to '$uri'",
			uri => $uri
		};
	}

	## set user id for Apache
	$uid = $cred->{uid};
	$log->debug("Setting user ID: '$uid'.");
	$r->user($uid);

	## checksum is good, examine the protection qualities and freshness
	if ($resp = $self->validateQOP($r, $cred)) { return $resp; }
	if ($resp = $self->validateAge($r, $cred)) { return $resp; }

	## user authenticated
	$log->info("User '$uid' authenticated.");
	return undef;
}

## validate quality of protection
sub validateQOP {
	my $self = shift;
	my($r, $cred) = @_;
	my($uri, $requri);

	unless ($cred->{qop} >= $self->minSessQOP) {
		$uri = $self->authenURL;
		$requri = $self->requested_uri($r);
		return {
			message => "Insufficient session protection.",
			uri => "$uri?url=$requri"
		}
	}
	unless ($cred->{authqop} >= $self->minAuthQOP) {
		$uri = $self->authenURL;
		$requri = $self->requested_uri($r);
		return {
			message => "Insufficient authentication protection.",
			uri => "$uri?url=$requri"
		}
	}

	return undef;
}

## validated time stamp
sub validateAge {
	my $self = shift;
	my($r, $cred) = @_;
	my($life, $idle, $renew, $uid, $ts, $t, $uri, $requri);

	## get object timing constants
	$life =  $self->lifeTime;
	$idle =  $self->idleTime;
	$renew = $self->renewRate;

	## check times
	$uid = $cred->{uid};
	$ts = $cred->{timestamp};
	$t = time;
	$r->log->debug(sprintf(
		"validateAge(): uid = '%s', time - ts = %.02f (min):"
			. " vs renew = %d, idle = %d, life = %d",
		$uid, ($t-$ts)/60.0, $renew, $idle, $life
	));
	if ($t > $ts + 60*$life) { # hard timeout
		$uri = $self->timeoutURL;
		return {
			message => "Expired, redirecting '$uid' to '$uri?type=expire'.",
			uri => "$uri?type=expire"
		};
	}
	if ($t > $ts + 60*($idle+$renew)) { # idle timeout
		$uri = $self->timeoutURL;
		return {
			message => "Cookie idle too long '$uid'.",
			uri => "$uri?type=idle"
		};
	}
	if ($t > $ts + 60*$renew) { # renew
		$uri = $self->renewURL;
		$requri = $self->requested_uri($r);
		return {
			message => "Renewing credentials for user '$uid'.",
			renew => 'true',
			uri => "$uri?url=$requri"
		};
	}

	return undef;
}

## get requirements
sub getRequirements {
	my $self = shift;
	my($r) = @_;
	return $r->requires;
}

## authorize request
sub authorizeRequest {
	my $self = shift;
	my($r, $req) = @_;

	return undef;
}

#
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# 		Utilities
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
#

## extract the requested URI as base64 wrapped
sub requested_uri {
	my $self = shift;
	my($r) = @_;
	my($u, %args, $requrl);

	%args = $r->args;
	unless ($requrl = $args{url}) { # will already be wrapped
		$u = Apache::URI->parse($r);
		$requrl = $self->wrap_uri($u->unparse);
	}
	return $requrl;
}

## (un)wrap a URI, with more armor than Apache::Util::escape_uri
sub wrap_uri {
	my $self = shift;
	my($u) = @_;
	$u = encode_base64($u, '');
    $u =~ tr/\+\/\=/-._/;
	return $u;
}
sub unwrap_uri {
	my $self = shift;
	my($u) = @_;
    $u =~ tr/\-\.\_/+\/=/;
	return decode_base64($u);
}

1;

__END__