Apache-AxKit-Plugin-Session
view release on metacpan or search on metacpan
lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN
use mod_perl qw(1.24 StackedHandlers MethodHandlers Authen Authz);
use Apache::Constants qw(:common M_GET REDIRECT MOVED);
use Apache::URI ();
use Apache::Cookie;
use URI::Escape;
use URI;
# store reason of failed authentication, authorization or login for later retrieval
#======================
sub orig_save_reason ($;$) {
#----------------------
my ($self, $error_message) = @_;
$self->debug(3,"======= save_reason(".join(',',@_).")");
my $r = Apache->request();
my $auth_name = $r->auth_name || 'AxKitSession';
my $auth_type = $r->auth_type || __PACKAGE__;
# Pass a cookie with the error reason that can be read after the redirect.
# Use a cookie with no time limit
if (@_ <= 1) {
# delete error message cookie if it exists
if ( exists $r->pnotes('COOKIES')->{$auth_type.'_'.$auth_name.'Reason'} ) {
$self->send_cookie(value=>'', name=>'Reason');
delete $r->pnotes('COOKIES')->{$auth_type.'_'.$auth_name.'Reason'};
}
} elsif ($error_message) {
# set error message cookie if error message exists
$self->send_cookie(name=>'Reason', value=>$error_message);
$r->pnotes('COOKIES')->{$auth_type.'_'.$auth_name.'Reason'} = $error_message;
}
}
# ____ End of save_reason ____
#==================
sub orig_get_reason($) {
#------------------
my ($self) = @_;
$self->debug(3,"======= orig_get_reason(".join(',',@_).")");
my $r = Apache->request();
my $auth_name = $r->auth_name || 'AxKitSession';
my $auth_type = $r->auth_type || __PACKAGE__;
parse_input();
return $r->pnotes('COOKIES')->{$auth_type.'_'.$auth_name.'Reason'};
}
# ____ End of get_reason ____
# save args of original request so it can be replayed after a redirect
#=====================
sub orig_save_params ($$) {
#---------------------
my ($self, $uri) = @_;
$self->debug(3,"======= save_params(".join(',',@_).")");
my $r = Apache->request();
parse_input(1);
$uri = new URI($uri);
$uri->query_form(%{$r->pnotes('INPUT')||{}});
return $uri->as_string;
}
# ____ End of save_params ____
# restore args of original request in $r->pnotes('INPUT')
#=======================
sub orig_restore_params ($) {
#-----------------------
my ($self) = @_;
$self->debug(3,"======= restore_params(".join(',',@_).")");
my $r = Apache->request();
parse_input();
}
# ____ End of restore_params ____
#===================
sub login_form ($) {
#-------------------
my ($self) = @_;
$self->debug(3,"======= login_form(".join(',',@_).")");
my $r = Apache->request();
my $auth_name = $r->auth_name || 'AxKitSession';
my $authen_script;
unless ($authen_script = $r->dir_config($auth_name.'LoginScript')) {
$r->log_reason("PerlSetVar '${auth_name}LoginScript' missing", $r->uri);
return SERVER_ERROR;
}
my $uri = uri_escape($r->uri);
$authen_script =~ s/((?:[?&])destination=)/$1$uri/;
$self->debug(3,"Internally redirecting to $authen_script");
$r->custom_response(FORBIDDEN, $authen_script);
return FORBIDDEN;
}
# ____ End of login_form ____
####################################################################################
# you don't normally need to override anything below
#================
sub debug ($$$) {
#----------------
my ($self, $level, $msg) = @_;
my $r = Apache->request();
my $debug = $r->dir_config('AxDebugSession') || 0;
$r->log_error($msg) if $debug >= $level;
}
# ____ End of debug ____
#================
sub parse_input {
#----------------
my ($full) = @_;
my $or = my $r = Apache->request();
while ($r->prev) {
$r = $r->prev;
$r = $r->main || $r;
}
if ($r->pnotes('INPUT') && $r ne $or) {
$or->pnotes('INPUT',$r->pnotes('INPUT'));
$or->pnotes('UPLOADS',$r->pnotes('UPLOADS'));
$or->pnotes('COOKIES',$r->pnotes('COOKIES'));
$or->pnotes('COOKIES',{}) unless $or->pnotes('COOKIES');
return;
}
my %cookies;
my %cookiejar = Apache::Cookie->new($r)->parse;
foreach (sort keys %cookiejar) {
my $cookie = $cookiejar{$_};
$cookies{$cookie->name} = $cookie->value;
}
$or->pnotes('COOKIES',\%cookies);
$r->pnotes('COOKIES',$or->pnotes('COOKIES')) if ($r ne $or);
# avoid parsing the input so later modules can modify it
return if (!$full);
return if $r->pnotes('INPUT');
# from Apache::RequestNotes
my $maxsize = $r->dir_config('MaxPostSize') || 1024;
my $uploads = $r->dir_config('DisableUploads') =~ m/Off/i ? 0 : 1;
my $apr = Apache::Request->instance($r,
POST_MAX => $maxsize,
DISABLE_UPLOADS => $uploads,
);
$r->pnotes('INPUT',$apr->parms);
$r->pnotes('UPLOADS',[ $apr->upload ]);
if ($r ne $or) {
$or->pnotes('INPUT',$r->pnotes('INPUT'));
$or->pnotes('UPLOADS',$r->pnotes('UPLOADS'));
}
}
# ____ End of parse_input ____
#===========================
sub external_redirect ($$) {
#---------------------------
my ($self, $uri) = @_;
$self->debug(3,"======= external_redirect(".join(',',@_).")");
my $r = Apache->request();
$r->header_out('Location' => $uri);
return $self->fixup_redirect($r);
}
# ____ End of external_redirect ____
#====================
sub send_cookie($@) {
#--------------------
my ($self, %settings) = @_;
$self->debug(3,"======= send_cookie(".join(',',@_).")");
my $r = Apache->request();
my $auth_name = $r->auth_name || 'AxKitSession';
my $auth_type = $r->auth_type || __PACKAGE__;
return if $r->dir_config($auth_name.'NoCookie');
$settings{name} = "${auth_type}_$auth_name".($settings{name}||'');
for (qw{Path Expires Domain Secure}) {
my $s = lc();
next if exists $settings{$s};
if (my $value = $r->dir_config($auth_name.$_)) {
$settings{$s} = $value;
}
delete $settings{$s} if !defined $settings{$s};
}
# need to do this so will return cookie when url is munged.
$settings{path} ||= '/';
$settings{domain} ||= $r->hostname;
my $cookie = Apache::Cookie->new($r, %settings);
$cookie->bake;
$r->err_headers_out->add("Set-Cookie" => $cookie->as_string);
$self->debug(3,'Sent cookie: ' . $cookie->as_string);
}
# ____ End of send_cookie ____
#=============
sub key ($) {
#-------------
lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN
sub translate_session_uri ($$) {
#-------------------------------
my ($self, $r) = @_;
$self->debug(3,"======= translate_session_uri(".join(',',@_).")");
$self->debug(3,"uri: ".$r->uri);
# Important! The existence of SessionPrefix is used as indicator
# that URL sessions are in use, so set it before declining
my $prefix = $r->dir_config('SessionPrefix') || 'Session-';
$r->notes('SessionPrefix',$prefix);
return DECLINED unless $r->is_initial_req;
# retrieve session id from URL or HTTP 'Referer:' header
my (undef, $session, $rest) = split /\/+/, $r->uri, 3;
$rest ||= '';
return DECLINED unless $session && $session =~ /^$prefix(.+)$/;
# Session ID found. Extract and make it available in notes();
$session = $1;
$self->debug(1,"Found session ID '$session' in url");
$r->notes(SESSION_ID => $session);
$r->subprocess_env(SESSION_ID => $session);
# Make the prefix and session available to CGI scripts for use in absolute
# links or redirects
$r->subprocess_env(SESSION_URLPREFIX => "/$prefix$session");
$r->notes(SESSION_URLPREFIX => "/$prefix$session");
# Remove the session from the URI
$r->uri( "/$rest" );
$self->debug(3,'Requested URI = \''.$r->uri."'");
return DECLINED;
}
# ____ End of translate_session_uri ____
# PerlHandler for location /redirect
# if reached via ErrorDocument 301/302 - add session ID for internal redirects/strip for external
# if reached directly, show a self-refreshing page (to strip off unwanted referer headers)
# can be called directly, be sure to set $r->header_out('Location') first
#========================
sub fixup_redirect ($$) {
#------------------------
my ($self, $r) = @_;
$self->debug(3,"======= fixup_redirect(".join(',',@_).")");
parse_input(1);
my $mr = $r;
while ($mr->prev) {
$mr = $mr->prev;
$mr = $mr->main || $mr;
}
$mr = $mr->main || $mr;
$r->pnotes('INPUT')->{'url'} = $1 if ($r->uri =~ m{^/[a-z]+(/.*)$});
$r->pnotes('INPUT')->{'url'} =~ s{^/([a-z0-9]+://)}{$1};
if (!$r->header_out('Location') && (!$r->prev || !$r->prev->header_out('Location')) && !$r->pnotes('INPUT')->{'url'}) {
$self->debug(1,'called without location header or url paramater');
return SERVER_ERROR;
}
my $session = $r->notes('SESSION_URLPREFIX') || $mr->notes('SESSION_URLPREFIX') || '';
my $uri;
$uri = Apache::URI->parse($r, $r->header_out('Location') || ($r->prev?$r->prev->header_out('Location'):undef) || $r->pnotes('INPUT')->{'url'});
if (!$uri->hostname) {
$uri->hostname($r->hostname);
$uri->port($r->get_server_port);
}
$self->debug(6,"Session: $session, uri: ".$uri->unparse);
my $same_host = (lc($uri->hostname) eq lc($r->hostname) && ($uri->port||80) == $r->server->port);
# we have not been internally redirected - show the refresh page, or redirect to
# ourselves first, if session id is still present
if ($same_host) {
$self->debug(6,"same host");
# add session ID and continue
if ($session && $uri->path !~ /^$session/) {
$self->debug(6,"adding session");
$uri->path($session.$uri->path);
}
} else {
$self->debug(6,"different host");
if ((!$r->prev || !$r->prev->header_out('Location')) && !$r->header_out('Location')) {
$self->debug(6,"called externally");
if (!$session || $mr->parsed_uri->path !~ /^$session/) {
$self->debug(6,"refresh");
# we have been called without session id. it's safe now to refresh
my $location = $uri->unparse;
my $message = <<EOF;
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<HTML>
<HEAD>
<TITLE>Redirecting...</TITLE>
<META HTTP-EQUIV=Refresh CONTENT="0; URL=$location">
</HEAD>
<BODY bgcolor="#ffffff" text="#000000">
<H1>Redirecting...</H1>
You are being redirected <A HREF="$location">here</A>.<P>
</BODY>
</HTML>
EOF
$r->content_type('text/html');
$r->send_http_header;
$r->print($message);
$r->rflush;
return OK;
}
}
$self->debug(6,"external redirect to self, ".$mr->uri);
# remove session ID and externally redirect to ourselves
if ($session && $mr->parsed_uri->path =~ /^$session/) {
my $myuri = $mr->parsed_uri;
$myuri->path($redirect_location.'/'.$uri->unparse);
$uri = $myuri;
}
$uri->path(substr($uri->path,length($session))) if ($session && $uri->path =~ /^$session/);
}
my $status = (($r->status != MOVED) && (!$r->prev || $r->prev->status != MOVED)?REDIRECT:MOVED);
my $location = $uri ? $uri->unparse : 'unknown';
my $description = ( $status == MOVED ) ? 'Moved Permanently' : 'Found';
$self->debug(6,"redirect to $location, status $status");
my $message = <<EOF;
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<HTML>
<HEAD>
<TITLE>$status $description</TITLE>
</HEAD>
<BODY>
<H1>$description</H1>
The document has moved <A HREF="$location">$location</A>.<P>
</BODY>
</HTML>
EOF
$r->content_type('text/html');
$r->status($status);
$r->header_out('Location', $location);
$r->header_out('URI', $location);
$r->send_http_header;
$r->print($message);
$r->rflush;
return $status;
}
# ____ End of fixup_redirect ____
# This one can be used as PerlHandler if a non-mod_perl script is doing the login form
# In that case, be sure to validate the login in authen_cred above!
#===============
sub login ($$) {
#---------------
my ($self, $r, $destination ) = @_;
$self->debug(3,"======= login(".join(',',@_).")");
my $auth_name = $r->auth_name || 'AxKitSession';
my $auth_type = $r->auth_type || __PACKAGE__;
parse_input(1);
my $args = $r->pnotes('INPUT');
$destination = $$args{'destination'} if @_ < 3;
if ($destination) {
$destination = URI->new_abs($destination, $r->uri);
} else {
my $mr = $r;
$mr = $mr->prev while ($mr->prev);
$mr = $mr->main while ($mr->main);
$destination = $mr->uri;
}
$self->debug(1,"destination = '$destination'");
# Get the credentials from the data posted by the client, if any.
my @credentials;
while (exists $$args{"credential_" . ($#credentials + 1)}) {
$self->debug(2,"credential_" . ($#credentials + 1) . "= '" .$$args{"credential_" . ($#credentials + 1)} . "'");
push(@credentials, $$args{"credential_" . ($#credentials + 1)});
}
# convert post to get
if ($r->method eq 'POST') {
$r->method('GET');
$r->method_number(M_GET);
$r->headers_in->unset('Content-Length');
}
$r->no_cache(1) unless $r->dir_config($auth_name.'Cache');
# Exchange the credentials for a session key.
my ($ses_key, $error_message) = $self->authen_cred($r, @credentials);
# Get the uri so can adjust path, and to redirect including the query string
unless ($ses_key) {
$self->debug(2,"No session returned from authen_cred: $error_message" );
$self->save_reason($error_message) if ($r->is_main());
} else {
$self->debug(2,"ses_key returned from authen_cred: '$ses_key'");
# Send cookie if a session was returned from authen_cred
$self->send_cookie(value=>$ses_key);
# add the session to the URI - if trans handler not installed prefix will be empty
if (my $prefix = $r->notes('SessionPrefix')) {
$r->notes('SESSION_URLPREFIX',"/$prefix$ses_key");
} elsif (!$r->dir_config($auth_name.'LoginScript' ) ||
lc($r->dir_config($auth_name.'LoginScript' )) eq 'none' ||
$destination eq $r->uri) {
# don't redirect if we only set a cookie
my ($auth_user, $error_message) = $auth_type->authen_ses_key($r, $ses_key);
$self->debug(2,"login() not redirecting, just setting cookie: user = $auth_user, SID = $ses_key");
return SERVER_ERROR unless defined $auth_user;
lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN
$r->auth_type($self);
$r->auth_name('AxKitSession') unless $r->auth_name;
my $rc = $self->authenticate($r);
return OK if $rc == DECLINED;
return $rc if $rc != OK;
$rc = $self->authorize($r,$r->requires||[{requirement => 'valid-user'}]);
return OK if $rc == DECLINED;
return $rc;
}
# this part does the real work and won't be very useful for
# customization/subclassing.
# You may consider skipping to the 'require' handlers below.
sub makeVariableName($) { my $x = shift; $x =~ s/[^a-zA-Z0-9]/_/g; $x; }
sub save_reason($;$) {
my ($self, $error_message) = @_;
$self->debug(3,"--------- save_reason(".join(',',@_).")");
my $session = Apache->request()->pnotes('SESSION') || return $self->orig_save_reason($error_message);
if (!$error_message) {
# delete error message
delete $$session{'auth_reason'};
delete $$session{'auth_location'};
} else {
# set error message
$$session{'auth_reason'} = $error_message;
my $r = Apache->request();
$$session{'auth_location'} = $r->uri;
$$session{'auth_location'} .= '?'.$r->args if ($r->args);
}
}
sub get_reason($) {
my ($self) = @_;
$self->debug(3,"--------- get_reason(".join(',',@_).")");
my $session = Apache->request()->pnotes('SESSION') || return $self->orig_get_reason();
$$session{'auth_reason'};
}
sub get_location($) {
my ($self) = @_;
$self->debug(3,"--------- get_location(".join(',',@_).")");
my $session = Apache->request()->pnotes('SESSION') || return undef;
$$session{'auth_location'};
}
sub save_params ($$) {
my ($self, $uri) = @_;
$self->debug(3,"--------- save_params(".join(',',@_).")");
my $r = Apache->request();
my $session = $r->pnotes('SESSION') || return $self->orig_save_params($uri);
parse_input(1);
my $in = $r->pnotes('INPUT');
my @out = ();
while(my($key,$val) = each %$in) {
push @out, $key, $val;
}
$$session{'auth_params'} = \@out;
return $uri;
}
sub restore_params ($) {
my ($self) = @_;
$self->debug(3,"--------- restore_params(".join(',',@_).")");
my $r = Apache->request();
my $session = $r->pnotes('SESSION') || return $self->orig_restore_params();
return $self->orig_restore_params() unless $$session{'auth_params'};
my @in = @{$$session{'auth_params'}};
my $out = new Apache::Table($r);
while (@in) {
$out->add($in[0],$in[1]);
shift @in; shift @in;
}
$r->pnotes('INPUT',$out);
delete $$session{'auth_params'};
}
sub _cleanup_session ($$) {
my ($self, $session) = @_;
$self->debug(3,"--------- _cleanup_session(".join(',',@_).")");
untie %{$session};
undef %{$session};
}
sub _get_session_from_store($$;$) {
my ($self, $r, $session_id) = @_;
$self->debug(3,"--------- _get_session_from_store(".join(',',@_).")");
my $auth_name = $r->auth_name || 'AxKitSession';
my @now = localtime;
my $session = {};
my $dir = $r->dir_config($auth_name.'Dir') || '/tmp/sessions';
my $absdir = $dir;
$absdir = $r->document_root.'/'.$dir if substr($dir,0,1) ne '/';
my $args = {
Directory => $absdir,
DataSource => $dir,
FileName => $absdir.'/sessions.db',
LockDirectory => $absdir.'/locks',
DirLevels => 3,
CounterFile => sprintf("$absdir/counters/%04d-%02d-%02d", $now[5]+1900,$now[4]+1,$now[3]),
$r->dir_config->get($auth_name.'ManagerArgs'),
};
eval {
eval "require ".($r->dir_config($auth_name.'Manager')||'Apache::Session::File') or die $@;
tie %{$session}, $r->dir_config($auth_name.'Manager')||'Apache::Session::File', $session_id, $args;
};
die "Session creation failed. Depending on which session module you use, make sure that directories $absdir, $absdir/locks or $absdir/counters, or database $dir exist and are writable. The error message was: $@" if $@ && !defined $session_id;
return $session;
}
sub _get_session($$;$) {
my ($self, $r, $session_id) = @_;
my $auth_name = $r->auth_name || 'AxKitSession';
$self->debug(3,"--------- _get_session(".join(',',@_).")");
my $dir = $r->dir_config($auth_name.'Dir') || '/tmp/sessions';
my $expire = ($r->dir_config($auth_name.'Expire') || 30) / 5 + 1; #/
my $check = $r->dir_config($auth_name.'IPCheck');
my $remote = ($check == 1?($r->header_in('X-Forwarded-For') || $r->connection->remote_ip):
$check == 2?($r->connection->remote_ip =~ m/(.*)\./):
$check == 3?($r->connection->remote_ip):
'');
my $guest = $r->dir_config($auth_name.'Guest') || 'guest';
my $mr = $r;
# find existing session - a bit more complicated than usual since the request could be in
# different stages of authentication
if (1 || $session_id) {
if ($mr->main && (!$mr->pnotes('SESSION') || $mr->pnotes('SESSION')->{'_session_id'} ne $session_id)) {
$mr = $mr->main;
#$self->debug(5,"main: ".$mr->main.", sid=".($mr->pnotes('SESSION')||{})->{'_session_id'});
}
#$self->debug(5,"prev: ".$mr->prev.", sid=".($mr->pnotes('SESSION')||{})->{'_session_id'});
while ($mr->prev && (!$mr->pnotes('SESSION') || $mr->pnotes('SESSION')->{'_session_id'} ne $session_id)) {
( run in 1.087 second using v1.01-cache-2.11-cpan-13bb782fe5a )