Apache-AxKit-Plugin-Session
view release on metacpan or search on metacpan
lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN
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;
$r->notes('SESSION_ID',$ses_key);
$r->connection->user($auth_user);
return OK;
}
}
if ($destination eq 'none') {
$self->debug(2,"login() not redirecting: requested by application");
return OK;
}
$self->debug(2,"login() redirecting to $destination");
return $self->external_redirect($destination);
}
# ____ End of login ____
# Again, this can be used as PerlHandler or called directly
# subclass this one if you want to invalidate a session db
# entry or something like that
#================
sub orig_logout ($$) {
#----------------
my ($self,$r, $location) = @_;
$self->debug(3,"======= logout(".join(',',@_).")");
my $auth_name = $r->auth_name || 'AxKitSession';
my $auth_type = $r->auth_type || __PACKAGE__;
# Send the Set-Cookie header to expire the auth cookie.
$self->send_cookie(value=>'');
lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN
}
my $session = {};
# retrieve session from a previous internal request
$session = $mr->pnotes('SESSION') if $mr->pnotes('SESSION'); # and $session_id;
$self->debug(5,"checkpoint beta, session={".join(',',keys %$session)."}");
# create/retrieve session, providing parameters for several common session managers
if (!keys %$session) {
$session = $self->_get_session_from_store($r,$session_id);
$r->register_cleanup(sub { _cleanup_session($self, $session) });
if ($@ && $guest) {
$self->debug(3, "sid $session_id invalid: $@");
return (undef, 'bad_session_provided');
}
}
$self->debug(5,"checkpoint charlie, sid=".$$session{'_session_id'}.", keys = ".join(",",keys %$session));
$$session{'auth_access_user'} = $guest unless exists $$session{'auth_access_user'};
$$session{'auth_first_access'} = time() unless exists $$session{'auth_first_access'};
$$session{'auth_expire'} = $expire unless exists $$session{'auth_expire'};
$expire = $$session{'auth_expire'};
$self->debug(4,'UID = '.$$session{'auth_access_user'});
# check if remote host changed or session expired; guest sessions never expire
if (exists $$session{'auth_remote_ip'} && $remote ne $$session{'auth_remote_ip'}) {
$self->debug(3, "ip mispatch");
return (undef, 'ip_mismatch') if ($$session{'auth_access_user'} && $$session{'auth_access_user'} ne $guest);
} elsif ($$session{'auth_access_user'} && $$session{'auth_access_user'} ne $guest && exists $$session{'auth_last_access'} && int(time()/300) > $$session{'auth_last_access'}+$expire) {
$self->debug(3, "session expired");
%$session = ();
eval { tied(%$session)->delete };
return (undef, 'session_expired');
} elsif (!exists $$session{'auth_remote_ip'}) {
$$session{'auth_remote_ip'} = $remote;
}
# force new session ID every 5 minutes if Apache::Session::Counted is used, don't write session file on each access
$$session{'auth_last_access'} = int(time()/300) if $$session{'auth_last_access'} < int(time()/300);
# store session hash in pnotes
$r->pnotes('SESSION',$session);
# global application data
my $globals = $mr->pnotes('GLOBAL');
if (!$globals) {
$globals = {};
if (my $tie = $r->dir_config($auth_name.'Global')) {
my ($tie, @tie) = split(/,/,$tie);
eval "require $tie" || die "Could not load ${auth_name}Global module $tie[0], did you install it? $@";
tie(%$globals, $tie, @tie) || die "Could tie ${auth_name}Global: $@";
$r->register_cleanup(sub { _cleanup_session($self, $globals) });
}
}
$r->pnotes('GLOBAL',$globals);
return $session;
}
# this is a NO-OP! Don't use this one (or ->login) directly,
# unless you have verified the credentials yourself or don't
# want user logins
sub authen_cred($$\@) {
my ($self, $r, @credentials) = @_;
$self->debug(3,"--------- authen_cred(".join(',',@_).")");
my ($session, $err) = $self->_get_session($r);
return (undef, $err) if $err;
$$session{'auth_access_user'} = $credentials[0] if defined $credentials[0];
$r->pnotes('SESSION',$session);
return $$session{'_session_id'};
}
sub authen_ses_key($$$) {
my ($self, $r, $session_id) = @_;
$self->debug(3,"--------- authen_ses_key(".join(',',@_).")");
my ($session, $err) = $self->_get_session($r, $session_id);
return (undef, $err) if $err;
return ($session_id eq $$session{'_session_id'})?$$session{'auth_access_user'}:undef;
}
sub logout($$) {
my ($self) = shift;
my ($r) = @_;
$self->debug(3,"--------- logout(".join(',',$self,@_).")");
my $session = $r->pnotes('SESSION');
eval {
%$session = ('_session_id' => $$session{'_session_id'});
my $obj = tied(%$session);
untie(%$session);
$obj->delete;
};
$self->debug(5,'session delete failed: '.$@) if $@;
return $self->orig_logout(@_);
}
# 'require' handlers
sub subrequest($$) {
my ($self, $r) = @_;
$self->debug(3,"--------- subrequest(".join(',',@_).")");
return ($r->is_initial_req?FORBIDDEN:OK);
}
sub group($$) {
my ($self, $r, $args) = @_;
$self->debug(3,"--------- group(".join(',',@_).")");
my $session = $r->pnotes('SESSION');
my $groups = $$session{'auth_access_group'};
$self->debug(10,"Groups: $groups");
$groups = { $groups => undef } if !ref($groups);
$groups = {} if (!$groups || ref($groups) ne 'HASH');
foreach (split(/\s+/,$args)) {
return OK if exists $$groups{$_};
}
return FORBIDDEN;
}
sub level($$) {
my ($self, $r, $args) = @_;
$self->debug(3,"--------- level(".join(',',@_).")");
my $session = $r->pnotes('SESSION');
if (exists $$session{'auth_access_level'}) {
return OK if ($$session{'auth_user_level'} >= $args);
}
return FORBIDDEN;
}
( run in 0.562 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )