use
vars
qw($redirect_location)
;
BEGIN {
$Apache::AxKit::Plugin::Session::VERSION
= 0.93;
}
use
mod_perl
qw(1.24 StackedHandlers MethodHandlers Authen Authz)
;
sub
orig_save_reason ($;$) {
my
(
$self
,
$error_message
) =
@_
;
$self
->debug(3,
"======= save_reason("
.
join
(
','
,
@_
).
")"
);
my
$r
= Apache->request();
my
(
$auth_name
,
$auth_type
) = (
$r
->auth_name,
$r
->auth_type);
if
(
@_
<= 1) {
if
(
exists
$r
->pnotes(
'COOKIES'
)->{
$auth_type
.
'_'
.
$auth_name
.
'Reason'
} ) {
$self
->send_cookie(
value
=>
''
,
name
=>
'Reason'
,
expires
=>
'-1d'
);
delete
$r
->pnotes(
'COOKIES'
)->{
$auth_type
.
'_'
.
$auth_name
.
'Reason'
};
}
}
elsif
(
$error_message
) {
$self
->send_cookie(
name
=>
'Reason'
,
value
=>
$error_message
);
$r
->pnotes(
'COOKIES'
)->{
$auth_type
.
'_'
.
$auth_name
.
'Reason'
} =
$error_message
;
}
}
sub
orig_get_reason($) {
my
(
$self
) =
@_
;
$self
->debug(3,
"======= orig_get_reason("
.
join
(
','
,
@_
).
")"
);
my
$r
= Apache->request();
my
(
$auth_name
,
$auth_type
) = (
$r
->auth_name,
$r
->auth_type);
parse_input();
return
$r
->pnotes(
'COOKIES'
)->{
$auth_type
.
'_'
.
$auth_name
.
'Reason'
};
}
sub
orig_save_params ($$) {
my
(
$self
,
$uri
) =
@_
;
$self
->debug(3,
"======= save_params("
.
join
(
','
,
@_
).
")"
);
my
$r
= Apache->request();
parse_input();
$uri
= new URI(
$uri
);
$uri
->query_form(%{
$r
->pnotes(
'INPUT'
)});
return
$uri
->as_string;
}
sub
orig_restore_params ($) {
my
(
$self
) =
@_
;
$self
->debug(3,
"======= restore_params("
.
join
(
','
,
@_
).
")"
);
my
$r
= Apache->request();
parse_input();
}
sub
login_form ($) {
my
(
$self
) =
@_
;
$self
->debug(3,
"======= login_form("
.
join
(
','
,
@_
).
")"
);
my
$r
= Apache->request();
my
$auth_name
=
$r
->auth_name;
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;
}
sub
debug ($$$) {
my
(
$self
,
$level
,
$msg
) =
@_
;
my
$r
= Apache->request();
my
$debug
=
$r
->dir_config(
'AuthCookieURLDebug'
) || 0;
$r
->log_error(
$msg
)
if
$debug
>=
$level
;
}
sub
parse_input {
my
$or
=
my
$r
= Apache->request();
return
if
$r
->pnotes(
'INPUT'
);
while
(
$r
->prev) {
$r
=
$r
->prev;
$r
=
$r
->main ||
$r
;
}
if
(
$r
->pnotes(
'INPUT'
)) {
if
(
$r
ne
$or
) {
$or
->pnotes(
'INPUT'
,
$r
->pnotes(
'INPUT'
));
$or
->pnotes(
'UPLOADS'
,
$r
->pnotes(
'UPLOADS'
));
$or
->pnotes(
'COOKIES'
,
$r
->pnotes(
'COOKIES'
));
}
return
;
}
Apache::RequestNotes::handler(
$r
);
$r
->pnotes(
'INPUT'
,{})
unless
$r
->pnotes(
'INPUT'
);
$r
->pnotes(
'UPLOADS'
,[])
unless
$r
->pnotes(
'UPLOADS'
);
$r
->pnotes(
'COOKIES'
,{})
unless
$r
->pnotes(
'COOKIES'
);
if
(
$r
ne
$or
) {
$or
->pnotes(
'INPUT'
,
$r
->pnotes(
'INPUT'
));
$or
->pnotes(
'UPLOADS'
,
$r
->pnotes(
'UPLOADS'
));
$or
->pnotes(
'COOKIES'
,
$r
->pnotes(
'COOKIES'
));
}
}
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
);
}
sub
send_cookie($@) {
my
(
$self
,
%settings
) =
@_
;
$self
->debug(3,
"======= send_cookie("
.
join
(
','
,
@_
).
")"
);
my
$r
= Apache->request();
my
(
$auth_name
,
$auth_type
) = (
$r
->auth_name,
$r
->auth_type);
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
};
}
$settings
{path} ||=
'/'
;
$settings
{domain} ||=
$r
->hostname;
$settings
{expires} ||=
'+1d'
;
my
$cookie
= Apache::Cookie->new(
$r
,
%settings
);
$cookie
->bake;
$self
->debug(3,
'Sent cookie: '
.
$cookie
->as_string);
}
sub
key ($) {
my
$self
=
shift
;
$self
->debug(3,
"======= key("
.
join
(
','
,
@_
).
")"
);
my
$r
= Apache->request;
my
(
$auth_type
,
$auth_name
) = (
$r
->auth_type,
$r
->auth_name);
parse_input();
my
$mr
=
$r
;
while
(
$mr
->prev) {
last
if
$mr
->notes(
'SESSION_ID'
);
$mr
=
$mr
->prev;
last
if
$mr
->notes(
'SESSION_ID'
);
$mr
=
$r
->main ||
$mr
;
}
my
$session
=
$mr
->notes(
'SESSION_ID'
);
if
(
$session
) {
$r
->notes(
'SESSION_ID'
,
$session
);
$self
->debug(5,
"- present session: $session"
);
return
$session
;
}
$session
=
$r
->pnotes(
'COOKIES'
)->{
$auth_type
.
'_'
.
$auth_name
};
if
(
$session
) {
$self
->debug(5,
"- cookie session: $session"
);
$r
->notes(
'SESSION_ID'
,
$session
);
return
$session
;
}
my
$prefix
=
$r
->notes(
'SessionPrefix'
);
$self
->debug(5,
"- session referer: "
.
$mr
->header_in(
'Referer'
));
if
(
$prefix
&&
$mr
->header_in(
'Referer'
)) {
my
$rest
=
$mr
->uri.(
$r
->args?
'?'
.
$r
->args:
''
);
my
$ref
=
$session
=
$mr
->header_in(
'Referer'
);
$session
=~ s/^https?:\/\///i;
my
$x
;
$x
=
$mr
->hostname;
$session
=~ s/^
$x
//i;
$x
=
$mr
->server->port;
$session
=~ s/^:
$x
//i;
$session
=~ s/^\/+([^\/]+)\/.*$/$1/;
$self
->debug(5,
"- session after stripping: $session, prefix: $prefix"
);
if
(
substr
(
$session
,0,
length
(
$prefix
)) eq
$prefix
) {
$self
->debug(4,
"Referer: "
.
$r
->header_in(
'Referer'
).
", session: $session"
);
if
(
substr
(
$rest
,0,1) eq
'/'
) {
$self
->debug(1,
"! absolute link from $ref to $rest"
);
$r
->status(REDIRECT);
$self
->external_redirect(
$self
->save_params(
"/$session$rest"
));
return
REDIRECT;
}
}
else
{
undef
$session
;
}
}
$r
->notes(
'SESSION_ID'
,
$session
);
return
$session
;
}
sub
recognize_user ($$) {
my
(
$self
,
$r
) =
@_
;
$self
->debug(3,
"======= recognize_user("
.
join
(
','
,
@_
).
")"
);
my
(
$auth_type
,
$auth_name
) = (
$r
->auth_type,
$r
->auth_name);
return
unless
$auth_type
&&
$auth_name
;
my
$session
=
$self
->key();
return
REDIRECT
if
$session
eq REDIRECT;
$self
->debug(1,
"session provided = '$session'"
);
return
OK
unless
$session
;
if
(
my
(
$user
) =
$auth_type
->authen_ses_key(
$r
,
$session
)) {
$self
->debug(2,
"recognize user = '$user'"
);
$r
->connection->user(
$user
);
}
return
OK;
}
sub
translate_session_uri ($$) {
my
(
$self
,
$r
) =
@_
;
$self
->debug(3,
"======= translate_session_uri("
.
join
(
','
,
@_
).
")"
);
$self
->debug(3,
"uri: "
.
$r
->uri);
my
$prefix
=
$r
->dir_config(
'SessionPrefix'
) ||
'Session-'
;
$r
->notes(
'SessionPrefix'
,
$prefix
);
return
DECLINED
unless
$r
->is_initial_req;
my
(
undef
,
$session
,
$rest
) =
split
/\/+/,
$r
->uri, 3;
$rest
||=
''
;
return
DECLINED
unless
$session
&&
$session
=~ /^
$prefix
(.+)$/;
$session
= $1;
$self
->debug(1,
"Found session ID '$session' in url"
);
$r
->notes(
SESSION_ID
=>
$session
);
$r
->subprocess_env(
SESSION_ID
=>
$session
);
$r
->subprocess_env(
SESSION_URLPREFIX
=>
"/$prefix$session"
);
$r
->notes(
SESSION_URLPREFIX
=>
"/$prefix$session"
);
$r
->uri(
"/$rest"
);
$self
->debug(3,
'Requested URI = \''
.
$r
->uri.
"'"
);
return
DECLINED;
}
sub
fixup_redirect ($$) {
my
(
$self
,
$r
) =
@_
;
$self
->debug(3,
"======= fixup_redirect("
.
join
(
','
,
@_
).
")"
);
parse_input();
$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'
) || (
$r
->prev?
$r
->prev->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'
});
my
$same_host
= (!
$uri
->hostname || (
lc
(
$uri
->hostname) eq
lc
(
$r
->hostname) && (
$uri
->port||80) ==
$r
->server->port));
if
(
$same_host
) {
$self
->debug(6,
"same host"
);
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
||
$uri
->main->parsed_uri->path !~ /^
$session
/) {
$self
->debug(6,
"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"
);
$uri
->path(
substr
(
$uri
->path,
length
(
$session
)))
if
(
$session
&&
$uri
->path =~ /^
$session
/);
if
(
$session
&&
$r
->main &&
$r
->main->parsed_uri->path =~ /^
$session
/) {
my
$myuri
=
$r
->parsed_uri;
$myuri
->query(
'url='
.uri_escape(
$uri
->unparse));
$uri
=
$myuri
;
}
}
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
;
}
sub
login ($$) {
my
(
$self
,
$r
,
$destination
) =
@_
;
$self
->debug(3,
"======= login("
.
join
(
','
,
@_
).
")"
);
my
(
$auth_type
,
$auth_name
) = (
$r
->auth_type,
$r
->auth_name);
parse_input();
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'"
);
my
@credentials
;
while
(
exists
$$args
{
"credential_"
. (
$#credentials
+ 1)}) {
$self
->debug(2,
"credential_"
. (
$#credentials
+ 1) .
"= '"
.
$$args
{
"credential_"
. (
$#credentials
+ 1)} .
"'"
);
push
(
@credentials
,
$$args
{
"credential_"
. (
$#credentials
+ 1)});
}
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'
);
my
(
$ses_key
,
$error_message
) =
$self
->authen_cred(
$r
,
@credentials
);
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'"
);
$self
->send_cookie(
value
=>
$ses_key
);
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) {
my
(
$auth_user
,
$error_message
) =
$auth_type
->authen_ses_key(
$r
,
$ses_key
);
$self
->debug(2,
"login() not redirecting, user = $auth_user, SID = $ses_key"
);
return
SERVER_ERROR
unless
defined
$auth_user
;
$r
->notes(
'SESSION_ID'
,
$ses_key
);
$r
->connection->auth_type(
$auth_type
);
$r
->connection->user(
$auth_user
);
return
OK;
}
}
$self
->debug(2,
"login() redirecting to $destination"
);
return
$self
->external_redirect(
$destination
);
}
sub
orig_logout ($$) {
my
(
$self
,
$r
,
$location
) =
@_
;
$self
->debug(3,
"======= logout("
.
join
(
','
,
@_
).
")"
);
my
(
$auth_type
,
$auth_name
) = (
$r
->auth_type,
$r
->auth_name);
$self
->send_cookie(
value
=>
'none'
,
expires
=>
'-1d'
);
$r
->no_cache(1)
unless
$r
->dir_config(
$auth_name
.
'Cache'
);
$location
=
$r
->dir_config(
$auth_name
.
'LogoutURI'
)
if
@_
< 3;
$r
->notes(
'SESSION_URLPREFIX'
,
undef
);
return
OK
if
!
$location
;
$r
->header_out(
Location
=>
$location
);
return
REDIRECT;
}
sub
authenticate ($$) {
my
(
$self
,
$r
) =
@_
;
my
$auth_type
=
$self
;
$self
->debug(3,
"======= authenticate("
.
join
(
','
,
@_
).
")"
);
my
(
$authen_script
,
$auth_user
);
return
OK
if
lc
$r
->auth_name eq
'none'
;
return
OK
if
$r
->uri eq
$r
->dir_config((
$r
->auth_name).
'LoginScript'
);
if
(
$r
->auth_type ne
$auth_type
) {
$self
->debug(3,
"AuthType mismatch: $auth_type != "
.
$r
->auth_type);
return
DECLINED;
}
my
$auth_name
=
$r
->auth_name;
$self
->debug(2,
"auth_name= '$auth_name'"
);
unless
(
$auth_name
) {
$r
->log_reason(
"AuthName not set, AuthType=$auth_type"
,
$r
->uri);
return
SERVER_ERROR;
}
parse_input();
my
$session
=
$self
->key;
return
REDIRECT
if
$session
eq REDIRECT;
$self
->debug(1,
"session provided = '$session'"
);
$self
->debug(2,
"requested uri = '"
.
$r
->uri .
"'"
);
my
$error_message
;
unless
(
$session
) {
$error_message
=
'no_session_provided'
;
}
else
{
(
$auth_user
,
$error_message
) =
$auth_type
->authen_ses_key(
$r
,
$session
);
if
(
defined
$auth_user
) {
$r
->connection->auth_type(
$auth_type
);
$r
->connection->user(
$auth_user
);
$self
->debug(1,
"user authenticated as $auth_user. Exiting Authen."
);
if
(
$r
->pnotes(
'COOKIES'
) &&
$r
->pnotes(
'COOKIES'
)->{
$auth_type
.
'_'
.
$auth_name
} &&
$r
->pnotes(
'COOKIES'
)->{
$auth_type
.
'_'
.
$auth_name
} eq
$session
&&
$r
->notes(
'SESSION_URLPREFIX'
)) {
my
$uri
=
$r
->uri;
$uri
.=
'?'
.
$r
->args
if
$r
->args;
my
$query
=
$self
->save_params(
$uri
);
$self
->debug(3,
"URL and Cookies are in use - redirecting to '$query'"
);
$r
->notes(
'SESSION_URLPREFIX'
,
undef
);
return
$self
->external_redirect(
$query
);
}
return
OK;
}
else
{
$self
->debug(1,
'Bad session key sent.'
);
$auth_type
->send_cookie(
value
=>
'none'
,
expires
=>
'-1d'
);
$error_message
||=
'bad_session_provided'
;
}
}
if
(!
$r
->dir_config(
$auth_name
.
'LoginScript'
) ||
lc
(
$r
->dir_config(
$auth_name
.
'LoginScript'
)) eq
'none'
) {
$self
->debug(2,
'LoginScript=NONE - calling login()'
);
my
$rc
=
$auth_type
->login(
$r
,
$self
->save_params(
$r
->uri));
$self
->save_reason(
$error_message
)
if
(
$r
->is_main());
return
$rc
;
}
$self
->save_reason(
$error_message
)
if
(
$r
->is_main());
return
$self
->login_form;
}
sub
get_permissions($$) {
my
(
$self
,
$r
) =
@_
;
my
$reqs
=
$r
->requires ||
return
();
return
map
{ [
split
/\s+/,
$_
->{requirement}, 2 ] }
@$reqs
;
}
sub
user($$) {
my
(
$self
,
$r
,
$args
) =
@_
;
$self
->debug(3,
"======= user("
.
join
(
','
,
@_
).
")"
);
my
$user
=
$r
->connection->user;
return
OK
if
grep
{
$user
eq
$_
}
split
/\s+/,
$args
;
return
FORBIDDEN;
}
sub
initialize_url_sessions($@) {
my
(
$self
,
$redirect_location
) =
@_
;
$redirect_location
||=
'/redirect'
;
push
@Apache::ReadConfig::PerlTransHandler
,
$self
.
'->translate_session_uri'
;
$Apache::ReadConfig::Location
{
$redirect_location
} = {
'AuthName'
=>
'none'
,
'SetHandler'
=>
'perl-script'
,
'PerlHandler'
=>
$self
.
'->fixup_redirect'
,
};
push
@Apache::ReadConfig::ErrorDocument
, [ 302,
$redirect_location
];
push
@Apache::ReadConfig::ErrorDocument
, [ 301,
$redirect_location
];
}
$redirect_location
||=
'/redirect'
;
__PACKAGE__->initialize_url_sessions(
$redirect_location
)
if
(
$Apache::Server::Starting
);
sub
has_permission {
my
(
$r
,
$attr_target
) =
@_
;
$attr_target
= URI->new_abs(
$attr_target
,
$r
->uri);
return
1
if
(
$r
->uri eq
$attr_target
);
my
$subr
=
$r
->lookup_uri(
$attr_target
);
return
$subr
->status == 200;
}
sub
handler {
my
(
$r
) =
@_
;
my
$self
= __PACKAGE__;
return
OK
if
$r
->connection->user or
$r
->auth_type ne
$self
;
$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
);
return
OK
if
$rc
== DECLINED;
return
$rc
;
}
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
$$session
{
'auth_reason'
};
delete
$$session
{
'auth_location'
};
}
else
{
$$session
{
'auth_reason'
} =
$error_message
;
my
$r
= Apache->request();
$$session
{
'auth_location'
} =
$r
->uri;
$$session
{
'auth_location'
} .=
'?'
.
$r
->args
if
(
$r
->args);
warn
(
"saved location: "
.
$$session
{
'auth_location'
});
}
}
sub
get_reason($) {
my
(
$self
) =
@_
;
$self
->debug(3,
"--------- get_reason("
.
join
(
','
,
@_
).
")"
);
my
$session
= Apache->request()->pnotes(
'SESSION'
) ||
return
$self
->orig_get_reason();
warn
(
"got location: "
.
$$session
{
'auth_location'
});
$$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
);
$self
->parse_input();
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;
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
{
tie
%{
$session
},
$r
->dir_config(
$auth_name
.
'Manager'
)||
'Apache::Session::File'
,
$session_id
,
$args
;
};
return
$session
;
}
sub
_get_session($$;$) {
my
(
$self
,
$r
,
$session_id
) =
@_
;
my
$auth_name
=
$r
->auth_name;
$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
;
if
(
$session_id
) {
if
(
$mr
->main && (!
$mr
->pnotes(
'SESSION'
) ||
$mr
->pnotes(
'SESSION'
)->{
'_session_id'
} ne
$session_id
)) {
$mr
=
$mr
->main;
}
while
(
$mr
->prev && (!
$mr
->pnotes(
'SESSION'
) ||
$mr
->pnotes(
'SESSION'
)->{
'_session_id'
} ne
$session_id
)) {
$mr
=
$mr
->prev;
if
(
$mr
->main && (!
$mr
->pnotes(
'SESSION'
) ||
$mr
->pnotes(
'SESSION'
)->{
'_session_id'
} ne
$session_id
)) {
$mr
=
$mr
->main;
}
}
$mr
||=
$r
;
}
my
$session
= {};
$session
=
$mr
->pnotes(
'SESSION'
)
if
$mr
->pnotes(
'SESSION'
);
$self
->debug(5,
"checkpoint beta, session={"
.
join
(
','
,
keys
%$session
).
"}"
);
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'
});
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'
} &&
time
()/300 >
$$session
{
'auth_last_access'
}+
$expire
) {
$self
->debug(3,
"session expired"
);
return
(
undef
,
'session_expired'
);
}
elsif
(!
exists
$$session
{
'auth_remote_ip'
}) {
$$session
{
'auth_remote_ip'
} =
$remote
;
}
$$session
{
'auth_last_access'
} =
time
()/300;
$r
->pnotes(
'SESSION'
,
$session
);
my
$globals
=
$mr
->pnotes(
'GLOBAL'
);
if
(!
$globals
) {
$globals
= {};
eval
{
$globals
=
$self
->_get_session_from_store(
$r
,
$r
->dir_config(
'SessionGlobal'
)||
"00000000000000000000000000000000"
);
};
if
(!
tied
(
%$globals
)) {
$globals
=
$self
->_get_session_from_store(
$r
);
$$globals
{
'_session_id'
} =
$r
->dir_config(
'SessionGlobal'
)||
"00000000000000000000000000000000"
;
my
$sessobj
=
tied
(
%$globals
);
$sessobj
->release_write_lock;
$sessobj
->{status} = Apache::Session::NEW;
$sessobj
->save;
}
$$globals
{
'_creation_time'
} =
time
()
unless
exists
$$globals
{
'_creation_time'
};
$r
->pnotes(
'GLOBAL'
,
$globals
);
$session
=
$self
->_get_session(
$r
)
if
$$globals
{
'_session_id'
} eq
$$session
{
'_session_id'
};
$r
->register_cleanup(
sub
{ _cleanup_session(
$self
,
$globals
) });
}
$r
->pnotes(
'GLOBAL'
,
$globals
);
return
$session
;
}
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];
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'
});
tied
(
%$session
)->
delete
;
};
$self
->debug(5,
'session delete failed: '
.$@)
if
$@;
return
$self
->orig_logout(
@_
);
}
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;
}
sub
combined($$) {
my
(
$self
,
$r
,
$args
) =
@_
;
$self
->debug(3,
"--------- combined("
.
join
(
','
,
@_
).
")"
);
my
(
$requirement
,
$arg
);
while
(
$args
=~ m/\s*(.*?)\s+(
"(?:.*?(?:\\\\|\\"
))*.*?
"(?:\s|$)|[^"
\t\r\n].*?(?:\s|$))/g) {
(
$requirement
,
$arg
) = ($1, $2);
$arg
=~ s/^
"|"
\s?$//g;
$arg
=~ s/\\([\\"])/$1/g;
$requirement
= makeVariableName(
$requirement
);
no
strict
'refs'
;
my
$rc
=
$self
->
$requirement
(
$r
,
$arg
);
$self
->debug(4,
"-------- $requirement returned $rc"
);
return
FORBIDDEN
if
$rc
!= OK;
}
return
OK;
}
sub
alternate($$) {
my
(
$self
,
$r
,
$args
) =
@_
;
$self
->debug(3,
"--------- alternate("
.
join
(
','
,
@_
).
")"
);
my
(
$requirement
,
$arg
);
while
(
$args
=~ m/\s*(.*?)\s+(
"(?:.*?(?:\\\\|\\"
))*.*?
"(?:\s|$)|[^"
\t\r\n].*?(?:\s|$))/g) {
(
$requirement
,
$arg
) = ($1, $2);
$arg
=~ s/^
"|"
\s?$//g;
$arg
=~ s/\\([\\"])/$1/g;
$requirement
= makeVariableName(
$requirement
);
no
strict
'refs'
;
my
$rc
=
$self
->
$requirement
(
$r
,
$arg
);
$self
->debug(4,
"-------- $requirement returned $rc"
);
return
OK
if
$rc
== OK;
}
return
FORBIDDEN;
}
sub
not($$) {
my
(
$self
,
$r
,
$args
) =
@_
;
$self
->debug(3,
"--------- not("
.
join
(
','
,
@_
).
")"
);
my
(
$requirement
,
$arg
) =
split
/\s+/,
$args
, 2;
$requirement
= makeVariableName(
$requirement
);
no
strict
'refs'
;
my
$rc
=
$self
->
$requirement
(
$r
,
$arg
);
$self
->debug(4,
"-------- $requirement returned $rc"
);
return
FORBIDDEN
if
$rc
== OK;
return
OK;
}
sub
default_unpack_requirement {
my
(
$self
,
$req
,
$args
) =
@_
;
return
[
$req
=> [
split
(/\s+/,
$args
) ] ];
}
*unpack_requirement_subrequest
= \
&default_unpack_requirement
;
*unpack_requirement_valid_user
= \
&default_unpack_requirement
;
*unpack_requirement_user
= \
&default_unpack_requirement
;
*unpack_requirement_group
= \
&default_unpack_requirement
;
*unpack_requirement_level
= \
&default_unpack_requirement
;
sub
unpack_requirement_combined {
my
(
$self
,
$req
,
$args
) =
@_
;
no
strict
'refs'
;
my
(
$requirement
,
$arg
);
my
$rc
= [
$req
=> [] ];
while
(
$args
=~ m/\s*(.*?)\s+(
"(?:.*?(?:\\\\|\\"
))*.*?
"(?:\s|$)|[^"
\t\r\n].*?(?:\s|$))/g) {
(
$requirement
,
$arg
) = ($1, $2);
$arg
=~ s/^
"|"
\s?$//g;
$arg
=~ s/\\([\\"])/$1/g;
my
$sub
=
"unpack_requirement_"
.makeVariableName(
$requirement
);
push
@{
$$rc
[1]},
$self
->
$sub
(
$requirement
,
$arg
);
}
return
$rc
;
}
*unpack_requirement_alternate
= \
&unpack_requirement_combined
;
sub
unpack_requirement_not {
my
(
$self
,
$req
,
$args
) =
@_
;
no
strict
'refs'
;
my
(
$requirement
,
$arg
) =
split
/\s+/,
$args
, 2;
my
$sub
=
"unpack_requirement_"
.makeVariableName(
$requirement
);
return
[
'not'
=>
$self
->
$sub
(
$requirement
,
$arg
) ];
}
sub
default_pack_requirement {
my
(
$self
,
$args
) =
@_
;
return
join
(
' '
,@{
$$args
[1]});
}
*pack_requirement_subrequest
= \
&default_pack_requirement
;
*pack_requirement_valid_user
= \
&default_pack_requirement
;
*pack_requirement_user
= \
&default_pack_requirement
;
*pack_requirement_group
= \
&default_pack_requirement
;
*pack_requirement_level
= \
&default_pack_requirement
;
sub
pack_requirement_combined {
my
(
$self
,
$args
) =
@_
;
no
strict
'refs'
;
my
$rc
=
''
;
foreach
my
$req
(@{
$$args
[1]}) {
my
$sub
=
"pack_requirement_"
.makeVariableName(
$$req
[0]);
my
$res
=
$self
->
$sub
(
$req
);
$res
=~ s/([\\"])/\\$1/g;
$rc
.=
$$req
[0].
" \"$res\" "
;
}
return
substr
(
$rc
,0,-1);
}
*pack_requirement_alternate
= \
&pack_requirement_combined
;
sub
pack_requirement_not {
my
(
$self
,
$args
) =
@_
;
no
strict
'refs'
;
my
$sub
=
"pack_requirement_"
.makeVariableName(
$$args
[1][0]);
return
$$args
[1][0].
' '
.
$self
->
$sub
(
$$args
[1]);
}
sub
set_permissions($$@) {
my
(
$self
,
$r
,
@perms
) =
@_
;
@perms
=
map
{
'require '
.
$_
->[0].
' '
.
$_
->[1].
"\n"
}
@perms
;
if
(
$r
->uri =~ m/
push
@perms
,
"SetHandler perl-script\n"
;
push
@perms
,
"PerlHandler \"sub { &Apache::Constants::NOT_FOUND; }\"\n"
;
}
my
$configfile
=
$r
->dir_config(
$r
->auth_name.
'AuthFile'
) ||
die
'read the fine manual.'
;
local
(
*IN
,
*OUT
);
if
(
substr
(
$configfile
,0,1) eq
'/'
) {
open
(IN,
$configfile
) ||
die
"file open error (read): $configfile"
;
open
(OUT,
">$configfile.new"
) ||
die
"file open error (write): $configfile.new"
;
while
(
my
$line
= <IN>) {
print
OUT
$line
unless
$line
eq
'# do not modify - autogenerated. # '
.
$r
->uri.
"\n"
;
while
(
my
$line
= <IN> &&
$line
ne
"# end of autogenerated fragment\n"
) {}
}
close
(IN);
print
OUT
'# do not modify - autogenerated. # '
.
$r
->uri.
"\n"
;
print
OUT
'<Location '
.
$r
->uri.
">\n"
;
print
OUT
@perms
;
print
OUT
"</Location>\n"
;
print
OUT
"# end of autogenerated fragment\n"
;
close
(OUT);
rename
(
"$configfile.new"
,
$configfile
);
}
else
{
my
$dir
=
$r
->filename;
$dir
=~ s{[^/]*$}{
$configfile
};
my
$file
=
$r
->uri;
$file
=~ s{.*\/}{};
$file
.=
$r
->path_info;
my
@lines
;
if
(
open
(IN,
$dir
)) {
@lines
= <IN>;
close
(IN);
}
open
(OUT,
">$dir"
) ||
die
"file open error (write): $dir"
;
my
$skip
= 0;
for
my
$line
(
@lines
) {
$skip
= 1
if
$line
eq
'# do not modify - autogenerated. # '
.
$r
->uri.
"\n"
;
print
OUT
$line
unless
$skip
;
$skip
= 0
if
$line
eq
"# end of autogenerated fragment\n"
;
}
print
OUT
'# do not modify - autogenerated. # '
.
$r
->uri.
"\n"
;
print
OUT
'<Files '
.
$file
.
">\n"
;
print
OUT
@perms
;
print
OUT
"</Files>\n"
;
print
OUT
"# end of autogenerated fragment\n"
;
close
(OUT);
}
}
sub
get_permission_set($$) {
my
(
$self
,
$r
) =
@_
;
my
@rc
= ();
foreach
my
$req
(
$self
->get_permissions(
$r
)) {
$$req
[1] =
''
unless
defined
$$req
[1];
my
$sub
=
'unpack_requirement_'
.makeVariableName(
$$req
[0]);
push
@rc
,
$self
->
$sub
(
@$req
);
}
return
@rc
;
}
sub
set_permission_set($$@) {
my
(
$self
,
$r
,
@reqs
) =
@_
;
my
@rc
;
my
$req
;
foreach
my
$req
(
@reqs
) {
my
$sub
=
"pack_requirement_"
.makeVariableName(
$$req
[0]);
push
@rc
, [
$$req
[0],
$self
->
$sub
(
$req
) ];
}
$self
->set_permissions(
$r
,
@rc
);
}
sub
authorize ($$) {
my
(
$self
,
$r
) =
@_
;
my
$auth_type
=
$self
;
$self
->debug(3,
"------- authorize("
.
join
(
','
,
@_
).
")"
);
return
OK
if
lc
$r
->auth_name eq
'none'
;
return
OK
if
$r
->dir_config(
'DisableAuthCookieURL'
);
return
OK
if
$r
->uri eq
$r
->dir_config((
$r
->auth_name).
'LoginScript'
);
if
(
$r
->auth_type ne
$auth_type
) {
$self
->debug(3,
"AuthType mismatch: $auth_type != "
.
$r
->auth_type);
return
DECLINED;
}
my
@reqs
=
$self
->get_permissions(
$r
) or
return
DECLINED;
my
$user
=
$r
->connection->user;
unless
(
$user
) {
$r
->log_reason(
"No user authenticated"
,
$r
->uri);
$self
->save_reason(
'no_user'
)
if
(
$r
->is_main());
return
FORBIDDEN;
}
foreach
my
$req
(
@reqs
) {
my
(
$requirement
,
$args
) =
@$req
;
$args
=
''
unless
defined
$args
;
$self
->debug(2,
"requirement := $requirement, $args"
);
return
OK
if
$requirement
eq
'valid-user'
;
$self
->debug(3,
"calling $auth_type\-\>$requirement"
);
my
$ret_val
=
$auth_type
->
$requirement
(
$r
,
$args
);
$self
->debug(3,
"$requirement returned $ret_val"
);
return
OK
if
$ret_val
== OK;
}
$self
->save_reason(
'access_denied'
)
if
(
$r
->is_main());
return
FORBIDDEN;
}
1;
Hide Show 344 lines of Pod