From e04b1ebc9de1b968ee9a1efd11aed60048448c85 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 11:44:10 +1100 Subject: [PATCH] text but no images --- lib/WebGUI.pm | 81 +++++++++++-------------------------- lib/WebGUI/Session/Http.pm | 10 +++++ lib/WebGUI/Session/Plack.pm | 74 ++++++++++++++++++++++++++++++--- 3 files changed, 101 insertions(+), 64 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 4d841943b..b39615f43 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -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; diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index d38b08303..2fbb01af5 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -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, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index cde6a74c9..2cd5906fc 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -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