view release on metacpan or  search on metacpan

SecSess/Cookie.pm  view on Meta::CPAN

#
# Cookie.pm - Apache::SecSess encrypted cookie implementation
#
# $Id: Cookie.pm,v 1.15 2002/05/22 05:40:33 pliam Exp $
#

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

package Apache::SecSess::Cookie;
use strict;

use Apache::Constants qw(:common :response);
use Apache::SecSess;
use Apache::SecSess::Wrapper;

use vars qw(@ISA $VERSION);

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

@ISA = qw(Apache::SecSess);

## extract appropriate cookie from headers and decrypt contents
sub getCredentials {
	my $self = shift;
	my($r) = @_;
	my $log = $r->log;
	my($realm, $ckyhead, %ckys, @tags, $max);

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

	## extract strongest cookie with appropriate name/tag pair
	$realm = $self->authRealm;
	$ckyhead = $r->headers_in->get('Cookie');
	%ckys = ($ckyhead =~ /${realm}:([^=]+)=([^;]+)/g);
	@tags = sort {
		my($as, $aa) = split(',', $a);
		my($bs, $ba) = split(',', $b);
		return ($bs <=> $as) ? ($bs <=> $as) : ($ba <=> $aa);
	} (keys %ckys);
	$max = $tags[0];
	unless (defined($max)) { return 'No cookie found.'; }
	$log->debug(sprintf("Found Cookie: %s:%s=%s", $realm, $max, $ckys{$max}));

	return $self->{wrapper}->unwraphash($ckys{$max});
}

## validate (usually non-cookie) credentials used to authenicate user
sub verifyIdentity { my $self = shift; return undef }

## issue cookies
sub issueCredentials {
	my $self = shift;
	my($r) = @_;
	my $log = $r->log;
	my(@cky, %args, $url);

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

	## put credentials into headers
	for (@cky = $self->setCookies($r)) {
		$r->err_headers_out->add('Set-Cookie' => $_);
	}

	## form target URL and response
	%args = $r->args;
	$url = $self->unwrap_uri($args{url}) || $self->defaultURL;
	$log->debug("redirect url (after cookies) = ", $url, " args{url}: ", 
		$args{url});
	unless ($url) { return 'No place to go (no defaultURL set).'; }
	return {
		message => sprintf("Issuing cookies for user '%s': ('%s')",
			$r->user,
			join("','", @cky)
		),
		uri => $url
	};
}

## delete cookies
sub deleteCredentials {
	my $self = shift;
	my($r) = @_;
	my $log = $r->log;
	my(@ckys);

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

	## form delete-me cookies
	for (@ckys = $self->deleteCookies) {
	#	$r->header_out('Set-Cookie' => $_); why if no redirect?
        $r->err_headers_out->add('Set-Cookie' => $_);
	}
	unless (@ckys) { return "No cookies to delete."; }
	return {
		message => sprintf("Deleting cookies for '%s': Set-Cookie: ('%s')", 
			$r->user, join("','", @ckys)
		)
	};
}

## make all HTTP cookie headers
sub setCookies {
	my $self = shift;
	my($r) = @_;
	my($time, $uid, $realm, $ckydom, $dom, $s, $a, @ckys);

	$time = time;
	$uid = $r->user;
	$realm = $self->authRealm;
	$ckydom = $self->cookieDomain;
	for (keys %$ckydom) {
		$dom = $ckydom->{$_};
		($s, $a) = split(',');
		$a = defined($a) ? $a : $s;
		push(@ckys, $self->makeCookie(
			"$realm:$s,$a",
			{uid => $uid, timestamp => $time, qop => $s, authqop => $a},
			{path => '/', domain => $dom, secure => $s}
		));