Client.pm
No OneTemporary
Actions

Subscribers

None

File Metadata

Created: Sat, Nov 9, 04:23

Client.pm
View Options

	#!/usr/bin/perl
	#
	##############################################################################
	#
	# File Name: Tequila/Client.pm
	# Description: Encapsule l'authentification Tequila pour les CGI en perl
	# Author: Claude Lecommandeur (Claude.Lecommandeur@epfl.ch)
	# Date Created: Thu Oct 31 09:16:06 CET 2002
	#
	# 2.0.1 -> 2.0.2
	# - Remove all remnant of opaque ans urlauth.
	# - Fix localorg image access. Now, it is logo.gif.
	#
	# 2.0.2 -> 2.0.3
	# - In loadargs : protect from multiple 'key' values.
	# - Remove all remnant of 'fromserver'.
	# - Fetch images from server.
	#
	# 2.0.2 -> 2.0.3
	# - Fix for ever the key business. Now there is a separateket for the request
	# and session.
	# - No longer use the key= attribute in the urlaccess, always use cookies.
	#
	# 2.0.3 -> 2.0.4
	# - Check session key validity (/^[a-z0-9]+$/).
	#
	# 2.0.4 -> 2.0.5
	# - REALLY Check session key validity.
	# - Improve search of sessions directory.
	#
	# 2.0.5 -> 2.0.6
	# - Improve random initialization.
	# - Fix bug in key calculation that never uses '9'.
	#
	#
	##############################################################################
	#
	package Tequila::Client;
	#
	use strict;
	use Socket;
	use IO::Socket::SSL;
	use IO::Socket::INET;

	use vars qw(@ISA $VERSION $XS_VERSION $CONFIG $DEBUG);

	my ($defaultserver, $defaultserverurl, $defaultsessionsdir);

	$VERSION = '2.0.6';

	sub new { # Exported
	my $class = shift;
	my %args = @_;

	staticinit ();
	my $self = {
	partner => undef,
	resource => undef,
	urlacces => undef,
	urlaccess => undef,
	usessl => 1,
	service => undef,
	request => undef,
	wish => undef,
	require => undef,
	wantright => undef,
	wantrole => undef,
	language => 'english',
	identities => undef,
	localserver => $defaultserver,
	serverurl => $defaultserverurl,
	serverfile => "/tequila",
	usesessions => 1,
	sessionsdir => $defaultsessionsdir,
	sessionsmanager => undef,
	sessionmax => 24 * 3600,
	checkcertificates => 0,
	cafile => undef,
	clientargs => {},
	allows => undef,
	authstrength => 0,
	hascookie => 0,
	usecookies => 1,
	cookiename => undef,
	cookiepolicy => 'session',
	servercookies => 1,
	allsensitive => undef,
	username => undef,
	contact => undef,
	testing => undef,
	debug => undef,
	logouturl => undef,

	verbose => 0,
	authenticated => undef,
	initialized => undef,
	querystring => undef,
	pathinfo => undef,
	scriptname => undef,
	servername => undef,
	serverport => undef,
	https => undef,
	sessionkey => undef,
	requestkey => undef,
	org => undef,
	user => undef,
	host => undef,
	vars => undef,
	attrs => undef,
	appargs => undef,
	};
	foreach my $arg (keys %args) {
	if (ref ($args {$arg}) eq 'ARRAY') {
	$self->{$arg} = join ('+', @{$args {$arg}});
	next;
	}
	$self->{$arg} = $args {$arg};
	}
	$self->{urlaccess} \|\|= $self->{urlacces};
	bless $self, $class;
	#$self->init (); # Too dangerous.
	return $self;
	}

	sub init {
	my $self = shift;
	return if $self->{initialized};
	my $appargs = loadargs ();

	$self->{querystring} = $ENV {QUERY_STRING};
	$self->{pathinfo} = $ENV {PATH_INFO};
	$self->{scriptname} = $ENV {SCRIPT_NAME};
	$self->{servername} = $ENV {SERVER_NAME};
	$self->{serverport} = $ENV {SERVER_PORT};
	$self->{https} = $ENV {HTTPS};
	$self->{appargs} = $appargs;

	if ($self->{usecookies}) {
	$self->{sessioncookiename} \|\|= $self->{cookiename};
	unless ($self->{sessioncookiename}) {
	my $scriptname = $self->{scriptname};
	if ($scriptname =~ /^.*\/(\S+)$/) {
	$self->{sessioncookiename} = "Tequila_$1";
	} else {
	$self->{sessioncookiename} = 'teqsession_key';
	}
	}
	unless ($self->{requestcookiename}) {
	my $scriptname = $self->{scriptname};
	if ($scriptname =~ /^.*\/(\S+)$/) {
	$self->{requestcookiename} = "Tequila_req_$1";
	} else {
	$self->{requestcookiename} = 'teqrequest_key';
	}
	}
	my $sessioncookiename = $self->{sessioncookiename};
	my $requestcookiename = $self->{requestcookiename};
	my $allcookies = $ENV {HTTP_COOKIE};
	foreach my $cookie (split (/; /, $allcookies)) {
	if ($cookie =~ /^\Q$sessioncookiename\E=(.*)$/) {
	$self->{sessionkey} = $1;
	$self->{hascookie} = 1;
	last;
	}
	if ($cookie =~ /^\Q$requestcookiename\E=(.*)$/) {
	$self->{requestkey} = $1;
	last;
	}
	}
	} else {
	$self->{sessionkey} \|\|= $appargs->{tequila_key} \|\| $appargs->{key};
	delete $appargs->{tequila_key};
	delete $appargs->{key};
	}
	$self->{initialized} = 1;
	}

	sub authenticate {
	my $self = shift;
	return if $self->{authenticated};
	init ($self) unless $self->{initialized};
	if ($self->authenticated ()) {
	$self->{attrs}->{authstrength} \|\|= 0;
	if ($self->{attrs}->{authstrength} >= $self->{authstrength}) {
	return;
	}
	}
	$self->{requestkey} = $self->createserverrequest ();
	$self->redirecttoserver ();
	}

	sub authenticated {
	my $self = shift;
	return 1 if $self->{authenticated};
	init ($self) unless $self->{initialized};

	if ($self->{sessionkey}) {
	if ($self->{usesessions} && ($self->loadsession () == 1)) {
	if ($self->checkuserprofile ()) {
	$self->depositcookie ($self->{sessioncookiename}, $self->{sessionkey})
	if (!$self->{hascookie} && $self->{usecookies});
	$self->{authenticated} = 1;
	} else { return; }
	} else { return; }
	}
	elsif ($self->{requestkey}) {
	$self->removecookie ($self->{requestcookiename});
	if ($self->fetchattributes ()) {
	$self->depositcookie ($self->{sessioncookiename}, $self->{sessionkey})
	if $self->{usecookies};
	$self->{authenticated} = 1;
	} else { return; }
	}
	return $self->{authenticated};
	}

	sub logout {
	my $self = shift;
	$self->killsession () if $self->{usesessions};
	$self->{authenticated} = 0;
	$self->removecookie ($self->{sessioncookiename});
	}

	sub globallogout {
	my $self = shift;
	$self->logout ();
	my $pi = $self->{pathinfo};
	my $me = $self->{scriptname};
	my $us = $self->{servername};
	my $serverurl = $self->{serverurl};
	my $logouturl = $self->{logouturl} \|\| $self->{urlaccess} \|\| "http://$us$me$pi";
	$logouturl = escapeurl ($logouturl);
	print qq{Location: $serverurl/logout?urlaccess=$logouturl\r\n\r\n};
	}

	sub redirecttoserver {
	my $self = shift;
	my $requestkey = $self->{requestkey};
	$self->error ("Internal error in redirecttoserver : requestkey undefined.")
	unless $requestkey;
	$self->removecookie ($self->{sessioncookiename});
	$self->depositcookie ($self->{requestcookiename}, $self->{requestkey});
	print qq{WWW-Authenticate: Tequila serverurl="$self->{serverurl}" requestkey="$requestkey"\r\n};
	print qq{Location: $self->{serverurl}/auth?requestkey=$requestkey\r\n\r\n};
	exit;
	}

	sub loadsessionsmanager {
	my $self = shift;
	my $sessionsmanager = $self->{sessionsmanager};
	my $SM = 'Tequila::' . $sessionsmanager;
	eval "use $SM; 1;" \|\| do {
	warn "loadsessionsmanager ($sessionsmanager) failed1.\n" if $self->{verbose};
	$self->error ("loadsessionsmanager : Unable to load session manager $SM : $@");
	};
	my $sm;
	eval "\$sm = new $SM (dsmhost => 'localhost', dsmport => 2345);" \|\| do {
	warn "loadsessionsmanager ($sessionsmanager) failed2.\n" if $self->{verbose};
	$self->error ("loadsessionsmanager : Unable to initialized session manager $SM : $@");
	};
	$self->{sm} = $sm;
	warn "loadsessionsmanager ($sessionsmanager) OK.\n" if $self->{verbose};
	}

	sub createsession {
	my $self = shift;
	checksessionkey ($self, $self->{sessionkey});
	warn "createsession ($self->{sessionsdir}:$self->{sessionkey}:$self->{org}".
	":$self->{user}:$self->{host})" if $self->{verbose};

	if ($self->{sessionsmanager}) {
	$self->loadsessionsmanager () unless $self->{sm};
	my $sm = $self->{sm};
	return unless $sm;
	my $session = {
	org => $self->{org},
	user => $self->{user},
	host => $self->{host},
	timeout => $self->{sessionmax}
	};
	foreach my $attr (keys %{$self->{attrs}}) {
	my $value = $self->{attrs}->{$attr};
	$value =~ s/\n/\\n/g;
	$value =~ s/\r]//g;
	$session->{$attr} = $value;
	}
	my $status = $sm->createsession ("Application:$self->{sessionkey}", $session);
	unless ($status) {
	$self->error ("createsession : Unable to create session Application:$self->{sessionkey}");
	}
	warn "createsession : session $self->{sessionkey} created\n" if $self->{verbose};
	return 1;
	} else {
	return $self->createfilesession ();
	}
	}

	sub createfilesession {
	my $self = shift;
	warn "createfilesession ($self->{sessionsdir}:$self->{sessionkey}:$self->{org}".
	":$self->{user}:$self->{host})" if $self->{verbose};

	checksessionkey ($self, $self->{sessionkey});
	my $sesdir = $self->{sessionsdir};
	unless (-d $sesdir && -w $sesdir) {
	$self->error ("Tequila:createsession: Session directory $sesdir doesn't ".
	"exist or not writable.");
	}
	unless (open (SESSION, ">$sesdir/$self->{sessionkey}")) {
	$self->error ("Tequila:createsession: Unable to open session file ".
	"($sesdir/$self->{sessionkey}) : $!");
	}
	print SESSION
	"org=$self->{org}\n",
	"user=$self->{user}\n",
	"host=$self->{host}\n"
	;
	foreach my $attr (keys %{$self->{attrs}}) {
	my $value = $self->{attrs}->{$attr};
	$value = "\\\n" . $value . "\n" if ($value =~ /[\n\r]/);
	print SESSION "$attr=$value\n";
	}
	close (SESSION);
	return 1;
	}

	#
	# loadsession
	#
	# returns : 1 : OK.
	# 2 : pas de session.
	# 3 : session échue.
	# 4 : pas la bonne machine au bout
	#
	sub loadsession {
	my $self = shift;
	return 2 unless $self->{sessionkey};
	checksessionkey ($self, $self->{sessionkey});

	if ($self->{sessionsmanager}) {
	$self->loadsessionsmanager () unless $self->{sm};
	my $sm = $self->{sm};
	return unless $sm;
	warn "loadsession ($self->{sessionkey} OK\n" if $self->{verbose};
	my $session = $sm->readsession ("Application:$self->{sessionkey}");
	return 2 unless $session;
	foreach my $attr (keys %$session) {
	$self->{$attr} = $session->{$attr};
	}
	return 1;
	} else {
	return $self->loadfilesession ();
	}
	}

	sub loadfilesession {
	my $self = shift;
	my $sessionkey = $self->{sessionkey};
	my $sesdir = $self->{sessionsdir};
	my $sesmax = $self->{sessionmax};

	return 2 unless $self->{sessionkey};
	checksessionkey ($self, $self->{sessionkey});

	my $keyfile = "$sesdir/$sessionkey";
	return 2 unless (-r $keyfile);
	my $lastaccess = (stat ($keyfile))[8];
	my $now = time;
	if ($lastaccess < ($now - $sesmax)) {
	unlink ($keyfile);
	return 3;
	}
	open (SESSION, $keyfile) \|\| return 2;
	while (<SESSION>) {
	chomp;
	my ($attr, $value) = split (/=/, $_, 2);
	if ($attr =~ /^(org\|user\|host)$/) {
	$self->{$attr} = $value;
	next;
	}
	if ($value =~ /^\\/) {
	$value = "\\\n";
	while (<SESSION>) {
	last if /^[\r\n]*$/;
	$value .= $_;
	}
	}
	$self->{attrs}->{$attr} = $value;
	}
	close (SESSION);
	utime ($now, $now, "$sesdir/$sessionkey");
	killsession ($self) unless $self->{usesessions};
	return 1;
	}

	sub checkuserprofile {
	my $self = shift;
	my $abort = shift;
	my $require = $self->{require};
	my $resource = $self->{resource};
	my $wantright = $self->{wantright};
	my $wantrole = $self->{wantrole};

	return 1 if ($self->{attrs}->{status} eq 'fail'); # Don't check failed login.
	if ($resource && ($resource ne $self->{attrs}->{resource})) {
	return 0 if !$abort;
	$self->error (
	"Tequila:checkuserprofile: request found on the server, doesnt match the".
	" requested resource :".
	"<br>server says resource = $self->{attrs}->{resource},".
	"<br>client says resource = $resource");
	}
	if ($require && ($require ne $self->{attrs}->{require})) {
	return 0 if !$abort;
	$self->error (
	"Tequila:checkuserprofile: request found on the server, doesnt fit the".
	" required filter :".
	"<br>server says require = $self->{attrs}->{require},".
	"<br>client says require = $require");
	}
	if ($wantright) {
	my @rights = split (/,/, $wantright);
	foreach my $right (@rights) {
	unless ($self->{attrs}->{$right}) {
	return 0 if !$abort;
	$self->error (
	"Tequila:checkuserprofile: request found on the server, doesnt fit the".
	" required filter : right $right is missing");
	}
	}
	}
	if ($wantrole) {
	my @roles = split (/,/, $wantrole);
	foreach my $role (@roles) {
	unless ($self->{attrs}->{$role}) {
	return 0 if !$abort;
	$self->error (
	"Tequila:checkuserprofile: request found on the server, doesnt fit the".
	" required filter : role $role is missing");
	}
	}
	}
	return 1;
	}

	sub purgesessions {
	my $self = shift;
	return if $self->{sessionsmanager};
	my $sesmax = $self->{sessionmax};
	opendir (SESSIONS, $self->{sessionsdir}) \|\| return;
	my @sessions = readdir (SESSIONS);
	closedir (SESSIONS);
	@sessions = grep (!/^\.\.?$/, @sessions);
	foreach my $session (@sessions) {
	my $sessionfile = "$self->{sessionsdir}/$session";
	next if -d $sessionfile;
	my $lastaccess = (stat ($sessionfile))[8];
	my $now = time;
	unlink ($sessionfile) if ($lastaccess < ($now - $sesmax));
	}
	}

	sub killsession {
	my $self = shift;
	checksessionkey ($self, $self->{sessionkey});
	if ($self->{sessionsmanager}) {
	$self->loadsessionsmanager () unless $self->{sm};
	my $sm = $self->{sm};
	return unless $sm;
	$sm->deletesession ("Application:$self->{sessionkey}");
	} else {
	my $sessionfile = "$self->{sessionsdir}/$self->{sessionkey}";
	unlink ($sessionfile) \|\| "killsession: Unable to kill session $self->{sessionkey} : $!";
	}
	}

	sub request {
	my $self = shift;
	$self->{request} = join ('+', @_);
	}

	sub wish {
	my $self = shift;
	$self->{wish} = join ('+', @_);
	}

	sub require {
	my $self = shift;
	my $newreq = shift;
	if ($self->{require}) {
	$self->{require} = "($self->{require})&($newreq)";
	} else {
	$self->{require} = $newreq;
	}
	}

	sub authstrength {
	my $self = shift;
	$self->{authstrength} = shift;
	}

	sub checkcerts {
	my $self = shift;
	$self->{checkcertificates} = shift;
	}

	sub cafile {
	my $self = shift;
	$self->{cafile} = shift;
	}

	sub wantright {
	my $self = shift;
	$self->{wantright} = shift;
	}

	sub wantrole {
	my $self = shift;
	$self->{wantrole} = shift;
	}

	sub setresource {
	my $self = shift;
	$self->{resource} = shift;
	}

	sub setpartner {
	my $self = shift;
	$self->{partner} = shift;
	}

	sub setlang {
	my $self = shift;
	$self->{language} = shift;
	}

	sub setidentities {
	my $self = shift;
	$self->{identities} = shift;
	}

	sub allsensitive {
	my $self = shift;
	my $value = shift;
	$self->{allsensitive} = $value ? 1 : 0;
	}

	sub usecookies {
	my $self = shift;
	my $value = shift;
	$self->{usecookies} = $value ? 1 : 0;
	}

	sub setcookiename {
	my $self = shift;
	$self->{cookiename} = $self->{sessioncookiename} = shift;
	}

	sub setcookiepolicy {
	my $self = shift;
	$self->{cookiepolicy} = shift;
	}

	sub useloginwindow {
	# nothing.
	}

	sub servercookies {
	my $self = shift;
	$self->{servercookies} = shift;
	}

	sub setopaque {
	# nothing
	}

	sub setserver {
	my $self = shift;
	my $server = shift;
	$self->{localserver} = $server;

	my $binaddr = gethostbyname ($server);
	my $srvaddr = join ('.', unpack ('C4', $binaddr));
	$self->{sessionsdir} = $self->{sessionsdir} . '/' . $srvaddr;
	$self->{serverurl} = "https://$self->{localserver}/tequila";
	}

	sub setserverurl {
	my $self = shift;
	my $serverurl = shift;

	$self->{serverurl} = $serverurl;
	if ($serverurl =~ m!^(http\|https)://([^/])(.)$!) {
	my ($host, $file) = ($2, $3);
	$host = $1 if $host =~ /^([^:]):(.)$/;
	$self->{localserver} = $host;
	$self->{serverfile} = $file;
	}
	my $binaddr = gethostbyname ($self->{localserver});
	my $srvaddr = join ('.', unpack ('C4', $binaddr));
	$self->{sessionsdir} = $self->{sessionsdir} . '/' . $srvaddr;
	}

	sub getserverurl {
	my $self = shift;
	return $self->{serverurl};
	}

	sub setlogouturl {
	my $self = shift;
	$self->{logouturl} = shift;
	}

	sub usessl {
	my $self = shift;
	$self->{usessl} = shift;
	}

	sub allows {
	my ($self, $allow) = @_;
	$self->{allows} .= '&' if $self->{allows};
	$self->{allows} .= $allow;
	}

	sub setusername {
	my $self = shift;
	$self->{username} = shift;
	}

	sub setorg {
	my $self = shift;
	$self->{org} = shift;
	}

	sub setservice {
	my $self = shift;
	$self->{service} = shift;
	}

	sub setclientarg {
	my ($self, $key, $value) = @_;
	$self->{clientargs}->{$key} = $value;
	}

	sub getclientarg {
	my ($self, $key) = @_;
	return $self->{clientargs}->{$key};
	}

	sub usesessions {
	my $self = shift;
	$self->{usesessions} = shift;
	}

	sub setsessionsdir {
	my $self = shift;
	$self->{sessionsdir} = shift;
	}

	sub getsessionsdir {
	my $self = shift;
	return $self->{sessionsdir};
	}

	sub setsessionsduration {
	my $self = shift;
	$self->{sessionmax} = shift;
	}

	sub getsessionsduration {
	my $self = shift;
	return $self->{sessionmax};
	}

	sub loadargs {
	my $clen = $ENV {CONTENT_LENGTH};
	my $meth = $ENV {REQUEST_METHOD};
	my $get = $ENV {QUERY_STRING};

	my $args;
	my $post = '';
	if ($meth eq 'POST') {
	read STDIN, $post, $clen;
	my $ctype = $ENV {CONTENT_TYPE};
	if ($ctype =~ /^multipart\/form-data;\s+boundary=(.*)$/) {
	my $boundary = $1;
	my @parts = split (/$boundary/, $post);
	shift @parts; pop @parts;

	my $pat1 = qq{\r\nContent-Disposition: form-data; name="(.*?)"};
	my $pat2 = qq{\r\nContent-Type: (.?)\r\n\r\n(.)};
	foreach my $part (@parts) {
	if($part =~ /^$pat1\r\n\r\n(.*)\r\n/is) {
	my $name = $1;
	my $value = $2;
	$args->{$name} = $value;
	next;
	}
	if ($part =~ /^$pat1; filename="(.*?)"$pat2\r\n/is) {
	my $name = $1;
	my $filename = $2; $filename =~ s/.\\//; $filename =~ s/.\///;
	my $ctype = $3;
	my $content = $4; $content =~ s/!$//;
	$args->{$name} = {
	filename => $filename,
	contenttype => $ctype,
	content => $content,
	};
	next;
	}
	if ($part =~ /^$pat1; filename="(.?)"\r\n(.)\r\n/is) {
	my $name = $1;
	my $filename = $2; $filename =~ s/.\\//; $filename =~ s/.\///;
	my $content = $3; $content =~ s/!$//;
	$args->{$name} = {
	filename => $filename,
	contenttype => "unknown",
	content => $content,
	};
	next;
	}
	}
	$post = '';
	}
	}
	my $all = $get . '&' . $post;
	my @fields = split (/&/, $all);
	foreach (@fields) {
	s/\+/ /g;
	s/%([0-9a-f]{2,2})/pack ("C", hex ($1))/gie;
	}
	foreach my $field (@fields) {
	next unless ($field =~ /=/);
	my ($key, $value) = split(/=/, $field, 2);
	next unless $value;
	if ($key eq 'key') {
	$args->{$key} = $value;
	} else {
	my $oldval = $args->{$key};
	$args->{$key} = $oldval ? "$oldval,$value" : $value;
	}
	}
	return $args;
	}

	sub parseargs {
	my $qstr = shift;
	return unless $qstr;

	my $args;
	my @fields = split (/&/, $qstr);
	foreach (@fields) {
	s/\+/ /g;
	s/%([0-9a-f]{2,2})/pack ("C", hex ($1))/gie;
	}
	foreach my $field (@fields) {
	next unless ($field =~ /=/);
	my ($key, $value) = split (/=/, $field, 2);
	my $oldval = $args->{$key};
	$args->{$key} = $oldval ? "$oldval,$value" : $value;
	}
	return $args;
	}

	sub head {
	my $title = shift \|\| 'Tequila';
	print qq{Content-Type: text/html;charset=iso-8859-1

	<html>
	<head>
	<title>$title</title>
	</head>
	<body>
	};
	}

	sub tail {
	print qq{
	</body>
	</html>
	};
	exit;
	}

	sub error {
	my ($self, $msg1, $testing, $msg2) = @_;
	my $server = $self->{localserver};
	head ('Tequila error');
	print qq{
	<table width="100%" height="100%"><tr><td valign="middle">
	<table width="600" border="1" cellspacing="0" align="center" cellpadding="5">
	<tr>
	<td bgcolor="#CCCCCC">
	<table width="100%">
	<tr>
	<td>
	<img src="http://$server/images/logo.gif" alt="Local logo">
	</td>
	<td bgcolor="#CCCCCC" align="right">
	<font size="+2">Service <b>$self->{service}</b></font>
	</td>
	</tr>
	</table>
	</td>
	</tr>
	<tr>
	<td align="center">
	<table width="98%" cellspacing="0" bgcolor=white>
	<tr>
	<td width="219">
	<img src="http://$server/images/eye.gif" width="200" height="270">
	</td>
	<td align="center" valign="middle">
	<font color="red" size="+1">
	Tequila error : $msg1
	<h3 align="center">
	Contact the manager of the application you
	are trying to access.
	</h3>
	</font>
	</td>
	</tr>
	</table>
	</td>
	</tr>
	</table>
	</td></tr></table>
	};
	tail ();
	}

	sub getaddrs {
	my $srv = shift;
	my ($name, $aliases, $addrtype, $length, @addresses) = gethostbyname ($srv);
	next unless @addresses;
	foreach (@addresses) {
	$_ = join ('.', unpack ('C4', $_));
	}
	return @addresses;
	}

	sub createserverrequest {
	my $self = shift;
	$self->{urlaccess} = $self->makeurlaccess () unless $self->{urlaccess};
	$self->{usecookie} = $self->{servercookies} ? '' : 'off';

	#
	# We should use method POST, but we get trapped in the Apache infamous
	# Method Not Allowed message.
	#
	my $method = 'GET';
	#my $method = 'POST';
	my $args;
	if ($self->{resource}) {
	$args->{resource} = $self->{resource};
	$args->{partner} = $self->{partner} if $self->{partner};
	} else {
	foreach my $keyword (qw(partner resource origresource urlaccess service username
	allows allsensitive request wish require wantright forcelogin
	wantrole language identities usecookie authstrength debug allowedorgs
	nochecksrchost charset)) {
	next unless $self->{$keyword};
	$args->{$keyword} = $self->{$keyword};
	$args->{$keyword} = escapeurl ($args->{$keyword}) if ($method eq 'GET');
	}
	}
	foreach my $key (keys %{$self->{clientargs}}) {
	next if $args->{$key};
	my $value = $self->{clientargs}->{$key};
	$value = escapeurl ($value) if ($method eq 'GET');
	$args->{$key} = $value;
	}
	$args->{dontappendkey} = 1 if $self->{usecookies};
	my $server = $self->{localserver};
	my $script = $self->{serverfile};
	my $serverurl = $self->{serverurl} \|\| "http://$server$script";
	$serverurl =~ s/\/tequila(\/\|$)/\/tequilac$1/ if $self->{resource} \|\| $self->{partner};
	$serverurl =~ s/^http:/https:/ if $self->{checkcertificates} \|\|
	$self->{resource} \|\|
	$self->{partner} \|\|
	$self->{usessl};
	my ($status, $sock, $statusline) =
	$self->httpsocket ("$serverurl/createrequest", $method, $args);

	$self->error ("Bad connection to Tequila server ($serverurl), server says : $statusline")
	if ($status != 200);

	my $requestkey;
	my $nempty = 0;
	while (<$sock>) { # body
	last unless $_;
	s/^[\r\n]*$//;
	if (/^$/) {
	last if (++$nempty > 5);
	} else { $nempty = 0; }
	$requestkey = $1 if /^key=(.*)$/;
	}
	close ($sock);
	$self->error ("Bad response from local Tequila server ($server)") if !$requestkey;
	return $requestkey;
	}

	sub fetchattributes {
	my $self = shift;
	my $requestkey = $self->{requestkey};
	my $server = $self->{localserver};
	my $serverurl = $self->{serverurl} \|\| "http://$server/tequila";
	$serverurl =~ s/\/tequila(\/\|$)/\/tequilac$1/ if $self->{resource} \|\| $self->{partner};
	$serverurl =~ s/^http:/https:/ if $self->{checkcertificates} \|\|
	$self->{resource} \|\|
	$self->{partner} \|\|
	$self->{usessl};

	my $args = { key => $requestkey, };
	my ($status, $sock, $statusline) =
	$self->httpsocket ("$serverurl/fetchattributes", 'GET', $args);

	return if ($status == 451); # Invalid key.
	$self->error ("Bad connection to Tequila server ($serverurl), server says : $statusline")
	if ($status != 200);

	my ($org, $user, $host, $key, $sver, %attrs);
	while (<$sock>) { # body
	last unless $_;
	chomp;
	next if /^$/;
	if (/^([^=]+)=(.*)$/) {
	my ($name, $value) = ($1, $2);
	if ($name eq 'org') { $org = $value; }
	elsif ($name eq 'user') { $user = $value; }
	elsif ($name eq 'host') { $host = $value; }
	elsif ($name eq 'key') { $key = $value; }
	elsif ($name eq 'version') { $sver = $value; }
	else {
	if ($value =~ /^\\/) {
	$value = '';
	while (<$sock>) {
	last if /^[\r\n]*$/;
	$value .= $_;
	}
	}
	$attrs {$name} = $value;
	}
	}
	}
	close ($sock);
	$self->error ("Tequila:fetchattributes: Malformed server response : org undefined")
	unless $org;
	$self->error ("Tequila:fetchattributes: Malformed server response : user undefined")
	unless $user;
	$self->error ("Tequila:fetchattributes: Malformed server response : host undefined")
	unless $host;
	$self->error ("Tequila:fetchattributes: Malformed server response : key undefined")
	unless $key;

	$self->{org} = $org;
	$self->{user} = $user;
	$self->{host} = $host;
	$self->{version} = $sver;
	$self->{attrs} = \%attrs;

	$self->checkuserprofile (1);
	if ($self->{usesessions}) {
	$self->{sessionkey} = $self->genkey ();
	$self->createsession ();
	}
	return 1;
	}

	sub makeurlaccess () {
	my $self = shift;
	my $qs = $self->{querystring};
	my $pi = $self->{pathinfo};
	my $me = $self->{scriptname};
	my $us = $self->{servername};
	my $proto = ($self->{https} && ($self->{https} eq 'on')) ? "https" : "http";
	my $urlaccess = "$proto://$us$me$pi";
	$urlaccess .= "?$qs" if $qs;
	return $urlaccess;
	}

	sub depositcookie {
	my ($self, $cook, $value) = @_;
	return unless $cook;
	my $date = gmtime (time + $self->{sessionmax});
	my ($day, $month, $daynum, $hms, $year) = split (/\s+/, $date);
	my $expires = sprintf ("%s %02d-%s-%s %s GMT", $day, $daynum, $month, $year, $hms);
	if ($self->{cookiepolicy} eq 'session') {
	print qq{Set-Cookie: $cook=$value; path=/;\r\n};
	} else {
	print qq{Set-Cookie: $cook=$value; path=/; expires=$expires;\r\n};
	}
	}

	sub removecookie {
	my ($self, $cook) = @_;
	my $date = gmtime (time - 3600);
	my ($day, $month, $daynum, $hms, $year) = split (/\s+/, $date);
	my $expires = sprintf ("%s %02d-%s-%s %s GMT", $day, $daynum, $month, $year, $hms);
	print qq{Set-Cookie: $cook=removed; path=/; expires=$expires;\r\n};
	}

	sub staticinit {
	my ($localserver, $serverurl, $sessionsdir);
	if (open (CONF, "/etc/tequila.conf")) {
	while (<CONF>) {
	chomp;
	next if (/^#/ \|\| /^$/);
	$localserver = $1 if /^TequilaServer:\s(.)$/i;
	$serverurl = $1 if /^TequilaServerUrl:\s(.)$/i;
	$sessionsdir = $1 if /^SessionsDir:\s(.)$/i;
	}
	close (CONF);
	}
	unless ($sessionsdir) {
	if (eval "use Tequila::Config; 1;") {
	$localserver = $Tequila::Config::server;
	$serverurl = $Tequila::Config::serverurl;
	$sessionsdir = $Tequila::Config::sessionsdir;
	}
	}

	my @tried;
	unless ($sessionsdir) {
	my $scriptfile = $ENV {SCRIPT_FILENAME};
	$scriptfile =~ s/\/[^\/]*$//;
	my $sesdir = "$scriptfile/config/Sessions";
	push (@tried, $sesdir);
	if (-d $sesdir && -w $sesdir) {
	$sessionsdir = $sesdir;
	}
	}
	unless ($sessionsdir) {
	my @sessionsdirs = (
	'/var/www/Tequila/Sessions',
	'/var/www/tequila/Tequila/Sessions',
	);
	foreach my $sesdir (@sessionsdirs) {
	push (@tried, $sesdir);
	if (-d $sesdir && -w $sesdir) {
	$sessionsdir = $sesdir;
	last;
	}
	}
	}
	my $sesdir = $ENV {DOCUMENT_ROOT};
	unless ($sessionsdir) {
	$sesdir =~ s!/[^/]/$!/Sessions!; # One step over DOCUMENT_ROOT.
	push (@tried, $sesdir);
	if (-d $sesdir && -w $sesdir) {
	$sessionsdir = $sesdir;
	}
	}
	unless ($sessionsdir) {
	$sesdir =~ s!/Sessions$!/Tequila/Sessions!;
	push (@tried, $sesdir);
	if (-d $sesdir && -w $sesdir) {
	$sessionsdir = $sesdir;
	}
	}
	unless ($sessionsdir) {
	$sesdir =~ s!/Tequila/Sessions$!/private/Tequila/Sessions!;
	push (@tried, $sesdir);
	if (-d $sesdir && -w $sesdir) {
	$sessionsdir = $sesdir;
	}
	}
	unless ($sessionsdir) {
	my $self = { org => 'Unknown yet', service => 'Unknown yet', };
	bless $self, 'Tequila::Client';
	my $tried = join (', ', @tried);
	$self->error ("Unable to find the Session directory, (tried $tried).");
	}
	unless ($localserver) {
	my $hostname = `hostname`;
	chomp $hostname;
	if ($hostname !~ /\./) {
	my $addr = gethostbyname ($hostname);
	$hostname = gethostbyaddr ($addr, AF_INET);
	}
	my $localdomain = $1 if ($hostname =~ /^[^\.]\.(.)$/);
	unless ($localserver) {
	$localserver = "tequila";
	$localserver .= ".$localdomain" if $localdomain;
	}
	}
	unless ($serverurl) {
	$serverurl = "https://$localserver/tequila";
	}
	$defaultserver = $localserver;
	$defaultsessionsdir = $sessionsdir;
	$defaultserverurl = $serverurl;
	}

	sub escapeurl {
	local ($_) = @_;
	s/([^\w\+\.\-])/sprintf("%%%X",ord($1))/ge;
	return $_;
	}

	sub getrandombytes {
	my ($self, $len) = @_;
	$len \|\|= 32;
	my $bytes;
	open(RAND, "/dev/urandom") \|\| do {
	$self->error ("Internal error in getrandombytes : ".
	"unable to init random engine : $!.")
	};
	if (sysread (RAND, $bytes, $len) != $len) {
	$self->error ("Internal error in getrandombytes : ".
	"Unable to read random bytes : $!");
	}
	close (RAND);
	return $bytes;
	}

	sub genkey {
	my ($self, $len) = @_;
	$len \|\|= 32;
	my $bytes = $self->getrandombytes ($len);
	my @bytes = unpack ("C$len", $bytes);
	my $key = '';
	for (my $i = 0; $i < $len; $i++) {
	my $car = $bytes [$i] % 36;
	$key .= ('a'..'z', '0'..'9')[$car];
	}
	return $key;
	}

	sub httpsocket {
	my ($self, $url, $method, $args) = @_;
	my $sock;
	my $nredir = 0;
	while ($url) {
	$self->error ("Tequila:httpsocket: invalid URL : $url")
	if ($url !~ m!^(http\|https)://([^/])(.)$!);
	my ($prot, $host, $file, $port) = ($1, $2, $3, 0);
	($host, $port) = split (/:/, $host) if ($host =~ /:/);
	unless ($port) {
	$port = ($prot eq 'https') ? 443 : 80;
	}
	$sock = ($prot eq 'https')
	? $self->sslsocket ($host, $port)
	: new IO::Socket::INET ("$host:$port");
	$self->error ("Tequila:httpsocket: unable to open $prot socket connection to $host (for $url)")
	unless $sock;

	if ($method eq 'POST') {
	my $argstring = '';
	foreach my $arg (keys %$args) {
	$argstring .= "$arg=$args->{$arg}\n";
	}
	my $arglen = length ($argstring);
	print $sock "POST $file HTTP/1.0\r\n",
	"Host: $host\r\n",
	"Content-type: application/x-www-form-urlencoded\r\n",
	"Content-length: $arglen\r\n",
	"\r\n",
	"$argstring" \|\|
	$self->error ("Tequila:httpsocket: unable to send data to $host:$port");
	} else {
	my $argstring = '';
	foreach my $arg (keys %$args) {
	$argstring .= "&$arg=$args->{$arg}";
	}
	$argstring =~ s/^&//;
	print $sock "GET $file?$argstring HTTP/1.0\r\n",
	"Host: $host\r\n",
	"\r\n" \|\|
	$self->error ("Tequila:httpsocket: unable to send data to $host:$port");
	}
	$url = 0;
	my $statusline = <$sock>;
	$statusline = <$sock> unless $statusline;
	$statusline =~ s/[\r\n]//g;
	return (452, $sock, "No answer from server") unless $statusline;
	my ($status) = ($statusline =~ / (\d*) /); # HTTP/1.x 200 OK
	while (<$sock>) { # headers
	last unless $_;
	s/^[\r\n]*$//;
	if (/^Location:\s(.)$/) {
	$url = $1;
	}
	last if /^$/;
	}
	if (($status != 200) && !$url) {
	return ($status, $sock, $statusline);
	}
	if ($url) {
	close ($sock);
	$nredir++;
	$self->error ("Tequila:httpsocket: maximun number of HTTP redirect : $nredir")
	if ($nredir > 20);
	}
	}
	return (200, $sock);
	}

	sub sslsocket {
	my ($self, $server, $port) = @_;
	$port = 'https' unless $port;
	my ($sock, %sslargs);
	$sslargs {PeerAddr} = "$server:$port";
	if ($self->{checkcertificates} && $self->{cafile}) {
	$sslargs {SSL_verify_mode} = 0x01;
	$sslargs {SSL_ca_file} = $self->{cafile};
	}
	if ($self->{keyfile} && $self->{certfile}) {
	$sslargs {SSL_use_cert} = 1;
	$sslargs {SSL_key_file} = $self->{keyfile};
	$sslargs {SSL_cert_file} = $self->{certfile};
	}
	$sslargs {SSL_fingerprint} = $ENV {TEQUILA_FINGERPRINT} if $ENV {TEQUILA_FINGERPRINT} && $ENV {TEQUILA_FINGERPRINT} ne '';
	$sock = new IO::Socket::SSL (%sslargs);

	if ($self->{checkcertificates} && $self->{cafile}) {
	my $subject = $sock->peer_certificate ('subject');
	my @cns = split (/\/CN=/i, $subject);
	shift @cns;
	my $ok = 0;
	foreach my $cn (@cns) {
	if ($cn =~ /^$(.)$(.)$/) {
	my $domain = $2;
	my @names = split (/\\|/, $1);
	foreach my $name (@names) {
	my $fdqn = $name . $domain;
	if (uc $server eq uc $fdqn) { $ok = 1; last; }
	}
	last if $ok;
	} else {
	if (uc $server eq uc $cn) { $ok = 1; last; }
	}
	$self->error ("Tequila:sslsocket: invalid certificate for $server : $subject") unless $ok;
	}
	}
	return $sock;
	}

	sub checksessionkey {
	my ($self, $sessionkey) = @_;
	unless ($sessionkey =~ /^[a-z0-9]+$/i) {
	$sessionkey = fixmsg ($sessionkey);
	$self->error ("Tequila: Malformed session key : $sessionkey");
	}
	}

	sub fixmsg {
	my $msg = shift;
	$msg =~ s/</</g;
	$msg =~ s/>/>/g;
	return $msg;
	}


	1;

Client.pmNo OneTemporaryActions

File Metadata

Client.pmView Options

Event Timeline

Client.pm
No OneTemporary
Actions

Client.pm
View Options