view release on metacpan or  search on metacpan

SecSess.pm  view on Meta::CPAN

	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
#