TicketTool

package Apache2::TicketTool;
# usage : my $ticketTool = Apache2::TicketTool->new($r);

# Ne pas faire attention aux commentaires fantaisistes

use strict;

use Apache2::RequestRec qw(user);
use Apache2::Access (); 
use Apache2::ServerUtil ();
use Apache2::Reload;
use Apache2::Const 	-compile => qw(:log OK);
use Apache2::Log ();
use Apache2::URI qw(parse uri);

use CGI::Cookie ();
use Cluster::ClusterLoader;



my %DEFAULTS = 
	(
 	'TicketExpires'  => 30,
	# 'TicketSecret'   => 'http://www.alliancemca.com/secret_key.txt',
 	'TicketDomain'   => undef,
 	);

my %CACHE;  # cache objects by their parameters to minimize time-consuming operations

# Set up default parameters by passing in a request object
sub new 
	{
	my($class, $r) = @_;
	my %self = ();
	foreach (keys %DEFAULTS) 
		{
		$self{$_} = $r->dir_config($_) || $DEFAULTS{$_};
		}
# post-process TicketDatabase and TicketDomain
	unless ( $self{TicketDomain} )
		{
		($self{TicketDomain} = $r->server->server_hostname) =~ s/^[^.]+//;
		}
# try to return from cache
	$self{ServerName} = $r->server->server_hostname;
	my $id = join '', sort values %self;
	return $CACHE{$id} if $CACHE{$id};
# otherwise create new object
	return $CACHE{$id} = bless \%self, $class;
	} 

# TicketTool::authenticate()
# ($result,$explanation) = $ticketTool->authenticate($user,$passwd)
sub authenticate 
	{
	my($self, $user, $passwd) = @_;

	my $entite =Cluster::Entite->retrieve(
			email	 => $user, 
			passwd => $passwd, 
			domain => $self->{TicketDomain},
			);	
	unless (defined $entite)
		{return (undef, "password mismatch");}

	return (1, '');
	}

# TicketTool::fetch_secret()
# Call as:
# $ticketTool->fetch_secret();
sub fetch_secret 
	{
	my $self = shift;
	unless ($self->{SECRET_KEY}) 
		{
		$self->{SECRET_KEY} =  "hlaghlaghlaghlag";
		}
	$self->{SECRET_KEY};
	}

# invalidate the cached secret
sub invalidate_secret { undef shift->{SECRET_KEY}; }

# TicketTool::make_ticket()
# Call as:
# $cookie = $ticketTool->make_ticket($r);
#
sub make_ticket 
	{
	my($self, $r, $user_name) = @_;
	my $ip_address = $r->connection->remote_ip;
	my $expires = $self->{TicketExpires};
	my $now = time;
	my $secret = $self->fetch_secret() or return undef;
# SHAKE IT... 
	my $hash = MD5->hexhash($secret .
			MD5->hexhash(join ':', $secret, $ip_address, $now,
				$expires, $user_name)
			);
# ...BEFORE YOU BAKE IT !
	return CGI::Cookie->new(-name => 'Ticket',
			-path => '/',
			-domain => $self->{TicketDomain},
			-value => {
			'ip' => $ip_address,
			'time' => $now,
			'user' => $user_name,
			'hash' => $hash,
			'expires' => $expires,
			});
	}


# TicketTool::verify_ticket()
# ($result,$msg) = $ticketTool->verify_ticket($r)
sub verify_ticket 
	{
	my($self, $r) = @_;
	my %cookies = CGI::Cookie->parse($r->headers_in('Cookie'));
# Got cookies ?
	unless (%cookies)
		{
		return (0, 'user has no cookies');
		}
	unless ($cookies{'Ticket'})
		{
		return (0, 'user has no ticket')
		}
# Now we have a ticket
	my %ticket = $cookies{'Ticket'}->value;
	unless ( $ticket{'hash'} && $ticket{'user'} && $ticket{'time'} && $ticket{'expires'} )
		{	
		return (0, 'malformed ticket')
		}
	unless ($ticket{'ip'} eq $r->connection->remote_ip)
		{
		return (0, 'IP address mismatch in ticket')
		}
	unless ( (time - $ticket{'time'})/60 < $ticket{'expires'})
		{
		return (0, 'ticket has expired')
		}
	my $secret;
	unless ($secret = $self->fetch_secret)
		{
		return (0, "can't retrieve secret") 
		}
# HLAGHLAGHLAGHLAG
	my $newhash = MD5->hexhash($secret .
			MD5->hexhash(join ':', $secret,
				@ticket{qw(ip time expires user)})
			);
	unless ($newhash eq $ticket{'hash'}) 
		{
		$self->invalidate_secret;  #maybe it's changed?
			return (0, 'ticket mismatch');
		}
	$r->connection->user($ticket{'user'});
	return (1, 'ok');
	}

# $cookie = $ticketTool->make_return_address()
sub make_return_address 
	{
	my($self, $r) = @_;
	my $uri = Apache2::URI->parse($r, $r->uri);
	$uri->scheme("http");
	$uri->hostname($r->get_server_name);
	$uri->port($r->get_server_port);
	$uri->query(scalar $r->args);

	return CGI::Cookie->new
		(
		 -name => 'request_uri',
		 -value => $uri->unparse,
		 -domain => $self->{TicketDomain},
		 -path => '/'
		);
	}

1;
__END__