AIS-client
view release on metacpan or search on metacpan
select $ofh;
my $Query = join("\r\n", # "CRLF"
"GET $Desired HTTP/1.1",
# Do we need a Host: header with an "AbsoluteURI?"
# not needed: http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.2
# but this is trumped by an Apache error message invoking RFC2068 sections 9 and 14.23
"Host: $HostName",
"User-Agent: $agent",
"Connection: close",
'','') ;
print SOCK $Query or croak "could not print to miniget socket";
join('',<SOCK>);
ENDMINIGET
}
sub housekeeping(){
my @deletia;
if ($v->{last_access} < ($t - $maxage)){
push @deletia, $k
};
};
@Sessions{@deletia} = ();
};
sub redirect($){
print <<EOF;
Location: $_[0]
Content-Type: text/html
<HTML><HEAD><TITLE>Relocate </TITLE>
<META HTTP-EQUIV="REFRESH" CONTENT="1;URL=$_[0]">
</HEAD>
<BODY>
<A HREF="$_[0]">
<H1>Trying to relocate to $_[0]</H1>please click
here</A>.
$maxage = $params{maxage} || 72*60*60;
$aissri = $params{aissri} || 'http://www.pay2send.com/cgi/ais/';
$agent = $params{agent} ||
"http$ssl_ext://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";
$SessionPrefix = $params{prefix} || 'AIS'; # 'AIS_session';
eval{
tie %Sessions => DirDB => "${SessionPrefix}_sessions";
};
if($@){
print <<EOF;
Content-Type: text/plain
AIS::client module was not able to open DirDB [${SessionPrefix}_sessions]
eval result:
$@
AIS::client version $VERSION
};
if($freq){
housekeeping unless ($$ % $freq)
};
if ($ENV{QUERY_STRING} eq 'LOGOUT'){
# eval <<'LOGOUT';
($Coo) = ($ENV{HTTP_COOKIE} =~ /${SessionPrefix}_session=(\w+)/)
and delete $Sessions{$Coo};
print <<EOF;
Set-Cookie:/${SessionPrefix}_session=
Content-Type: text/html
<html><head><title> LOGGED OUT </title></head>
<body bgcolor=ffffff>
Cookie cleared, you are logged out of "${SessionPrefix}"
<p>
<a href="${aissri}logout">
click here to log out of AIS service $aissri</a>
exit;
# LOGOUT
};
# check for cookies
($Coo) = ($ENV{HTTP_COOKIE} =~ /${SessionPrefix}_session=(\w+)/);
if($Coo){
# print "Content-Type: text/plain\n\n";
# print "We have a cookie: $Coo\n";
# print( %{$Sessions{$Coo}});
# exit;
# Do we have an identity?
if (exists($Sessions{$Coo}->{identity}) and $Sessions{$Coo}->{identity} ne 'ERROR'){
# most of the time, this is what we are expecting
goto HAVE_ID ; # unless $Sessions{$Coo}->{identity} eq 'ERROR';
}else{
# eval <<'NOIDENTITYEVAL';
# get an identity from the AIS server
# (process might be underway already)
if ($ENV{QUERY_STRING} =~ /^OTU_KEY=(\w+)/){
foreach (qw{
identity
error
aissri
user_remote_addr
}
# ,@{$Param{XML}}
){
$AISXML =~ m#<$_>(.+)</$_>#si or next;
$aisvar{$_} = $1;
# print STDERR "ais var $_ is $1\n";
};
if ($aisvar{identity} eq 'NULL'){
redirect(
"$aisvar{aissri}add?RU=http$ssl_ext://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}$ENV{PATH_INFO}");
exit;
};
# hooray! we have an identity.
foreach (keys %aisvar){
# we are in parent
close POSTWRITE;
open STDIN, "<&POSTREAD";
$ENV{REQUEST_METHOD} = 'POST';
}else{
# in child -- write POSTdata to pipe and exit
close STDOUT;
close STDIN;
close POSTREAD;
print POSTWRITE delete $Sessions{$Coo}->{PostData};
close POSTWRITE or die "$$: Error closing POSTWRITE\n";
# exit;
#POSIX:_exit(0); # perldoc -f exit
exec '/usr/bin/true';
};
# HAVEOTUKEYEVAL
};
goto HAVE_ID;
}else{
# redirect us to AIS server PRESENT function
my $suffix = '';
if($ENV{QUERY_STRING}eq'AIS_INITIAL'){
# for when the first time we were called with the wrong host name.
$suffix = 2;
};
$ENV{QUERY_STRING}eq'AIS_INITIAL2'and goto NOCOO;
($Coo = localtime) =~ s/\W//g;
my @chars = 'A'..'Z' ;
substr($Coo, rand(length $Coo), 1) = $chars[rand @chars]
foreach 1..8;
print "X-Ais-Received-Request-Method: $ENV{REQUEST_METHOD}\n";
print "X-Ais-Received-Query-String: $ENV{QUERY_STRING}\n";
$Sessions{$Coo}->{QueryString} = $ENV{QUERY_STRING};
$ENV{REQUEST_METHOD} =~ /POST/i and
$Sessions{$Coo}->{PostData} = <>;
print "Set-Cookie:/${SessionPrefix}_session=$Coo\n";
redirect "http$ssl_ext://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?AIS_INITIAL$suffix";
exit;
};
print <<EOF;
Content-Type: text/plain
internal AIS module logic error
EOF
exit;
NOCOO:
print <<EOF;
Content-Type: text/plain
Cookies appear to be disabled in your web browser.
Cookie string: $ENV{HTTP_COOKIE}
This program uses a session and authentication system
(AIS, the Authenticated Identity Service)
that relies on cookies.
to access http$ssl_ext://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}
(this web server is adminned by $ENV{SERVER_ADMIN})
EOF
exit;
HAVE_ID:
$Sessions{$Coo}->{last_access} = time;
$Identity = $Sessions{$Coo}->{identity};
if($Identity eq 'ERROR'){
print <<EOF;
Content-type: text/plain
There was an error with the authentication layer
of this web service: $Sessions{$Coo}->{error}
please contact $ENV{SERVER_ADMIN} to report this.
EOF
exit;
};
# print STDERR "setting ",caller().'::AIS_IDENTITY', " to $Sessions{$Coo}->{identity}\n";
# $ENV{AIS_IDENTITY} = $Sessions{$Coo}->{identity};
$ENV{AIS_IDENTITY} =
${caller().'::AIS_IDENTITY'} = $Sessions{$Coo}->{identity};
tie %{caller().'::AIS_STASH'}, DirDB => ${tied(%{$Sessions{$Coo}})};
}; # import
1;
__END__
__END__
=head1 NAME
AIS::client - get an authenticated e-mail address for users of your web service
=head1 SYNOPSIS
BEGIN{umask(0077 & umask())}; # if your web server gives you a 0177 umask
use AIS::client;
print "Content-type: text/plain\n\nWelcome $AIS_IDENTITY\n";
print "this is page view number ", ++$AIS_STASH{accesses};
__END__
=head1 DESCRIPTION
The goal of AIS::client is to provide a very easy way to require an
authenticated identity for a perl web application. The user's e-mail
address appears in a global variable C<$AIS_IDENTITY> and a persistent
session stash is available in C<%AIS_STASH>.
=head1 USE-LINE CONFIGURATION OPTIONS
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test;
BEGIN { plan tests => 2 };
BEGIN {print <<EOF };
AIS::client redirects and exits, only achieving it's
aim of authenticating a user against a central AIS server
after at least three state-altering calls to itself.
If you can figure out a way to write a test harness for
it I'll gladly accept the patch.
under these lines you should see something like
Set-Cookie:/AIS_session=SomE1RanDoM5GaRBagE
Location: http://?AIS_INITIAL
( run in 0.495 second using v1.01-cache-2.11-cpan-de7293f3b23 )