text but no images
This commit is contained in:
Patrick Donelan
parent
d8e6256da8
commit
e04b1ebc9d
3 changed files with 101 additions and 64 deletions
|
|
@ -156,10 +156,15 @@ The Apache2::RequestRec object passed in by Apache's mod_perl.
|
|||
=cut
|
||||
|
||||
sub handler {
|
||||
my $request = shift; #start with apache request object
|
||||
$request = Apache2::Request->new($request);
|
||||
my $request = shift; # either apache request object or PSGI env hash
|
||||
my $server;
|
||||
if ($request->isa('WebGUI::Session::Plack')) {
|
||||
$server = $request->server;
|
||||
} else {
|
||||
$request = Apache2::Request->new($request);
|
||||
$server = Apache2::ServerUtil->server; #instantiate the server api
|
||||
}
|
||||
my $configFile = shift || $request->dir_config('WebguiConfig'); #either we got a config file, or we'll build it from the request object's settings
|
||||
my $server = Apache2::ServerUtil->server; #instantiate the server api
|
||||
my $config = WebGUI::Config->new($server->dir_config('WebguiRoot'), $configFile); #instantiate the config object
|
||||
my $error = "";
|
||||
my $matchUri = $request->uri;
|
||||
|
|
@ -168,15 +173,15 @@ sub handler {
|
|||
my $gotMatch = 0;
|
||||
|
||||
# handle basic auth
|
||||
my $auth = $request->headers_in->{'Authorization'};
|
||||
if ($auth =~ m/^Basic/) { # machine oriented
|
||||
# Get username and password from Apache and hand over to authen
|
||||
$auth =~ s/Basic //;
|
||||
authen($request, split(":", MIME::Base64::decode_base64($auth), 2), $config);
|
||||
}
|
||||
else { # realm oriented
|
||||
$request->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($request, undef, undef, $config)});
|
||||
}
|
||||
# my $auth = $request->headers_in->{'Authorization'};
|
||||
# if ($auth =~ m/^Basic/) { # machine oriented
|
||||
# # Get username and password from Apache and hand over to authen
|
||||
# $auth =~ s/Basic //;
|
||||
# authen($request, split(":", MIME::Base64::decode_base64($auth), 2), $config);
|
||||
# }
|
||||
# else { # realm oriented
|
||||
# $request->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($request, undef, undef, $config)});
|
||||
# }
|
||||
|
||||
|
||||
# url handlers
|
||||
|
|
@ -208,55 +213,15 @@ sub handler {
|
|||
}
|
||||
|
||||
sub handle_psgi {
|
||||
my $env = shift; # instead of an Apache2::Request object
|
||||
my $env = shift;
|
||||
require WebGUI::Session::Plack;
|
||||
my $plack = WebGUI::Session::Plack->new( env => $env );
|
||||
my $server = $plack->server;
|
||||
my $config = WebGUI::Config->new( $env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'} );
|
||||
my $error = "";
|
||||
my $matchUri = $plack->uri;
|
||||
my $gateway = $config->get("gateway");
|
||||
$matchUri =~ s{^$gateway}{/};
|
||||
my $plack = WebGUI::Session::Plack->new( env => $env );
|
||||
|
||||
# # handle basic auth
|
||||
# my $auth = $plack->headers_in->{'Authorization'};
|
||||
# if ($auth =~ m/^Basic/) { # machine oriented
|
||||
# # Get username and password from Apache and hand over to authen
|
||||
# $auth =~ s/Basic //;
|
||||
# authen($plack, split(":", MIME::Base64::decode_base64($auth), 2), $config);
|
||||
# }
|
||||
# else { # realm oriented
|
||||
# $plack->push_handlers(PerlAuthenHandler => sub { return WebGUI::authen($plack, undef, undef, $config)});
|
||||
# }
|
||||
# returns something like Apache2::Const::OK, which we ignore
|
||||
my $ret = handler($plack);
|
||||
|
||||
|
||||
# url handlers
|
||||
# TODO: We should probably ditch URL Handlers altogether in favour of Plack::Middleware
|
||||
WEBGUI_FATAL: foreach my $handler ( @{ $config->get("urlHandlers") } ) {
|
||||
my ($regex) = keys %{$handler};
|
||||
if ( $matchUri =~ m{$regex}i ) {
|
||||
my $output = eval { WebGUI::Pluggable::run( $handler->{$regex}, "handler", [ $plack, $server, $config ] ) };
|
||||
if ($@) {
|
||||
$error = $@;
|
||||
last;
|
||||
}
|
||||
# else {
|
||||
# $gotMatch = 1;
|
||||
# if ($output ne Apache2::Const::DECLINED) {
|
||||
# return $output;
|
||||
# }
|
||||
# }
|
||||
return $output if $output;
|
||||
}
|
||||
}
|
||||
# return Apache2::Const::DECLINED if ($gotMatch);
|
||||
|
||||
# can't handle the url due to error or misconfiguration
|
||||
return [
|
||||
500,
|
||||
[ 'Content-Type' => 'text/html' ],
|
||||
["This server is unable to handle the url '$matchUri' that you requested. $error"]
|
||||
];
|
||||
# let Plack::Response do its thing
|
||||
return $plack->finalize;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -389,6 +389,16 @@ sub setCookie {
|
|||
$ttl = (defined $ttl ? $ttl : '+10y');
|
||||
|
||||
if ($self->session->request) {
|
||||
if ($self->session->request->isa('WebGUI::Session::Plack')) {
|
||||
$self->session->request->response->cookies->{$name} = {
|
||||
value => $value,
|
||||
path => '/',
|
||||
expires => $ttl ne 'session' ? $ttl : undef,
|
||||
domain => $domain,
|
||||
};
|
||||
return;
|
||||
}
|
||||
|
||||
require Apache2::Cookie;
|
||||
my $cookie = Apache2::Cookie->new($self->session->request,
|
||||
-name=>$name,
|
||||
|
|
|
|||
|
|
@ -21,13 +21,17 @@ sub new {
|
|||
my $request = Plack::Request->new( $p{env} );
|
||||
my $response = $request->new_response;
|
||||
|
||||
bless {
|
||||
my $self = bless {
|
||||
%p,
|
||||
pnotes => {},
|
||||
request => $request,
|
||||
response => $response,
|
||||
server => WebGUI::Session::Plack::Server->new( env => $p{env} ),
|
||||
}, $class;
|
||||
|
||||
$self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( plack => $self );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub session { $_[0]{session} }
|
||||
|
|
@ -43,18 +47,28 @@ sub AUTOLOAD {
|
|||
my $what = $AUTOLOAD;
|
||||
$what =~ s/.*:://;
|
||||
|
||||
warn "!!plack->$what(@_)";
|
||||
carp "!!plack->$what(@_)";
|
||||
}
|
||||
|
||||
sub uri { shift->request->request_uri(@_) }
|
||||
sub headers_in { shift->request->headers(@_) }
|
||||
sub param { shift->request->param(@_) }
|
||||
sub params { shift->request->params(@_) }
|
||||
sub headers_in { shift->request->headers(@_) }
|
||||
sub headers_out { shift->{headers_out} }
|
||||
sub protocol { shift->request->protocol(@_) }
|
||||
sub status { shift->response->status(@_) }
|
||||
sub status_line {}
|
||||
|
||||
# TODO: I suppose this should do some sort of IO::Handle thing
|
||||
my @body;
|
||||
sub print { shift; push @body, @_ }
|
||||
|
||||
sub dir_config {
|
||||
my $self = shift;
|
||||
my $c = shift;
|
||||
return $self->env->{"wg.DIR_CONFIG.$c"};
|
||||
}
|
||||
|
||||
sub pnotes {
|
||||
my ($self, $key) = (shift, shift);
|
||||
return wantarray ? %{$self->{pnotes}} : $self->{pnotes} unless defined $key;
|
||||
|
|
@ -62,12 +76,36 @@ sub pnotes {
|
|||
return $self->{pnotes}{$key};
|
||||
}
|
||||
|
||||
sub user {
|
||||
my ($self, $user) = @_;
|
||||
if (defined $user) {
|
||||
$self->{user} = $user;
|
||||
}
|
||||
$self->{user};
|
||||
}
|
||||
|
||||
sub push_handlers {
|
||||
my $self = shift;
|
||||
my ($x, $sub) = @_;
|
||||
carp "push_handlers on $x";
|
||||
return $sub->();
|
||||
|
||||
# log it
|
||||
carp "push_handlers($x)";
|
||||
|
||||
# run it
|
||||
# returns something like Apache2::Const::OK, which we just ignore because we're not modperl
|
||||
my $ret = $sub->($self);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub finalize {
|
||||
my $self = shift;
|
||||
$self->response->body(\@body);
|
||||
return $self->response->finalize;
|
||||
}
|
||||
|
||||
sub content_type { shift->response->content_type(@_) }
|
||||
|
||||
#
|
||||
#sub headers_in {
|
||||
# my $self = shift;
|
||||
|
|
@ -79,6 +117,7 @@ package WebGUI::Session::Plack::Server;
|
|||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
|
@ -93,7 +132,7 @@ sub AUTOLOAD {
|
|||
my $what = $AUTOLOAD;
|
||||
$what =~ s/.*:://;
|
||||
|
||||
warn "!!server->$what(@_)";
|
||||
carp "!!server->$what(@_)";
|
||||
return;
|
||||
}
|
||||
|
||||
|
|
@ -103,6 +142,29 @@ sub dir_config {
|
|||
return $self->env->{"wg.DIR_CONFIG.$c"};
|
||||
}
|
||||
|
||||
package WebGUI::Session::Plack::HeadersOut;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
bless { @_ }, $class;
|
||||
}
|
||||
|
||||
our $AUTOLOAD;
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my $what = $AUTOLOAD;
|
||||
$what =~ s/.*:://;
|
||||
|
||||
carp "!!headers_out->$what(@_)";
|
||||
return;
|
||||
}
|
||||
|
||||
sub set { shift->{plack}->response->headers->header(@_) }
|
||||
|
||||
# --
|
||||
|
||||
## CGI request are _always_ main, and there is never a previous or a next
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue