$OpenInteract::VERSION
=
'1.62'
;
my
$SEP
=
'='
x 30;
my
%REQ
= ();
sub
handler ($$) {
my
(
$class
,
$apache
) =
@_
;
my
$R
=
eval
{
$class
->setup_request(
$apache
) };
if
( $@ ) {
$class
->send_html(
$apache
, $@ );
return
OK;
}
$R
->DEBUG &&
$R
->scrib( 1,
"\n\n$SEP\nRequest started:"
,
scalar
localtime
(
$R
->{
time
} ),
"\n"
,
"path: ("
,
$apache
->parsed_uri->path,
") PID: ($$)"
);
my
(
$page
);
eval
{
$class
->setup_server_interface(
$R
,
$apache
);
$class
->setup_cache(
$R
);
$class
->parse_uri(
$R
);
$class
->find_action_handler(
$R
);
$class
->check_database(
$R
);
$class
->setup_cookies_and_session(
$R
);
$class
->setup_authentication(
$R
);
$class
->setup_theme(
$R
);
$page
=
$class
->run_content_handler(
$R
);
$class
->finish_cookies_and_session(
$R
);
};
if
( $@ ) {
warn
" --EXITED WITH ERROR from main handler eval block\nError: $@\n"
;
return
$class
->bail( $@ );
}
if
(
$R
->{page}{send_file} ) {
$class
->send_static_file(
$R
);
}
elsif
(
my
$redirect_url
=
$R
->{page}{http_redirect} ) {
my
$apr
=
$R
->apache;
$apr
->no_cache(1);
$apr
->headers_out->set(
Location
=>
$redirect_url
);
$apr
->status( REDIRECT );
$apr
->send_http_header;
}
else
{
$class
->send_html(
$apache
,
$page
,
$R
);
}
$class
->cleanup(
$R
);
return
OK;
}
sub
bail {
my
(
$class
,
$msg
) =
@_
;
$msg
=
$msg
+ 0;
return
$msg
;
}
sub
setup_request {
my
(
$class
,
$apache
) =
@_
;
my
$STASH_CLASS
=
$apache
->dir_config(
'OIStashClass'
);
unless
(
$REQ
{
$STASH_CLASS
} ) {
eval
"require $STASH_CLASS"
;
if
( $@ ) {
$apache
->child_terminate;
die
"Cannot require stash class ($STASH_CLASS) -- "
,
"fatal event, will terminate Apache child\n"
;
}
$REQ
{
$STASH_CLASS
}++;
}
my
$C
=
$STASH_CLASS
->get_stash(
'config'
);
unless
(
ref
$C
and
scalar
keys
%{
$C
} ) {
$apache
->child_terminate;
die
"Cannot find configuration object from stash class ($STASH_CLASS) -- "
,
"fatal event, will terminate Apache child\n"
;
}
my
$REQUEST_CLASS
=
$C
->{server_info}{request_class};
unless
(
$REQ
{
$REQUEST_CLASS
} ) {
eval
"require $REQUEST_CLASS"
;
if
( $@ ) {
$apache
->child_terminate;
die
"Cannot require request class ($REQUEST_CLASS) -- "
,
"fatal event, will terminate Apache child\n"
;
}
$REQ
{
$REQUEST_CLASS
}++;
}
my
$R
=
$REQUEST_CLASS
->instance;
$R
->{stash_class} =
$STASH_CLASS
;
$R
->{pid} = $$;
$R
->{
time
} =
time
;
return
$R
;
}
sub
setup_apache {
my
$c
=
shift
;
return
$c
->setup_server_interface(
@_
) }
sub
setup_server_interface {
my
(
$class
,
$R
,
$apache
) =
@_
;
my
$apr
= Apache::Request->new(
$apache
);
$R
->stash(
'apache'
,
$apr
);
my
$srv
=
$apr
->server;
$R
->{server_name} =
$srv
->server_hostname;
$R
->DEBUG &&
$R
->scrib( 1,
"Server hostname set to $R->{server_name}"
);
$R
->{remote_host} =
$apr
->connection->remote_ip();
$R
->DEBUG &&
$R
->scrib( 1,
"Request coming from $R->{remote_host}"
);
return
;
}
sub
setup_cache {
my
(
$class
,
$R
) =
@_
;
my
$CONFIG
=
$R
->CONFIG;
my
$cache_info
=
$CONFIG
->{cache_info}{data};
if
( !
$R
->cache and
$cache_info
->{
use
} ) {
my
$cache_class
=
$cache_info
->{class};
eval
"require $cache_class"
;
if
( $@ ) {
$R
->scrib( 0,
"Cannot include cache class [$cache_class]: $@\n"
,
"Continuing with operation..."
);
return
;
}
$R
->DEBUG &&
$R
->scrib( 1,
"Using cache and setting up with [$cache_class]"
);
my
$cache
=
$cache_class
->new(
$CONFIG
);
$R
->stash(
'cache'
,
$cache
);
}
return
;
}
sub
parse_uri {
my
(
$class
,
$R
,
$uri
) =
@_
;
my
$apache
=
$R
->apache;
unless
(
$uri
) {
$uri
=
$apache
->parsed_uri;
}
$R
->stash(
'uri'
,
$uri
);
my
$location
=
$apache
->location;
my
$path
=
$uri
->path;
$R
->DEBUG &&
$R
->scrib( 1,
"Original path: ($path)"
);
if
(
$location
ne
'/'
) {
$path
=~ s/^
$location
//;
$R
->{path}{location} =
$location
;
$R
->DEBUG &&
$R
->scrib( 1,
"Modified path by removing ($location): ($path)"
);
}
my
@choices
=
split
/\//,
$path
;
shift
@choices
;
$R
->DEBUG &&
$R
->scrib( 1,
"Items in the path: "
,
join
(
" // "
,
@choices
) );
my
@full_choices
=
@choices
;
$R
->{path}{current} = \
@choices
;
$R
->{path}{full} = \
@full_choices
;
if
(
$R
->CONFIG->{page_directives}{
$R
->{path}{current}->[0] } ) {
$R
->{ui}{directive} =
shift
@{
$R
->{path}{current} };
$path
=
'/'
.
join
(
'/'
, @{
$R
->{path}{current} } );
}
$R
->{ui}{action} =
$R
->{path}{current}->[0];
$R
->DEBUG &&
$R
->scrib( 1,
"Action found from URL: $R->{ui}{action}"
);
$R
->{path}{original} =
$path
;
$R
->{path}{original} .=
'?'
.
$uri
->query
if
(
$uri
->query );
$R
->DEBUG &&
$R
->scrib( 1,
"Original path/query string set to: $R->{path}{original}"
);
return
;
}
sub
find_action_handler {
my
(
$class
,
$R
) =
@_
;
(
$R
->{ui}{class},
$R
->{ui}{method} ) =
$R
->lookup_conductor(
$R
->{ui}{action} );
unless
(
$R
->{ui}{class} ) {
$R
->scrib( 0,
" Conductor not found; displaying oops page."
);
eval
{
$R
->throw({
code
=> 301,
type
=>
'file'
,
user_msg
=>
"Bad URL"
,
system_msg
=>
"Cannot find conductor for $R->{ui}{action}"
,
extra
=> {
url
=>
$R
->{path}{original} } }) };
if
( $@ ) {
$class
->send_html(
$R
->apache, $@,
$R
);
die
OK .
"\n"
;
}
}
$R
->DEBUG &&
$R
->scrib( 1,
"Found $R->{ui}{class} // $R->{ui}{method} for conductor"
);
return
;
}
sub
check_database {
my
(
$class
,
$R
) =
@_
;
my
$db
=
$R
->db(
'main'
);
eval
{
unless
(
$db
) {
$R
->apache->child_terminate;
die
"Database not found -- fatal event, will terminate Apache child\n"
;
}
$R
->DEBUG &&
warn
"Found item: "
,
ref
(
$db
),
"\n"
;
$db
->ping;
};
if
( $@ ) {
$R
->apache->child_terminate;
$R
->scrib( 0,
"Cannot ping database -- fatal event, will terminate Apache child"
);
my
$error_msg
=
$R
->throw({
code
=> 11 });
$class
->send_html(
$R
->apache,
$error_msg
,
$R
);
die
OK .
"\n"
;
}
return
;
}
sub
setup_cookies_and_session {
my
(
$class
,
$R
) =
@_
;
eval
{
$R
->DEBUG &&
$R
->scrib( 2,
"Trying to use cookie class: "
,
$R
->cookies );
$R
->cookies->parse;
$R
->DEBUG &&
$R
->scrib( 2,
"Cookies in:"
, Dumper(
$R
->{cookie}{in} ) );
$R
->DEBUG &&
$R
->scrib( 2,
"Trying to use session class: "
,
$R
->session );
$R
->session->parse;
};
if
( $@ ) {
$class
->send_html(
$R
->apache, $@,
$R
);
die
OK .
"\n"
;
}
return
;
}
sub
finish_cookies_and_session {
my
(
$class
,
$R
) =
@_
;
eval
{
$R
->session->save;
$R
->cookies->bake;
$R
->DEBUG &&
$R
->scrib( 2,
"Cookies out:"
,
join
(
" // "
,
map
{
$_
->name .
' = '
.
$_
->value }
values
%{
$R
->{cookie}{out} } ) );
};
if
( $@ ) {
$class
->send_html(
$R
->apache, $@,
$R
);
die
OK .
"\n"
;
}
return
;
}
sub
setup_authentication {
my
(
$class
,
$R
) =
@_
;
my
(
$error_msg
);
if
(
my
$auth_class
=
$R
->auth ) {
eval
{
$auth_class
->user;
$auth_class
->group;
$auth_class
->is_admin;
$auth_class
->custom_handler;
};
$error_msg
= $@;
}
else
{
$error_msg
=
"Authentication cannot be setup! Please ensure 'auth' "
.
"is setup in your server configuration under 'system_alias'"
;
}
if
(
$error_msg
) {
$class
->send_html(
$R
->apache,
$error_msg
,
$R
);
die
OK .
"\n"
;
}
my
$login_info
=
$R
->CONFIG->{login};
return
undef
unless
(
$login_info
->{required} );
return
undef
if
(
$R
->{auth}{logged_in} );
my
$url_requires_login
=
$class
->url_requires_login(
$R
->{path}{original},
$login_info
->{required_skip} );
return
undef
unless
(
$url_requires_login
);
return
$class
->required_login_not_found(
$R
);
}
sub
url_requires_login {
my
(
$class
,
$url
,
$url_to_skip
) =
@_
;
return
1
unless
(
$url_to_skip
);
my
@urls_to_check
= (
ref
$url_to_skip
eq
'ARRAY'
)
? @{
$url_to_skip
} : (
$url_to_skip
);
my
$url_skip
= 0;
foreach
my
$url_check
(
@urls_to_check
) {
next
unless
(
$url_check
);
$url_skip
++
if
(
$url
=~ /
$url_check
/ );
}
return
( !
$url_skip
);
}
sub
required_login_not_found {
my
(
$class
,
$R
) =
@_
;
my
$required_url
=
$R
->CONFIG->{login}{required_url};
unless
(
$required_url
) {
$R
->scrib( 0,
"You have 'login.required' enabled so I'm ensuring "
,
"that all users have a login, but you don't have "
,
"'login_required_url' set to a URL where I should "
,
"send them. Ignoring login requirement setting..."
);
return
undef
;
}
my
$host
=
$R
->{server_name};
my
$full_url
=
join
(
''
,
'http://'
,
$host
,
$required_url
);
my
$uri
= Apache::URI->parse(
$R
->apache,
$full_url
);
$R
->DEBUG &&
$R
->scrib( 1,
"Resetting request URL to '$full_url' (composed "
,
"of host '$host' and path '$required_url') since "
,
"login required and none found"
);
$R
->{path}{login_fail} =
$R
->{path}{original};
return
$class
->parse_uri(
$R
,
$uri
);
}
sub
setup_theme {
my
(
$class
,
$R
) =
@_
;
my
$C
=
$R
->CONFIG;
my
$theme_refresh
=
$R
->CONFIG->{session_info}{cache_theme};
if
(
$theme_refresh
> 0 ) {
if
(
my
$theme
=
$R
->{session}{_oi_cache}{theme} ) {
if
(
time
<
$R
->{session}{_oi_cache}{theme_refresh_on} ) {
$R
->DEBUG &&
$R
->scrib( 1,
"Got theme from session ok"
);
$R
->{theme} =
$theme
;
return
;
}
$R
->DEBUG &&
$R
->scrib( 1,
"Theme session cache expired; refreshing from db"
);
}
}
$R
->{theme} = (
$R
->{auth}{user} and
$R
->{auth}{user}{theme_id} )
?
eval
{
$R
->{auth}{user}->theme }
:
eval
{
$R
->theme->fetch(
$C
->{default_objects}{theme} ) };
if
( $@ ) {
my
$ei
= SPOPS::Error->get;
OpenInteract::Error->set(
$ei
);
$R
->throw({
code
=> 404 });
$R
->scrib( 0,
"Error! Cannot retrieve theme! ( Class: "
,
$R
->theme,
")"
,
"with error ($@ / $ei->{system_msg}) Help!"
);
my
$admin_email
=
$C
->{mail}{admin_email} ||
$C
->{admin_email};
my
$error_msg
=
<<THEMERR;
Fundamental part of OpenInteract (themes) not functioning; please contact the
system administrator (<a href="mailto:$admin_email">$admin_email</a>).
THEMERR
$class
->send_html(
$R
->apache,
$error_msg
,
$R
);
die
OK .
"\n"
;
}
$R
->{theme}->discover_properties;
if
(
$theme_refresh
> 0 ) {
$R
->{session}{_oi_cache}{theme} =
$R
->{theme};
$R
->{session}{_oi_cache}{theme_refresh_on} =
time
+ (
$theme_refresh
+ 60 );
$R
->DEBUG &&
$R
->scrib( 1,
"Set theme to session cache, expires "
,
"in [$theme_refresh] minutes"
);
}
return
;
}
sub
run_content_handler {
my
(
$class
,
$R
) =
@_
;
my
(
$ui_class
,
$ui_method
) = (
$R
->{ui}{class},
$R
->{ui}{method} );
$R
->DEBUG &&
$R
->scrib( 1,
"Trying the conductor: <<$ui_class/$ui_method>>"
);
return
$ui_class
->
$ui_method
();
}
sub
send_static_file {
my
(
$class
,
$R
) =
@_
;
my
$file_spec
=
$R
->{page}{send_file};
my
(
$file_size
);
my
(
$fh
);
if
(
ref
$file_spec
) {
$fh
=
$file_spec
;
my
$default_type
=
'application/octet-stream'
;
unless
(
$R
->{page}{content_type} ) {
$R
->scrib( 0,
"No content type set for filehandle to send, "
,
"using default '$default_type'\n"
);
$R
->{page}{content_type} =
$default_type
;
}
$file_size
= (
stat
$fh
)[7];
$R
->DEBUG &&
$R
->scrib( 1,
"Sending filehandle of size"
,
"($file_size) and type"
,
"($R->{page}{content_type})"
);
}
else
{
$fh
= Apache->gensym;
eval
{
open
(
$fh
,
$file_spec
) ||
die
$! };
if
( $@ ) {
$R
->scrib( 0,
"Cannot open static file from filesystem ($file_spec): $@"
);
return
NOT_FOUND;
}
$file_size
=
$R
->{page}{send_file_size}
|| (
stat
$file_spec
)[7];
$R
->DEBUG &&
$R
->scrib( 1,
"Sending file ($file_spec) of size"
,
"($file_size) and type"
,
"($R->{page}{content_type})"
);
}
$R
->apache->headers_out->{
'Content-Length'
} =
$file_size
;
$R
->apache->send_http_header(
$R
->{page}{content_type} );
$R
->apache->send_fd(
$fh
);
close
(
$fh
);
}
sub
send_html {
my
(
$class
,
$apache
,
$content
,
$R
) =
@_
;
if
(
ref
$R
) {
unless
(
$R
->CONFIG->{no_promotion} ) {
$apache
->headers_out->{
'X-Powered-By'
} =
"OpenInteract $OpenInteract::VERSION"
;
}
}
my
$content_type
=
$R
->{page}{content_type} ||
$apache
->content_type ||
'text/html'
;
$content_type
= (
$content_type
eq
'httpd/unix-directory'
)
?
'text/html'
:
$content_type
;
$apache
->send_http_header(
$content_type
);
$apache
->
print
(
$content
);
}
sub
cleanup {
my
(
$class
,
$R
) =
@_
;
eval
{ SPOPS::Exception->clear_stack };
$R
->DEBUG &&
$R
->scrib( 2,
"\n\nErrors: "
, Dumper(
$R
->error_object->report ),
"\n"
);
$R
->error->clear;
$R
->error_object->clear_listing;
$R
->DEBUG &&
$R
->scrib( 1,
"\nRequest done:"
,
scalar
localtime
,
"\n"
,
"path: ($R->{path}{original}) PID: ($$)\n"
,
"from: ($R->{remote_host})\n$SEP\n"
);
$R
->finish_request;
return
;
}
1;