From b0d72bef33cc7a85f17d6f72cc6ce1ad7d4d4aae Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 20:31:28 +1100 Subject: [PATCH 01/15] FakeApache --- lib/WebGUI/Session.pm | 3 +- lib/WebGUI/Session/Request.pm | 508 ++++++++++++++++++++++++++++++++++ 2 files changed, 510 insertions(+), 1 deletion(-) create mode 100644 lib/WebGUI/Session/Request.pm diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 1ffcd69a52..84553efdbe 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -28,6 +28,7 @@ use WebGUI::Session::Id; use WebGUI::Session::Os; use WebGUI::Session::Output; use WebGUI::Session::Privilege; +use WebGUI::Session::Request; use WebGUI::Session::Scratch; use WebGUI::Session::Setting; use WebGUI::Session::Stow; @@ -440,7 +441,7 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - $self->{_request} = $request if (defined $request); + $self->{_request} = WebGUI::Session::Request->new( r => $request, env => {}, session => $self ) if $request; my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); my $noFuss = shift; diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm new file mode 100644 index 0000000000..575a7befd1 --- /dev/null +++ b/lib/WebGUI/Session/Request.pm @@ -0,0 +1,508 @@ +package WebGUI::Session::Request; +# We need to define an Apache package or we might get strange errors +# like "Can't locate package Apache for +# @WebGUI::Session::Request::ISA". We do the BEGIN/eval thing so that +# the CPAN indexer doesn't pick it up, which would be ugly. +#BEGIN { eval "package Apache" } +@WebGUI::Session::Request::ISA = qw(Apache); +# Analogous to Apache request object $r (but not an actual Apache subclass) +# In the future we'll probably want to switch this to Apache::Fake or similar + +use strict; +use warnings; +use CGI; + +sub new { + my $class = shift; + my %p = @_; + return bless { + %p, + query => $p{cgi} || CGI->new, + headers_out => WebGUI::Session::Request::FakeTable->new, + err_headers_out => WebGUI::Session::Request::FakeTable->new, + pnotes => {}, + }, $class; +} + +sub session { $_[0]{session} } +sub env { $_[0]{env} } +sub r { $_[0]{r} } + +our $AUTOLOAD; + +sub AUTOLOAD { + my $self = shift; + my $what = $AUTOLOAD; + $what =~ s/.*:://; + my $r = $self->r; + + if (!$r) { + $self->session->log->error("!!session->request->$what(@_) but r not defined"); + return; + } + + $self->session->log->error("!!session->request->$what(@_)"); + return $r->$what(@_); +} + +# CGI request are _always_ main, and there is never a previous or a next +# internal request. +sub main {} +sub prev {} +sub next {} +sub is_main {1} +sub is_initial_req {1} + +# What to do with this? +# sub allowed {} + +sub method { + $_[0]->query->request_method; +} + +# There mut be a mapping for this. +# sub method_number {} + +# Can CGI.pm tell us this? +# sub bytes_sent {0} + +# The request line sent by the client." Poached from Apache::Emulator. +sub the_request { + my $self = shift; + $self->{the_request} ||= join ' ', $self->method, + ( $self->{query}->query_string + ? $self->uri . '?' . $self->{query}->query_string + : $self->uri ), + $self->{query}->server_protocol; +} + +# Is CGI ever a proxy request? +# sub proxy_req {} + +sub header_only { $_[0]->method eq 'HEAD' } + +sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } + +sub hostname { $_[0]->{query}->server_name } + +# CGI says "use this when using virtual hosts". It falls back to +# CGI->server_port. +sub get_server_port { $_[0]->{query}->virtual_port } + +# Fake it by just giving the current time. +sub request_time { time } + +sub uri { + my $self = shift; + + $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; +} + +# Is this available in CGI? +# sub filename {} + +# "The $r->location method will return the path of the +# section from which the current "Perl*Handler" +# is being called." This is irrelevant, I think. +# sub location {} + +sub path_info { $_[0]->{query}->path_info } + +sub args { + my $self = shift; + if (@_) { + # Assign args here. + } + return $self->{query}->Vars unless wantarray; + # Do more here to return key => arg values. +} + +sub headers_in { + my $self = shift; + + # Create the headers table if necessary. Decided how to build it based on + # information here: + # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 + # + # Try to get as much info as possible from CGI.pm, which has + # workarounds for things like the IIS PATH_INFO bug. + # + $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new + ( 'Authorization' => $self->{query}->auth_type, # No credentials though. + 'Content-Length' => $ENV{CONTENT_LENGTH}, + 'Content-Type' => + ( $self->{query}->can('content_type') ? + $self->{query}->content_type : + $ENV{CONTENT_TYPE} + ), + # Convert HTTP environment variables back into their header names. + map { + my $k = ucfirst lc; + $k =~ s/_(.)/-\u$1/g; + ( $k => $self->{query}->http($_) ) + } grep { s/^HTTP_// } keys %ENV + ); + + + # Give 'em the hash list of the hash table. + return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; +} + +sub header_in { + my ($self, $header) = (shift, shift); + my $h = $self->headers_in; + return @_ ? $h->set($header, shift) : $h->get($header); +} + + +# The $r->content method will return the entity body +# read from the client, but only if the request content +# type is "application/x-www-form-urlencoded". When +# called in a scalar context, the entire string is +# returned. When called in a list context, a list of +# parsed key => value pairs are returned. *NOTE*: you +# can only ask for this once, as the entire body is read +# from the client. +# Not sure what to do with this one. +# sub content {} + +# I think this may be irrelevant under CGI. +# sub read {} + +# Use LWP? +sub get_remote_host {} +sub get_remote_logname {} + +sub http_header { + my $self = shift; + my $h = $self->headers_out; + my $e = $self->err_headers_out; + my $method = exists $h->{Location} || exists $e->{Location} ? + 'redirect' : 'header'; + return $self->query->$method(tied(%$h)->cgi_headers, + tied(%$e)->cgi_headers); +} + +sub send_http_header { + my $self = shift; + + return if $self->http_header_sent; + + print STDOUT $self->http_header; + + $self->{http_header_sent} = 1; +} + +sub http_header_sent { shift->{http_header_sent} } + +# How do we know this under CGI? +# sub get_basic_auth_pw {} +# sub note_basic_auth_failure {} + +# I think that this just has to be empty. +sub handler {} + +sub notes { + my ($self, $key) = (shift, shift); + $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; + return wantarray ? %{$self->{notes}} : $self->{notes} + unless defined $key; + return $self->{notes}{$key} = "$_[0]" if @_; + return $self->{notes}{$key}; +} + +sub pnotes { + my ($self, $key) = (shift, shift); + return wantarray ? %{$self->{pnotes}} : $self->{pnotes} + unless defined $key; + return $self->{pnotes}{$key} = $_[0] if @_; + return $self->{pnotes}{$key}; +} + +sub subprocess_env { + my ($self, $key) = (shift, shift); + unless (defined $key) { + $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); + return wantarray ? %{$self->{subprocess_env}} : + $self->{subprocess_env}; + + } + $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); + return $self->{subprocess_env}{$key} = "$_[0]" if @_; + return $self->{subprocess_env}{$key}; +} + +sub content_type { + shift->header_out('Content-Type', @_); +} + +sub content_encoding { + shift->header_out('Content-Encoding', @_); +} + +sub content_languages { + my ($self, $langs) = @_; + return unless $langs; + my $h = shift->headers_out; + for my $l (@$langs) { + $h->add('Content-Language', $l); + } +} + +sub status { + shift->header_out('Status', @_); +} + +sub status_line { + # What to do here? Should it be managed differently than status? + my $self = shift; + if (@_) { + my $status = shift =~ /^(\d+)/; + return $self->header_out('Status', $status); + } + return $self->header_out('Status'); +} + +sub headers_out { + my $self = shift; + return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; +} + +sub header_out { + my ($self, $header) = (shift, shift); + my $h = $self->headers_out; + return @_ ? $h->set($header, shift) : $h->get($header); +} + +sub err_headers_out { + my $self = shift; + return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; +} + +sub err_header_out { + my ($self, $err_header) = (shift, shift); + my $h = $self->err_headers_out; + return @_ ? $h->set($err_header, shift) : $h->get($err_header); +} + +sub no_cache { + my $self = shift; + $self->header_out(Pragma => 'no-cache'); + $self->header_out('Cache-Control' => 'no-cache'); +} + +sub print { + shift; + print @_; +} + +sub send_fd { + my ($self, $fd) = @_; + local $_; + + print STDOUT while defined ($_ = <$fd>); +} + +# Should this perhaps throw an exception? +# sub internal_redirect {} +# sub internal_redirect_handler {} + +# Do something with ErrorDocument? +# sub custom_response {} + +# I think we've made this essentially the same thing. +BEGIN { + local $^W; + *send_cgi_header = \&send_http_header; +} + +# Does CGI support logging? +# sub log_reason {} +# sub log_error {} +sub warn { + shift; + print STDERR @_, "\n"; +} + +sub params { + my $self = shift; + return _cgi_request_args($self->query, $self->query->request_method); +} + +sub _cgi_request_args{ + my ($q, $method) = @_; + + my %args; + + # Checking that there really is no query string when the method is + # not POST is important because otherwise ->url_param returns a + # parameter named 'keywords' with a value of () (empty array). + # This is apparently a feature related to queries or + # something (see the CGI.pm) docs. It makes my head hurt. - dave + my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); + + foreach my $key ( map { $q->$_() } @methods ) { + next if exists $args{$key}; + my @values = map { $q->$_($key) } @methods; + $args{$key} = @values == 1 ? $values[0] : \@values; + } + + return wantarray ? %args : \%args; +} + + +########################################################### +package WebGUI::Session::Request::FakeTable; +# Analogous to Apache::Table. +use strict; +use warnings; + +sub new { + my $class = shift; + my $self = {}; + tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; + %$self = @_ if @_; + return bless $self, ref $class || $class; +} + +sub set { + my ($self, $header, $value) = @_; + defined $value ? $self->{$header} = $value : delete $self->{$header}; +} + +sub unset { + my $self = shift; + delete $self->{shift()}; +} + +sub add { + tied(%{shift()})->add(@_); +} + +sub clear { + %{shift()} = (); +} + +sub get { + tied(%{shift()})->get(@_); +} + +sub merge { + my ($self, $key, $value) = @_; + if (defined $self->{$key}) { + $self->{$key} .= ',' . $value; + } else { + $self->{$key} = "$value"; + } +} + +sub do { + my ($self, $code) = @_; + while (my ($k, $val) = each %$self) { + for my $v (ref $val ? @$val : $val) { + return unless $code->($k => $v); + } + } +} + +########################################################### +package WebGUI::Session::Request::FakeTableHash; +# Used by WebGUI::Session::Request::FakeTable. +use strict; +use warnings; + +sub TIEHASH { + my $class = shift; + return bless {}, ref $class || $class; +} + +sub _canonical_key { + my $key = lc shift; + # CGI really wants a - before each header + return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; +} + +sub STORE { + my ($self, $key, $value) = @_; + $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; +} + +sub add { + my ($self, $key) = (shift, shift); + return unless defined $_[0]; + my $value = ref $_[0] ? "$_[0]" : $_[0]; + my $ckey = _canonical_key $key; + if (exists $self->{$ckey}) { + if (ref $self->{$ckey}[1]) { + push @{$self->{$ckey}[1]}, $value; + } else { + $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; + } + } else { + $self->{$ckey} = [ $key => $value ]; + } +} + +sub DELETE { + my ($self, $key) = @_; + my $ret = delete $self->{_canonical_key $key}; + return $ret->[1]; +} + +sub FETCH { + my ($self, $key) = @_; + # Grab the values first so that we don't autovivicate the key. + my $val = $self->{_canonical_key $key} or return; + if (my $ref = ref $val->[1]) { + return unless $val->[1][0]; + # Return the first value only. + return $val->[1][0]; + } + return $val->[1]; +} + +sub get { + my ($self, $key) = @_; + my $ckey = _canonical_key $key; + return unless exists $self->{$ckey}; + return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; + return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; +} + +sub CLEAR { + %{shift()} = (); +} + +sub EXISTS { + my ($self, $key)= @_; + return exists $self->{_canonical_key $key}; +} + +sub FIRSTKEY { + my $self = shift; + # Reset perl's iterator. + keys %$self; + # Get the first key via perl's iterator. + my $first_key = each %$self; + return undef unless defined $first_key; + return $self->{$first_key}[0]; +} + +sub NEXTKEY { + my ($self, $nextkey) = @_; + # Get the next key via perl's iterator. + my $next_key = each %$self; + return undef unless defined $next_key; + return $self->{$next_key}[0]; +} + +sub cgi_headers { + my $self = shift; + map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; +} + +sub _map_header_key_to_cgi_key { + return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; +} + +1; From f804b4918e07770af6a0a2e8d3d57af6bf36706b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 21:02:10 +1100 Subject: [PATCH 02/15] simple dualism --- etc/dev.localhost.localdomain.psgi | 34 ++ lib/WebGUI.pm | 28 + lib/WebGUI/Session.pm | 2 +- lib/WebGUI/Session/Request.pm | 952 +++++++++++++++-------------- lib/WebGUI/URL/Content.pm | 49 ++ 5 files changed, 602 insertions(+), 463 deletions(-) create mode 100644 etc/dev.localhost.localdomain.psgi diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi new file mode 100644 index 0000000000..4e5dad2887 --- /dev/null +++ b/etc/dev.localhost.localdomain.psgi @@ -0,0 +1,34 @@ +BEGIN { + # This is just a temporary hack + our $WEBGUI_ROOT = '/data/WebGUI'; + our $WEBGUI_DOMAINS = '/data/domains'; + our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; +} +use local::lib $WEBGUI_ROOT; +use WebGUI; +use Plack::Middleware qw( Static XFramework AccessLog ); +use Plack::Builder; + +my $app = sub { + my $env = shift; + $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; + $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; + WebGUI::handle_psgi($env); +}; + +# Apply some Middleware +builder { + # /extras + enable Plack::Middleware::Static + path => qr{^/extras/}, root => "$WEBGUI_ROOT/www/"; + + # /uploads (ignore .wgaccess for now..) + enable Plack::Middleware::Static + path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; + + enable Plack::Middleware::XFramework framework => 'WebGUI'; + + enable Plack::Middleware::AccessLog format => "combined"; + + $app; +} \ No newline at end of file diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index b1bc8141b5..4a952da30e 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -207,8 +207,36 @@ sub handler { return Apache2::Const::DECLINED; } +sub handle_psgi { + my $env = shift; + my $request = WebGUI::Session::Request->new( env => $env ); + my $config = WebGUI::Config->new( $env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'} ); + my $server; + my $error = ""; + my $matchUri = $request->plack->request_uri; + my $gateway = $config->get("gateway"); + $matchUri =~ s{^$gateway}{/}; + # 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", [ $request, $server, $config ] ) }; + if ($@) { + $error = $@; + last; + } + return $output if $output; + } + } + # 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"] + ]; +} 1; diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 84553efdbe..57a39edb5f 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -441,7 +441,7 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - $self->{_request} = WebGUI::Session::Request->new( r => $request, env => {}, session => $self ) if $request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); my $noFuss = shift; diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm index 575a7befd1..e988a96d79 100644 --- a/lib/WebGUI/Session/Request.pm +++ b/lib/WebGUI/Session/Request.pm @@ -1,10 +1,12 @@ package WebGUI::Session::Request; + # We need to define an Apache package or we might get strange errors # like "Can't locate package Apache for # @WebGUI::Session::Request::ISA". We do the BEGIN/eval thing so that # the CPAN indexer doesn't pick it up, which would be ugly. #BEGIN { eval "package Apache" } @WebGUI::Session::Request::ISA = qw(Apache); + # Analogous to Apache request object $r (but not an actual Apache subclass) # In the future we'll probably want to switch this to Apache::Fake or similar @@ -14,19 +16,30 @@ use CGI; sub new { my $class = shift; - my %p = @_; - return bless { + my %p = @_; + + my $self = bless { %p, - query => $p{cgi} || CGI->new, - headers_out => WebGUI::Session::Request::FakeTable->new, - err_headers_out => WebGUI::Session::Request::FakeTable->new, + + # query => $p{cgi} || CGI->new, + # headers_out => WebGUI::Session::Request::FakeTable->new, + # err_headers_out => WebGUI::Session::Request::FakeTable->new, pnotes => {}, }, $class; + + if ( $p{env} ) { + require Plack::Request; + require Plack::Response; + $self->{plack} = Plack::Request->new( $p{env} ); + } + + return $self; } sub session { $_[0]{session} } sub env { $_[0]{env} } sub r { $_[0]{r} } +sub plack { $_[0]{plack} } our $AUTOLOAD; @@ -35,474 +48,489 @@ sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; my $r = $self->r; - - if (!$r) { - $self->session->log->error("!!session->request->$what(@_) but r not defined"); - return; - } - - $self->session->log->error("!!session->request->$what(@_)"); - return $r->$what(@_); -} - -# CGI request are _always_ main, and there is never a previous or a next -# internal request. -sub main {} -sub prev {} -sub next {} -sub is_main {1} -sub is_initial_req {1} - -# What to do with this? -# sub allowed {} - -sub method { - $_[0]->query->request_method; -} - -# There mut be a mapping for this. -# sub method_number {} - -# Can CGI.pm tell us this? -# sub bytes_sent {0} - -# The request line sent by the client." Poached from Apache::Emulator. -sub the_request { - my $self = shift; - $self->{the_request} ||= join ' ', $self->method, - ( $self->{query}->query_string - ? $self->uri . '?' . $self->{query}->query_string - : $self->uri ), - $self->{query}->server_protocol; -} - -# Is CGI ever a proxy request? -# sub proxy_req {} - -sub header_only { $_[0]->method eq 'HEAD' } - -sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } - -sub hostname { $_[0]->{query}->server_name } - -# CGI says "use this when using virtual hosts". It falls back to -# CGI->server_port. -sub get_server_port { $_[0]->{query}->virtual_port } - -# Fake it by just giving the current time. -sub request_time { time } - -sub uri { - my $self = shift; - - $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; -} - -# Is this available in CGI? -# sub filename {} - -# "The $r->location method will return the path of the -# section from which the current "Perl*Handler" -# is being called." This is irrelevant, I think. -# sub location {} - -sub path_info { $_[0]->{query}->path_info } - -sub args { - my $self = shift; - if (@_) { - # Assign args here. - } - return $self->{query}->Vars unless wantarray; - # Do more here to return key => arg values. -} - -sub headers_in { - my $self = shift; - - # Create the headers table if necessary. Decided how to build it based on - # information here: - # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 - # - # Try to get as much info as possible from CGI.pm, which has - # workarounds for things like the IIS PATH_INFO bug. - # - $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new - ( 'Authorization' => $self->{query}->auth_type, # No credentials though. - 'Content-Length' => $ENV{CONTENT_LENGTH}, - 'Content-Type' => - ( $self->{query}->can('content_type') ? - $self->{query}->content_type : - $ENV{CONTENT_TYPE} - ), - # Convert HTTP environment variables back into their header names. - map { - my $k = ucfirst lc; - $k =~ s/_(.)/-\u$1/g; - ( $k => $self->{query}->http($_) ) - } grep { s/^HTTP_// } keys %ENV - ); - - - # Give 'em the hash list of the hash table. - return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; -} - -sub header_in { - my ($self, $header) = (shift, shift); - my $h = $self->headers_in; - return @_ ? $h->set($header, shift) : $h->get($header); -} - - -# The $r->content method will return the entity body -# read from the client, but only if the request content -# type is "application/x-www-form-urlencoded". When -# called in a scalar context, the entire string is -# returned. When called in a list context, a list of -# parsed key => value pairs are returned. *NOTE*: you -# can only ask for this once, as the entire body is read -# from the client. -# Not sure what to do with this one. -# sub content {} - -# I think this may be irrelevant under CGI. -# sub read {} - -# Use LWP? -sub get_remote_host {} -sub get_remote_logname {} - -sub http_header { - my $self = shift; - my $h = $self->headers_out; - my $e = $self->err_headers_out; - my $method = exists $h->{Location} || exists $e->{Location} ? - 'redirect' : 'header'; - return $self->query->$method(tied(%$h)->cgi_headers, - tied(%$e)->cgi_headers); -} - -sub send_http_header { - my $self = shift; - - return if $self->http_header_sent; - - print STDOUT $self->http_header; - - $self->{http_header_sent} = 1; -} - -sub http_header_sent { shift->{http_header_sent} } - -# How do we know this under CGI? -# sub get_basic_auth_pw {} -# sub note_basic_auth_failure {} - -# I think that this just has to be empty. -sub handler {} - -sub notes { - my ($self, $key) = (shift, shift); - $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; - return wantarray ? %{$self->{notes}} : $self->{notes} - unless defined $key; - return $self->{notes}{$key} = "$_[0]" if @_; - return $self->{notes}{$key}; -} - -sub pnotes { - my ($self, $key) = (shift, shift); - return wantarray ? %{$self->{pnotes}} : $self->{pnotes} - unless defined $key; - return $self->{pnotes}{$key} = $_[0] if @_; - return $self->{pnotes}{$key}; -} - -sub subprocess_env { - my ($self, $key) = (shift, shift); - unless (defined $key) { - $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); - return wantarray ? %{$self->{subprocess_env}} : - $self->{subprocess_env}; + if ( !$r ) { + $self->log("!!request->$what(@_) but r not defined"); + return; } - $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); - return $self->{subprocess_env}{$key} = "$_[0]" if @_; - return $self->{subprocess_env}{$key}; -} -sub content_type { - shift->header_out('Content-Type', @_); -} - -sub content_encoding { - shift->header_out('Content-Encoding', @_); -} - -sub content_languages { - my ($self, $langs) = @_; - return unless $langs; - my $h = shift->headers_out; - for my $l (@$langs) { - $h->add('Content-Language', $l); + if ( $what eq 'print' ) { + $self->log("!!request->$what(print--chomped)"); } -} - -sub status { - shift->header_out('Status', @_); -} - -sub status_line { - # What to do here? Should it be managed differently than status? - my $self = shift; - if (@_) { - my $status = shift =~ /^(\d+)/; - return $self->header_out('Status', $status); + else { + $self->log("!!request->$what(@_)"); } - return $self->header_out('Status'); -} - -sub headers_out { - my $self = shift; - return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; -} - -sub header_out { - my ($self, $header) = (shift, shift); - my $h = $self->headers_out; - return @_ ? $h->set($header, shift) : $h->get($header); -} - -sub err_headers_out { - my $self = shift; - return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; -} - -sub err_header_out { - my ($self, $err_header) = (shift, shift); - my $h = $self->err_headers_out; - return @_ ? $h->set($err_header, shift) : $h->get($err_header); -} - -sub no_cache { - my $self = shift; - $self->header_out(Pragma => 'no-cache'); - $self->header_out('Cache-Control' => 'no-cache'); -} - -sub print { - shift; - print @_; -} - -sub send_fd { - my ($self, $fd) = @_; - local $_; - - print STDOUT while defined ($_ = <$fd>); -} - -# Should this perhaps throw an exception? -# sub internal_redirect {} -# sub internal_redirect_handler {} - -# Do something with ErrorDocument? -# sub custom_response {} - -# I think we've made this essentially the same thing. -BEGIN { - local $^W; - *send_cgi_header = \&send_http_header; -} - -# Does CGI support logging? -# sub log_reason {} -# sub log_error {} -sub warn { - shift; - print STDERR @_, "\n"; -} - -sub params { - my $self = shift; - return _cgi_request_args($self->query, $self->query->request_method); -} - -sub _cgi_request_args{ - my ($q, $method) = @_; - - my %args; - - # Checking that there really is no query string when the method is - # not POST is important because otherwise ->url_param returns a - # parameter named 'keywords' with a value of () (empty array). - # This is apparently a feature related to queries or - # something (see the CGI.pm) docs. It makes my head hurt. - dave - my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); - - foreach my $key ( map { $q->$_() } @methods ) { - next if exists $args{$key}; - my @values = map { $q->$_($key) } @methods; - $args{$key} = @values == 1 ? $values[0] : \@values; - } - - return wantarray ? %args : \%args; -} - - -########################################################### -package WebGUI::Session::Request::FakeTable; -# Analogous to Apache::Table. -use strict; -use warnings; - -sub new { - my $class = shift; - my $self = {}; - tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; - %$self = @_ if @_; - return bless $self, ref $class || $class; -} - -sub set { - my ($self, $header, $value) = @_; - defined $value ? $self->{$header} = $value : delete $self->{$header}; + return $r->$what(@_); } -sub unset { +sub log { my $self = shift; - delete $self->{shift()}; -} - -sub add { - tied(%{shift()})->add(@_); -} - -sub clear { - %{shift()} = (); -} - -sub get { - tied(%{shift()})->get(@_); -} - -sub merge { - my ($self, $key, $value) = @_; - if (defined $self->{$key}) { - $self->{$key} .= ',' . $value; - } else { - $self->{$key} = "$value"; + if ( $self->session ) { + $self->session->log->error(shift); } -} - -sub do { - my ($self, $code) = @_; - while (my ($k, $val) = each %$self) { - for my $v (ref $val ? @$val : $val) { - return unless $code->($k => $v); - } - } -} - -########################################################### -package WebGUI::Session::Request::FakeTableHash; -# Used by WebGUI::Session::Request::FakeTable. -use strict; -use warnings; - -sub TIEHASH { - my $class = shift; - return bless {}, ref $class || $class; -} - -sub _canonical_key { - my $key = lc shift; - # CGI really wants a - before each header - return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; -} - -sub STORE { - my ($self, $key, $value) = @_; - $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; -} - -sub add { - my ($self, $key) = (shift, shift); - return unless defined $_[0]; - my $value = ref $_[0] ? "$_[0]" : $_[0]; - my $ckey = _canonical_key $key; - if (exists $self->{$ckey}) { - if (ref $self->{$ckey}[1]) { - push @{$self->{$ckey}[1]}, $value; - } else { - $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; - } - } else { - $self->{$ckey} = [ $key => $value ]; + else { + warn shift; } } -sub DELETE { - my ($self, $key) = @_; - my $ret = delete $self->{_canonical_key $key}; - return $ret->[1]; -} - -sub FETCH { - my ($self, $key) = @_; - # Grab the values first so that we don't autovivicate the key. - my $val = $self->{_canonical_key $key} or return; - if (my $ref = ref $val->[1]) { - return unless $val->[1][0]; - # Return the first value only. - return $val->[1][0]; - } - return $val->[1]; -} - -sub get { - my ($self, $key) = @_; - my $ckey = _canonical_key $key; - return unless exists $self->{$ckey}; - return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; - return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; -} - -sub CLEAR { - %{shift()} = (); -} - -sub EXISTS { - my ($self, $key)= @_; - return exists $self->{_canonical_key $key}; -} - -sub FIRSTKEY { - my $self = shift; - # Reset perl's iterator. - keys %$self; - # Get the first key via perl's iterator. - my $first_key = each %$self; - return undef unless defined $first_key; - return $self->{$first_key}[0]; -} - -sub NEXTKEY { - my ($self, $nextkey) = @_; - # Get the next key via perl's iterator. - my $next_key = each %$self; - return undef unless defined $next_key; - return $self->{$next_key}[0]; -} - -sub cgi_headers { - my $self = shift; - map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; -} - -sub _map_header_key_to_cgi_key { - return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; -} +## CGI request are _always_ main, and there is never a previous or a next +## internal request. +#sub main {} +#sub prev {} +#sub next {} +#sub is_main {1} +#sub is_initial_req {1} +# +## What to do with this? +## sub allowed {} +# +#sub method { +# $_[0]->query->request_method; +#} +# +## There mut be a mapping for this. +## sub method_number {} +# +## Can CGI.pm tell us this? +## sub bytes_sent {0} +# +## The request line sent by the client." Poached from Apache::Emulator. +#sub the_request { +# my $self = shift; +# $self->{the_request} ||= join ' ', $self->method, +# ( $self->{query}->query_string +# ? $self->uri . '?' . $self->{query}->query_string +# : $self->uri ), +# $self->{query}->server_protocol; +#} +# +## Is CGI ever a proxy request? +## sub proxy_req {} +# +#sub header_only { $_[0]->method eq 'HEAD' } +# +#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } +# +#sub hostname { $_[0]->{query}->server_name } +# +## CGI says "use this when using virtual hosts". It falls back to +## CGI->server_port. +#sub get_server_port { $_[0]->{query}->virtual_port } +# +## Fake it by just giving the current time. +#sub request_time { time } +# +#sub uri { +# my $self = shift; +# +# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; +#} +# +## Is this available in CGI? +## sub filename {} +# +## "The $r->location method will return the path of the +## section from which the current "Perl*Handler" +## is being called." This is irrelevant, I think. +## sub location {} +# +#sub path_info { $_[0]->{query}->path_info } +# +#sub args { +# my $self = shift; +# if (@_) { +# # Assign args here. +# } +# return $self->{query}->Vars unless wantarray; +# # Do more here to return key => arg values. +#} +# +#sub headers_in { +# my $self = shift; +# +# # Create the headers table if necessary. Decided how to build it based on +# # information here: +# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 +# # +# # Try to get as much info as possible from CGI.pm, which has +# # workarounds for things like the IIS PATH_INFO bug. +# # +# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new +# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. +# 'Content-Length' => $ENV{CONTENT_LENGTH}, +# 'Content-Type' => +# ( $self->{query}->can('content_type') ? +# $self->{query}->content_type : +# $ENV{CONTENT_TYPE} +# ), +# # Convert HTTP environment variables back into their header names. +# map { +# my $k = ucfirst lc; +# $k =~ s/_(.)/-\u$1/g; +# ( $k => $self->{query}->http($_) ) +# } grep { s/^HTTP_// } keys %ENV +# ); +# +# +# # Give 'em the hash list of the hash table. +# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; +#} +# +#sub header_in { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_in; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +# +## The $r->content method will return the entity body +## read from the client, but only if the request content +## type is "application/x-www-form-urlencoded". When +## called in a scalar context, the entire string is +## returned. When called in a list context, a list of +## parsed key => value pairs are returned. *NOTE*: you +## can only ask for this once, as the entire body is read +## from the client. +## Not sure what to do with this one. +## sub content {} +# +## I think this may be irrelevant under CGI. +## sub read {} +# +## Use LWP? +#sub get_remote_host {} +#sub get_remote_logname {} +# +#sub http_header { +# my $self = shift; +# my $h = $self->headers_out; +# my $e = $self->err_headers_out; +# my $method = exists $h->{Location} || exists $e->{Location} ? +# 'redirect' : 'header'; +# return $self->query->$method(tied(%$h)->cgi_headers, +# tied(%$e)->cgi_headers); +#} +# +#sub send_http_header { +# my $self = shift; +# +# return if $self->http_header_sent; +# +# print STDOUT $self->http_header; +# +# $self->{http_header_sent} = 1; +#} +# +#sub http_header_sent { shift->{http_header_sent} } +# +## How do we know this under CGI? +## sub get_basic_auth_pw {} +## sub note_basic_auth_failure {} +# +## I think that this just has to be empty. +#sub handler {} +# +#sub notes { +# my ($self, $key) = (shift, shift); +# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; +# return wantarray ? %{$self->{notes}} : $self->{notes} +# unless defined $key; +# return $self->{notes}{$key} = "$_[0]" if @_; +# return $self->{notes}{$key}; +#} +# +#sub pnotes { +# my ($self, $key) = (shift, shift); +# return wantarray ? %{$self->{pnotes}} : $self->{pnotes} +# unless defined $key; +# return $self->{pnotes}{$key} = $_[0] if @_; +# return $self->{pnotes}{$key}; +#} +# +#sub subprocess_env { +# my ($self, $key) = (shift, shift); +# unless (defined $key) { +# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); +# return wantarray ? %{$self->{subprocess_env}} : +# $self->{subprocess_env}; +# +# } +# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); +# return $self->{subprocess_env}{$key} = "$_[0]" if @_; +# return $self->{subprocess_env}{$key}; +#} +# +#sub content_type { +# shift->header_out('Content-Type', @_); +#} +# +#sub content_encoding { +# shift->header_out('Content-Encoding', @_); +#} +# +#sub content_languages { +# my ($self, $langs) = @_; +# return unless $langs; +# my $h = shift->headers_out; +# for my $l (@$langs) { +# $h->add('Content-Language', $l); +# } +#} +# +#sub status { +# shift->header_out('Status', @_); +#} +# +#sub status_line { +# # What to do here? Should it be managed differently than status? +# my $self = shift; +# if (@_) { +# my $status = shift =~ /^(\d+)/; +# return $self->header_out('Status', $status); +# } +# return $self->header_out('Status'); +#} +# +#sub headers_out { +# my $self = shift; +# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; +#} +# +#sub header_out { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_out; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +#sub err_headers_out { +# my $self = shift; +# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; +#} +# +#sub err_header_out { +# my ($self, $err_header) = (shift, shift); +# my $h = $self->err_headers_out; +# return @_ ? $h->set($err_header, shift) : $h->get($err_header); +#} +# +#sub no_cache { +# my $self = shift; +# $self->header_out(Pragma => 'no-cache'); +# $self->header_out('Cache-Control' => 'no-cache'); +#} +# +#sub print { +# shift; +# print @_; +#} +# +#sub send_fd { +# my ($self, $fd) = @_; +# local $_; +# +# print STDOUT while defined ($_ = <$fd>); +#} +# +## Should this perhaps throw an exception? +## sub internal_redirect {} +## sub internal_redirect_handler {} +# +## Do something with ErrorDocument? +## sub custom_response {} +# +## I think we've made this essentially the same thing. +#BEGIN { +# local $^W; +# *send_cgi_header = \&send_http_header; +#} +# +## Does CGI support logging? +## sub log_reason {} +## sub log_error {} +#sub warn { +# shift; +# print STDERR @_, "\n"; +#} +# +#sub params { +# my $self = shift; +# return _cgi_request_args($self->query, $self->query->request_method); +#} +# +#sub _cgi_request_args{ +# my ($q, $method) = @_; +# +# my %args; +# +# # Checking that there really is no query string when the method is +# # not POST is important because otherwise ->url_param returns a +# # parameter named 'keywords' with a value of () (empty array). +# # This is apparently a feature related to queries or +# # something (see the CGI.pm) docs. It makes my head hurt. - dave +# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); +# +# foreach my $key ( map { $q->$_() } @methods ) { +# next if exists $args{$key}; +# my @values = map { $q->$_($key) } @methods; +# $args{$key} = @values == 1 ? $values[0] : \@values; +# } +# +# return wantarray ? %args : \%args; +#} +# +# +############################################################ +#package WebGUI::Session::Request::FakeTable; +## Analogous to Apache::Table. +#use strict; +#use warnings; +# +#sub new { +# my $class = shift; +# my $self = {}; +# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; +# %$self = @_ if @_; +# return bless $self, ref $class || $class; +#} +# +#sub set { +# my ($self, $header, $value) = @_; +# defined $value ? $self->{$header} = $value : delete $self->{$header}; +#} +# +#sub unset { +# my $self = shift; +# delete $self->{shift()}; +#} +# +#sub add { +# tied(%{shift()})->add(@_); +#} +# +#sub clear { +# %{shift()} = (); +#} +# +#sub get { +# tied(%{shift()})->get(@_); +#} +# +#sub merge { +# my ($self, $key, $value) = @_; +# if (defined $self->{$key}) { +# $self->{$key} .= ',' . $value; +# } else { +# $self->{$key} = "$value"; +# } +#} +# +#sub do { +# my ($self, $code) = @_; +# while (my ($k, $val) = each %$self) { +# for my $v (ref $val ? @$val : $val) { +# return unless $code->($k => $v); +# } +# } +#} +# +############################################################ +#package WebGUI::Session::Request::FakeTableHash; +## Used by WebGUI::Session::Request::FakeTable. +#use strict; +#use warnings; +# +#sub TIEHASH { +# my $class = shift; +# return bless {}, ref $class || $class; +#} +# +#sub _canonical_key { +# my $key = lc shift; +# # CGI really wants a - before each header +# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; +#} +# +#sub STORE { +# my ($self, $key, $value) = @_; +# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; +#} +# +#sub add { +# my ($self, $key) = (shift, shift); +# return unless defined $_[0]; +# my $value = ref $_[0] ? "$_[0]" : $_[0]; +# my $ckey = _canonical_key $key; +# if (exists $self->{$ckey}) { +# if (ref $self->{$ckey}[1]) { +# push @{$self->{$ckey}[1]}, $value; +# } else { +# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; +# } +# } else { +# $self->{$ckey} = [ $key => $value ]; +# } +#} +# +#sub DELETE { +# my ($self, $key) = @_; +# my $ret = delete $self->{_canonical_key $key}; +# return $ret->[1]; +#} +# +#sub FETCH { +# my ($self, $key) = @_; +# # Grab the values first so that we don't autovivicate the key. +# my $val = $self->{_canonical_key $key} or return; +# if (my $ref = ref $val->[1]) { +# return unless $val->[1][0]; +# # Return the first value only. +# return $val->[1][0]; +# } +# return $val->[1]; +#} +# +#sub get { +# my ($self, $key) = @_; +# my $ckey = _canonical_key $key; +# return unless exists $self->{$ckey}; +# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; +# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; +#} +# +#sub CLEAR { +# %{shift()} = (); +#} +# +#sub EXISTS { +# my ($self, $key)= @_; +# return exists $self->{_canonical_key $key}; +#} +# +#sub FIRSTKEY { +# my $self = shift; +# # Reset perl's iterator. +# keys %$self; +# # Get the first key via perl's iterator. +# my $first_key = each %$self; +# return undef unless defined $first_key; +# return $self->{$first_key}[0]; +#} +# +#sub NEXTKEY { +# my ($self, $nextkey) = @_; +# # Get the next key via perl's iterator. +# my $next_key = each %$self; +# return undef unless defined $next_key; +# return $self->{$next_key}[0]; +#} +# +#sub cgi_headers { +# my $self = shift; +# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; +#} +# +#sub _map_header_key_to_cgi_key { +# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; +#} 1; diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index 14a2d8fd42..d2cb3f799b 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -62,6 +62,55 @@ to the user, instead of displaying the Page Not Found page. sub handler { my ($request, $server, $config) = @_; + + if ($request->isa('Plack::Request')) { +# my $session = $request->pnotes('wgSession'); +# unless (defined $session) { +# my $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); +# } + my $env = $request->env; + my $session = WebGUI::Session->open($env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'}, $request); + WEBGUI_FATAL: foreach my $handler (@{$config->get("contentHandlers")}) { + my $output = eval { WebGUI::Pluggable::run($handler, "handler", [ $session ] )}; + if ( my $e = WebGUI::Error->caught ) { + $session->errorHandler->error($e->package.":".$e->line." - ".$e->error); + $session->errorHandler->debug($e->package.":".$e->line." - ".$e->trace); + } + elsif ( $@ ) { + $session->errorHandler->error( $@ ); + } + else { + if ($output eq "chunked") { + if ($session->errorHandler->canShowDebug()) { + $session->output->print($session->errorHandler->showDebug(),1); + } + last; + } + if ($output eq "empty") { + if ($session->errorHandler->canShowDebug()) { + $session->output->print($session->errorHandler->showDebug(),1); + } + last; + } + elsif (defined $output && $output ne "") { + $session->http->sendHeader; + $session->output->print($output); + if ($session->errorHandler->canShowDebug()) { + $session->output->print($session->errorHandler->showDebug(),1); + } + last; + } + # Keep processing for success codes + elsif ($session->http->getStatus < 200 || $session->http->getStatus > 299) { + $session->http->sendHeader; + last; + } + } + } + $session->close; + return [ 200, [ 'Content-type' => 'text/html' ], [ 'Jah' ] ]; + } + $request->push_handlers(PerlResponseHandler => sub { my $session = $request->pnotes('wgSession'); unless (defined $session) { From cc2d60244b960faaac7c556561c94da5c5d12fee Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 22:02:06 +1100 Subject: [PATCH 03/15] Added WebGUI::Session::Plack --- lib/WebGUI.pm | 35 ++- lib/WebGUI/Session.pm | 8 +- lib/WebGUI/Session/Plack.pm | 553 ++++++++++++++++++++++++++++++++++ lib/WebGUI/Session/Request.pm | 520 +------------------------------- lib/WebGUI/URL/Content.pm | 48 --- 5 files changed, 599 insertions(+), 565 deletions(-) create mode 100644 lib/WebGUI/Session/Plack.pm diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 4a952da30e..35d12e07bd 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -208,27 +208,48 @@ sub handler { } sub handle_psgi { - my $env = shift; - my $request = WebGUI::Session::Request->new( env => $env ); + my $env = shift; # instead of an Apache2::Request object + 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 $server; my $error = ""; - my $matchUri = $request->plack->request_uri; + my $matchUri = $plack->uri; my $gateway = $config->get("gateway"); $matchUri =~ s{^$gateway}{/}; - - # We should probably ditch URL Handlers altogether in favour of Plack::Middleware + +# # 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)}); +# } + + + # 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", [ $request, $server, $config ] ) }; + 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 [ diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 57a39edb5f..4474a6a969 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -28,7 +28,6 @@ use WebGUI::Session::Id; use WebGUI::Session::Os; use WebGUI::Session::Output; use WebGUI::Session::Privilege; -use WebGUI::Session::Request; use WebGUI::Session::Scratch; use WebGUI::Session::Setting; use WebGUI::Session::Stow; @@ -441,7 +440,12 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; + + # This does our Plack TODO logging + # $self->{_request} = $request if (defined $request); + use WebGUI::Session::Request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; + my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); my $noFuss = shift; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm new file mode 100644 index 0000000000..71ca347d94 --- /dev/null +++ b/lib/WebGUI/Session/Plack.pm @@ -0,0 +1,553 @@ +package WebGUI::Session::Plack; + +use strict; +use warnings; + +=head1 DESCRIPTION + +This class is used instead of WebGUI::Session::Request when wg is started via plackup + +=cut + +sub new { + my $class = shift; + my %p = @_; + + # 'require' rather than 'use' so that non-plebgui doesn't freak out + require Plack::Request; + require Plack::Response; + + my $request = Plack::Request->new( $p{env} ); + my $response = $request->new_response; + + bless { + %p, + pnotes => {}, + request => $request, + response => $response, + server => WebGUI::Session::Plack::Server->new( env => $p{env} ), + }, $class; +} + +sub session { $_[0]{session} } +sub env { $_[0]{env} } +sub request { $_[0]{request} } +sub response { $_[0]{response} } +sub server { $_[0]{server} } + +our $AUTOLOAD; + +sub AUTOLOAD { + my $self = shift; + my $what = $AUTOLOAD; + $what =~ s/.*:://; + + warn "!!plack->$what(@_)"; +} + +sub uri { shift->request->request_uri(@_) } +sub headers_in { shift->request->headers(@_) } + +sub pnotes { + my ($self, $key) = (shift, shift); + return wantarray ? %{$self->{pnotes}} : $self->{pnotes} unless defined $key; + return $self->{pnotes}{$key} = $_[0] if @_; + return $self->{pnotes}{$key}; +} + +sub push_handlers { + my $self = shift; + my ($x, $sub) = @_; + warn "push_handlers on $x"; + return $sub->(); +} +# +#sub headers_in { +# my $self = shift; +# return unless $self->plack; +# return $self->plack->headers(@_); +#} + +package WebGUI::Session::Plack::Server; + +use strict; +use warnings; + +sub new { + my $class = shift; + bless { @_ }, $class; +} + +our $AUTOLOAD; +sub AUTOLOAD { + my $self = shift; + my $what = $AUTOLOAD; + $what =~ s/.*:://; + + warn "!!server->$what(@_)"; + return; +} + +# -- + +## CGI request are _always_ main, and there is never a previous or a next +## internal request. +#sub main {} +#sub prev {} +#sub next {} +#sub is_main {1} +#sub is_initial_req {1} +# +## What to do with this? +## sub allowed {} +# +#sub method { +# $_[0]->query->request_method; +#} +# +## There mut be a mapping for this. +## sub method_number {} +# +## Can CGI.pm tell us this? +## sub bytes_sent {0} +# +## The request line sent by the client." Poached from Apache::Emulator. +#sub the_request { +# my $self = shift; +# $self->{the_request} ||= join ' ', $self->method, +# ( $self->{query}->query_string +# ? $self->uri . '?' . $self->{query}->query_string +# : $self->uri ), +# $self->{query}->server_protocol; +#} +# +## Is CGI ever a proxy request? +## sub proxy_req {} +# +#sub header_only { $_[0]->method eq 'HEAD' } +# +#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } +# +#sub hostname { $_[0]->{query}->server_name } +# +## CGI says "use this when using virtual hosts". It falls back to +## CGI->server_port. +#sub get_server_port { $_[0]->{query}->virtual_port } +# +## Fake it by just giving the current time. +#sub request_time { time } +# +#sub uri { +# my $self = shift; +# +# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; +#} +# +## Is this available in CGI? +## sub filename {} +# +## "The $r->location method will return the path of the +## section from which the current "Perl*Handler" +## is being called." This is irrelevant, I think. +## sub location {} +# +#sub path_info { $_[0]->{query}->path_info } +# +#sub args { +# my $self = shift; +# if (@_) { +# # Assign args here. +# } +# return $self->{query}->Vars unless wantarray; +# # Do more here to return key => arg values. +#} +# +#sub headers_in { +# my $self = shift; +# +# # Create the headers table if necessary. Decided how to build it based on +# # information here: +# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 +# # +# # Try to get as much info as possible from CGI.pm, which has +# # workarounds for things like the IIS PATH_INFO bug. +# # +# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new +# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. +# 'Content-Length' => $ENV{CONTENT_LENGTH}, +# 'Content-Type' => +# ( $self->{query}->can('content_type') ? +# $self->{query}->content_type : +# $ENV{CONTENT_TYPE} +# ), +# # Convert HTTP environment variables back into their header names. +# map { +# my $k = ucfirst lc; +# $k =~ s/_(.)/-\u$1/g; +# ( $k => $self->{query}->http($_) ) +# } grep { s/^HTTP_// } keys %ENV +# ); +# +# +# # Give 'em the hash list of the hash table. +# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; +#} +# +#sub header_in { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_in; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +# +## The $r->content method will return the entity body +## read from the client, but only if the request content +## type is "application/x-www-form-urlencoded". When +## called in a scalar context, the entire string is +## returned. When called in a list context, a list of +## parsed key => value pairs are returned. *NOTE*: you +## can only ask for this once, as the entire body is read +## from the client. +## Not sure what to do with this one. +## sub content {} +# +## I think this may be irrelevant under CGI. +## sub read {} +# +## Use LWP? +#sub get_remote_host {} +#sub get_remote_logname {} +# +#sub http_header { +# my $self = shift; +# my $h = $self->headers_out; +# my $e = $self->err_headers_out; +# my $method = exists $h->{Location} || exists $e->{Location} ? +# 'redirect' : 'header'; +# return $self->query->$method(tied(%$h)->cgi_headers, +# tied(%$e)->cgi_headers); +#} +# +#sub send_http_header { +# my $self = shift; +# +# return if $self->http_header_sent; +# +# print STDOUT $self->http_header; +# +# $self->{http_header_sent} = 1; +#} +# +#sub http_header_sent { shift->{http_header_sent} } +# +## How do we know this under CGI? +## sub get_basic_auth_pw {} +## sub note_basic_auth_failure {} +# +## I think that this just has to be empty. +#sub handler {} +# +#sub notes { +# my ($self, $key) = (shift, shift); +# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; +# return wantarray ? %{$self->{notes}} : $self->{notes} +# unless defined $key; +# return $self->{notes}{$key} = "$_[0]" if @_; +# return $self->{notes}{$key}; +#} +# +#sub pnotes { +# my ($self, $key) = (shift, shift); +# return wantarray ? %{$self->{pnotes}} : $self->{pnotes} +# unless defined $key; +# return $self->{pnotes}{$key} = $_[0] if @_; +# return $self->{pnotes}{$key}; +#} +# +#sub subprocess_env { +# my ($self, $key) = (shift, shift); +# unless (defined $key) { +# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); +# return wantarray ? %{$self->{subprocess_env}} : +# $self->{subprocess_env}; +# +# } +# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); +# return $self->{subprocess_env}{$key} = "$_[0]" if @_; +# return $self->{subprocess_env}{$key}; +#} +# +#sub content_type { +# shift->header_out('Content-Type', @_); +#} +# +#sub content_encoding { +# shift->header_out('Content-Encoding', @_); +#} +# +#sub content_languages { +# my ($self, $langs) = @_; +# return unless $langs; +# my $h = shift->headers_out; +# for my $l (@$langs) { +# $h->add('Content-Language', $l); +# } +#} +# +#sub status { +# shift->header_out('Status', @_); +#} +# +#sub status_line { +# # What to do here? Should it be managed differently than status? +# my $self = shift; +# if (@_) { +# my $status = shift =~ /^(\d+)/; +# return $self->header_out('Status', $status); +# } +# return $self->header_out('Status'); +#} +# +#sub headers_out { +# my $self = shift; +# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; +#} +# +#sub header_out { +# my ($self, $header) = (shift, shift); +# my $h = $self->headers_out; +# return @_ ? $h->set($header, shift) : $h->get($header); +#} +# +#sub err_headers_out { +# my $self = shift; +# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; +#} +# +#sub err_header_out { +# my ($self, $err_header) = (shift, shift); +# my $h = $self->err_headers_out; +# return @_ ? $h->set($err_header, shift) : $h->get($err_header); +#} +# +#sub no_cache { +# my $self = shift; +# $self->header_out(Pragma => 'no-cache'); +# $self->header_out('Cache-Control' => 'no-cache'); +#} +# +#sub print { +# shift; +# print @_; +#} +# +#sub send_fd { +# my ($self, $fd) = @_; +# local $_; +# +# print STDOUT while defined ($_ = <$fd>); +#} +# +## Should this perhaps throw an exception? +## sub internal_redirect {} +## sub internal_redirect_handler {} +# +## Do something with ErrorDocument? +## sub custom_response {} +# +## I think we've made this essentially the same thing. +#BEGIN { +# local $^W; +# *send_cgi_header = \&send_http_header; +#} +# +## Does CGI support logging? +## sub log_reason {} +## sub log_error {} +#sub warn { +# shift; +# print STDERR @_, "\n"; +#} +# +#sub params { +# my $self = shift; +# return _cgi_request_args($self->query, $self->query->request_method); +#} +# +#sub _cgi_request_args{ +# my ($q, $method) = @_; +# +# my %args; +# +# # Checking that there really is no query string when the method is +# # not POST is important because otherwise ->url_param returns a +# # parameter named 'keywords' with a value of () (empty array). +# # This is apparently a feature related to queries or +# # something (see the CGI.pm) docs. It makes my head hurt. - dave +# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); +# +# foreach my $key ( map { $q->$_() } @methods ) { +# next if exists $args{$key}; +# my @values = map { $q->$_($key) } @methods; +# $args{$key} = @values == 1 ? $values[0] : \@values; +# } +# +# return wantarray ? %args : \%args; +#} +# +# +############################################################ +#package WebGUI::Session::Request::FakeTable; +## Analogous to Apache::Table. +#use strict; +#use warnings; +# +#sub new { +# my $class = shift; +# my $self = {}; +# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; +# %$self = @_ if @_; +# return bless $self, ref $class || $class; +#} +# +#sub set { +# my ($self, $header, $value) = @_; +# defined $value ? $self->{$header} = $value : delete $self->{$header}; +#} +# +#sub unset { +# my $self = shift; +# delete $self->{shift()}; +#} +# +#sub add { +# tied(%{shift()})->add(@_); +#} +# +#sub clear { +# %{shift()} = (); +#} +# +#sub get { +# tied(%{shift()})->get(@_); +#} +# +#sub merge { +# my ($self, $key, $value) = @_; +# if (defined $self->{$key}) { +# $self->{$key} .= ',' . $value; +# } else { +# $self->{$key} = "$value"; +# } +#} +# +#sub do { +# my ($self, $code) = @_; +# while (my ($k, $val) = each %$self) { +# for my $v (ref $val ? @$val : $val) { +# return unless $code->($k => $v); +# } +# } +#} +# +############################################################ +#package WebGUI::Session::Request::FakeTableHash; +## Used by WebGUI::Session::Request::FakeTable. +#use strict; +#use warnings; +# +#sub TIEHASH { +# my $class = shift; +# return bless {}, ref $class || $class; +#} +# +#sub _canonical_key { +# my $key = lc shift; +# # CGI really wants a - before each header +# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; +#} +# +#sub STORE { +# my ($self, $key, $value) = @_; +# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; +#} +# +#sub add { +# my ($self, $key) = (shift, shift); +# return unless defined $_[0]; +# my $value = ref $_[0] ? "$_[0]" : $_[0]; +# my $ckey = _canonical_key $key; +# if (exists $self->{$ckey}) { +# if (ref $self->{$ckey}[1]) { +# push @{$self->{$ckey}[1]}, $value; +# } else { +# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; +# } +# } else { +# $self->{$ckey} = [ $key => $value ]; +# } +#} +# +#sub DELETE { +# my ($self, $key) = @_; +# my $ret = delete $self->{_canonical_key $key}; +# return $ret->[1]; +#} +# +#sub FETCH { +# my ($self, $key) = @_; +# # Grab the values first so that we don't autovivicate the key. +# my $val = $self->{_canonical_key $key} or return; +# if (my $ref = ref $val->[1]) { +# return unless $val->[1][0]; +# # Return the first value only. +# return $val->[1][0]; +# } +# return $val->[1]; +#} +# +#sub get { +# my ($self, $key) = @_; +# my $ckey = _canonical_key $key; +# return unless exists $self->{$ckey}; +# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; +# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; +#} +# +#sub CLEAR { +# %{shift()} = (); +#} +# +#sub EXISTS { +# my ($self, $key)= @_; +# return exists $self->{_canonical_key $key}; +#} +# +#sub FIRSTKEY { +# my $self = shift; +# # Reset perl's iterator. +# keys %$self; +# # Get the first key via perl's iterator. +# my $first_key = each %$self; +# return undef unless defined $first_key; +# return $self->{$first_key}[0]; +#} +# +#sub NEXTKEY { +# my ($self, $nextkey) = @_; +# # Get the next key via perl's iterator. +# my $next_key = each %$self; +# return undef unless defined $next_key; +# return $self->{$next_key}[0]; +#} +# +#sub cgi_headers { +# my $self = shift; +# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; +#} +# +#sub _map_header_key_to_cgi_key { +# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; +#} + +1; diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm index e988a96d79..88ae0835d3 100644 --- a/lib/WebGUI/Session/Request.pm +++ b/lib/WebGUI/Session/Request.pm @@ -1,536 +1,40 @@ package WebGUI::Session::Request; -# We need to define an Apache package or we might get strange errors -# like "Can't locate package Apache for -# @WebGUI::Session::Request::ISA". We do the BEGIN/eval thing so that -# the CPAN indexer doesn't pick it up, which would be ugly. -#BEGIN { eval "package Apache" } -@WebGUI::Session::Request::ISA = qw(Apache); - -# Analogous to Apache request object $r (but not an actual Apache subclass) -# In the future we'll probably want to switch this to Apache::Fake or similar - use strict; use warnings; -use CGI; -sub new { - my $class = shift; - my %p = @_; +=head1 DESCRIPTION - my $self = bless { - %p, +This class wraps calls to $session->request and logs them so that we know +what is left to do to finish Plack support - # query => $p{cgi} || CGI->new, - # headers_out => WebGUI::Session::Request::FakeTable->new, - # err_headers_out => WebGUI::Session::Request::FakeTable->new, - pnotes => {}, - }, $class; +=cut - if ( $p{env} ) { - require Plack::Request; - require Plack::Response; - $self->{plack} = Plack::Request->new( $p{env} ); - } - - return $self; +sub new { + my $class = shift; + bless { @_ }, $class; } -sub session { $_[0]{session} } -sub env { $_[0]{env} } -sub r { $_[0]{r} } -sub plack { $_[0]{plack} } - our $AUTOLOAD; - sub AUTOLOAD { my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - my $r = $self->r; + my $r = $self->{r}; + my $session = $self->{session}; if ( !$r ) { - $self->log("!!request->$what(@_) but r not defined"); + $session->log->error("!!request->$what(@_) but r not defined"); return; } if ( $what eq 'print' ) { - $self->log("!!request->$what(print--chomped)"); + $session->log->error("!!request->$what(print--chomped)"); } else { - $self->log("!!request->$what(@_)"); + $session->log->error("!!request->$what(@_)"); } return $r->$what(@_); } -sub log { - my $self = shift; - if ( $self->session ) { - $self->session->log->error(shift); - } - else { - warn shift; - } -} - -## CGI request are _always_ main, and there is never a previous or a next -## internal request. -#sub main {} -#sub prev {} -#sub next {} -#sub is_main {1} -#sub is_initial_req {1} -# -## What to do with this? -## sub allowed {} -# -#sub method { -# $_[0]->query->request_method; -#} -# -## There mut be a mapping for this. -## sub method_number {} -# -## Can CGI.pm tell us this? -## sub bytes_sent {0} -# -## The request line sent by the client." Poached from Apache::Emulator. -#sub the_request { -# my $self = shift; -# $self->{the_request} ||= join ' ', $self->method, -# ( $self->{query}->query_string -# ? $self->uri . '?' . $self->{query}->query_string -# : $self->uri ), -# $self->{query}->server_protocol; -#} -# -## Is CGI ever a proxy request? -## sub proxy_req {} -# -#sub header_only { $_[0]->method eq 'HEAD' } -# -#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } -# -#sub hostname { $_[0]->{query}->server_name } -# -## CGI says "use this when using virtual hosts". It falls back to -## CGI->server_port. -#sub get_server_port { $_[0]->{query}->virtual_port } -# -## Fake it by just giving the current time. -#sub request_time { time } -# -#sub uri { -# my $self = shift; -# -# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; -#} -# -## Is this available in CGI? -## sub filename {} -# -## "The $r->location method will return the path of the -## section from which the current "Perl*Handler" -## is being called." This is irrelevant, I think. -## sub location {} -# -#sub path_info { $_[0]->{query}->path_info } -# -#sub args { -# my $self = shift; -# if (@_) { -# # Assign args here. -# } -# return $self->{query}->Vars unless wantarray; -# # Do more here to return key => arg values. -#} -# -#sub headers_in { -# my $self = shift; -# -# # Create the headers table if necessary. Decided how to build it based on -# # information here: -# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 -# # -# # Try to get as much info as possible from CGI.pm, which has -# # workarounds for things like the IIS PATH_INFO bug. -# # -# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new -# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. -# 'Content-Length' => $ENV{CONTENT_LENGTH}, -# 'Content-Type' => -# ( $self->{query}->can('content_type') ? -# $self->{query}->content_type : -# $ENV{CONTENT_TYPE} -# ), -# # Convert HTTP environment variables back into their header names. -# map { -# my $k = ucfirst lc; -# $k =~ s/_(.)/-\u$1/g; -# ( $k => $self->{query}->http($_) ) -# } grep { s/^HTTP_// } keys %ENV -# ); -# -# -# # Give 'em the hash list of the hash table. -# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; -#} -# -#sub header_in { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_in; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -# -## The $r->content method will return the entity body -## read from the client, but only if the request content -## type is "application/x-www-form-urlencoded". When -## called in a scalar context, the entire string is -## returned. When called in a list context, a list of -## parsed key => value pairs are returned. *NOTE*: you -## can only ask for this once, as the entire body is read -## from the client. -## Not sure what to do with this one. -## sub content {} -# -## I think this may be irrelevant under CGI. -## sub read {} -# -## Use LWP? -#sub get_remote_host {} -#sub get_remote_logname {} -# -#sub http_header { -# my $self = shift; -# my $h = $self->headers_out; -# my $e = $self->err_headers_out; -# my $method = exists $h->{Location} || exists $e->{Location} ? -# 'redirect' : 'header'; -# return $self->query->$method(tied(%$h)->cgi_headers, -# tied(%$e)->cgi_headers); -#} -# -#sub send_http_header { -# my $self = shift; -# -# return if $self->http_header_sent; -# -# print STDOUT $self->http_header; -# -# $self->{http_header_sent} = 1; -#} -# -#sub http_header_sent { shift->{http_header_sent} } -# -## How do we know this under CGI? -## sub get_basic_auth_pw {} -## sub note_basic_auth_failure {} -# -## I think that this just has to be empty. -#sub handler {} -# -#sub notes { -# my ($self, $key) = (shift, shift); -# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; -# return wantarray ? %{$self->{notes}} : $self->{notes} -# unless defined $key; -# return $self->{notes}{$key} = "$_[0]" if @_; -# return $self->{notes}{$key}; -#} -# -#sub pnotes { -# my ($self, $key) = (shift, shift); -# return wantarray ? %{$self->{pnotes}} : $self->{pnotes} -# unless defined $key; -# return $self->{pnotes}{$key} = $_[0] if @_; -# return $self->{pnotes}{$key}; -#} -# -#sub subprocess_env { -# my ($self, $key) = (shift, shift); -# unless (defined $key) { -# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); -# return wantarray ? %{$self->{subprocess_env}} : -# $self->{subprocess_env}; -# -# } -# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); -# return $self->{subprocess_env}{$key} = "$_[0]" if @_; -# return $self->{subprocess_env}{$key}; -#} -# -#sub content_type { -# shift->header_out('Content-Type', @_); -#} -# -#sub content_encoding { -# shift->header_out('Content-Encoding', @_); -#} -# -#sub content_languages { -# my ($self, $langs) = @_; -# return unless $langs; -# my $h = shift->headers_out; -# for my $l (@$langs) { -# $h->add('Content-Language', $l); -# } -#} -# -#sub status { -# shift->header_out('Status', @_); -#} -# -#sub status_line { -# # What to do here? Should it be managed differently than status? -# my $self = shift; -# if (@_) { -# my $status = shift =~ /^(\d+)/; -# return $self->header_out('Status', $status); -# } -# return $self->header_out('Status'); -#} -# -#sub headers_out { -# my $self = shift; -# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; -#} -# -#sub header_out { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_out; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -#sub err_headers_out { -# my $self = shift; -# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; -#} -# -#sub err_header_out { -# my ($self, $err_header) = (shift, shift); -# my $h = $self->err_headers_out; -# return @_ ? $h->set($err_header, shift) : $h->get($err_header); -#} -# -#sub no_cache { -# my $self = shift; -# $self->header_out(Pragma => 'no-cache'); -# $self->header_out('Cache-Control' => 'no-cache'); -#} -# -#sub print { -# shift; -# print @_; -#} -# -#sub send_fd { -# my ($self, $fd) = @_; -# local $_; -# -# print STDOUT while defined ($_ = <$fd>); -#} -# -## Should this perhaps throw an exception? -## sub internal_redirect {} -## sub internal_redirect_handler {} -# -## Do something with ErrorDocument? -## sub custom_response {} -# -## I think we've made this essentially the same thing. -#BEGIN { -# local $^W; -# *send_cgi_header = \&send_http_header; -#} -# -## Does CGI support logging? -## sub log_reason {} -## sub log_error {} -#sub warn { -# shift; -# print STDERR @_, "\n"; -#} -# -#sub params { -# my $self = shift; -# return _cgi_request_args($self->query, $self->query->request_method); -#} -# -#sub _cgi_request_args{ -# my ($q, $method) = @_; -# -# my %args; -# -# # Checking that there really is no query string when the method is -# # not POST is important because otherwise ->url_param returns a -# # parameter named 'keywords' with a value of () (empty array). -# # This is apparently a feature related to queries or -# # something (see the CGI.pm) docs. It makes my head hurt. - dave -# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); -# -# foreach my $key ( map { $q->$_() } @methods ) { -# next if exists $args{$key}; -# my @values = map { $q->$_($key) } @methods; -# $args{$key} = @values == 1 ? $values[0] : \@values; -# } -# -# return wantarray ? %args : \%args; -#} -# -# -############################################################ -#package WebGUI::Session::Request::FakeTable; -## Analogous to Apache::Table. -#use strict; -#use warnings; -# -#sub new { -# my $class = shift; -# my $self = {}; -# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; -# %$self = @_ if @_; -# return bless $self, ref $class || $class; -#} -# -#sub set { -# my ($self, $header, $value) = @_; -# defined $value ? $self->{$header} = $value : delete $self->{$header}; -#} -# -#sub unset { -# my $self = shift; -# delete $self->{shift()}; -#} -# -#sub add { -# tied(%{shift()})->add(@_); -#} -# -#sub clear { -# %{shift()} = (); -#} -# -#sub get { -# tied(%{shift()})->get(@_); -#} -# -#sub merge { -# my ($self, $key, $value) = @_; -# if (defined $self->{$key}) { -# $self->{$key} .= ',' . $value; -# } else { -# $self->{$key} = "$value"; -# } -#} -# -#sub do { -# my ($self, $code) = @_; -# while (my ($k, $val) = each %$self) { -# for my $v (ref $val ? @$val : $val) { -# return unless $code->($k => $v); -# } -# } -#} -# -############################################################ -#package WebGUI::Session::Request::FakeTableHash; -## Used by WebGUI::Session::Request::FakeTable. -#use strict; -#use warnings; -# -#sub TIEHASH { -# my $class = shift; -# return bless {}, ref $class || $class; -#} -# -#sub _canonical_key { -# my $key = lc shift; -# # CGI really wants a - before each header -# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; -#} -# -#sub STORE { -# my ($self, $key, $value) = @_; -# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; -#} -# -#sub add { -# my ($self, $key) = (shift, shift); -# return unless defined $_[0]; -# my $value = ref $_[0] ? "$_[0]" : $_[0]; -# my $ckey = _canonical_key $key; -# if (exists $self->{$ckey}) { -# if (ref $self->{$ckey}[1]) { -# push @{$self->{$ckey}[1]}, $value; -# } else { -# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; -# } -# } else { -# $self->{$ckey} = [ $key => $value ]; -# } -#} -# -#sub DELETE { -# my ($self, $key) = @_; -# my $ret = delete $self->{_canonical_key $key}; -# return $ret->[1]; -#} -# -#sub FETCH { -# my ($self, $key) = @_; -# # Grab the values first so that we don't autovivicate the key. -# my $val = $self->{_canonical_key $key} or return; -# if (my $ref = ref $val->[1]) { -# return unless $val->[1][0]; -# # Return the first value only. -# return $val->[1][0]; -# } -# return $val->[1]; -#} -# -#sub get { -# my ($self, $key) = @_; -# my $ckey = _canonical_key $key; -# return unless exists $self->{$ckey}; -# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; -# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; -#} -# -#sub CLEAR { -# %{shift()} = (); -#} -# -#sub EXISTS { -# my ($self, $key)= @_; -# return exists $self->{_canonical_key $key}; -#} -# -#sub FIRSTKEY { -# my $self = shift; -# # Reset perl's iterator. -# keys %$self; -# # Get the first key via perl's iterator. -# my $first_key = each %$self; -# return undef unless defined $first_key; -# return $self->{$first_key}[0]; -#} -# -#sub NEXTKEY { -# my ($self, $nextkey) = @_; -# # Get the next key via perl's iterator. -# my $next_key = each %$self; -# return undef unless defined $next_key; -# return $self->{$next_key}[0]; -#} -# -#sub cgi_headers { -# my $self = shift; -# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; -#} -# -#sub _map_header_key_to_cgi_key { -# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; -#} - 1; diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index d2cb3f799b..5102946b89 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -63,54 +63,6 @@ to the user, instead of displaying the Page Not Found page. sub handler { my ($request, $server, $config) = @_; - if ($request->isa('Plack::Request')) { -# my $session = $request->pnotes('wgSession'); -# unless (defined $session) { -# my $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $config->getFilename, $request, $server); -# } - my $env = $request->env; - my $session = WebGUI::Session->open($env->{'wg.WEBGUI_ROOT'}, $env->{'wg.WEBGUI_CONFIG'}, $request); - WEBGUI_FATAL: foreach my $handler (@{$config->get("contentHandlers")}) { - my $output = eval { WebGUI::Pluggable::run($handler, "handler", [ $session ] )}; - if ( my $e = WebGUI::Error->caught ) { - $session->errorHandler->error($e->package.":".$e->line." - ".$e->error); - $session->errorHandler->debug($e->package.":".$e->line." - ".$e->trace); - } - elsif ( $@ ) { - $session->errorHandler->error( $@ ); - } - else { - if ($output eq "chunked") { - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); - } - last; - } - if ($output eq "empty") { - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); - } - last; - } - elsif (defined $output && $output ne "") { - $session->http->sendHeader; - $session->output->print($output); - if ($session->errorHandler->canShowDebug()) { - $session->output->print($session->errorHandler->showDebug(),1); - } - last; - } - # Keep processing for success codes - elsif ($session->http->getStatus < 200 || $session->http->getStatus > 299) { - $session->http->sendHeader; - last; - } - } - } - $session->close; - return [ 200, [ 'Content-type' => 'text/html' ], [ 'Jah' ] ]; - } - $request->push_handlers(PerlResponseHandler => sub { my $session = $request->pnotes('wgSession'); unless (defined $session) { From 22deb042c5484a3fbe758e4ecd0fb1bbfadae34a Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 22:11:01 +1100 Subject: [PATCH 04/15] checkpoint --- etc/dev.localhost.localdomain.psgi | 2 ++ lib/WebGUI/Session/Plack.pm | 11 ++++++++++- lib/WebGUI/Session/Request.pm | 4 ++-- lib/WebGUI/URL/Content.pm | 1 - 4 files changed, 14 insertions(+), 4 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 4e5dad2887..4591416dab 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -13,6 +13,8 @@ my $app = sub { my $env = shift; $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; + $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; + $env->{'wg.DIR_CONFIG.WebguiConfig'} = $env->{'wg.WEBGUI_CONFIG'}; WebGUI::handle_psgi($env); }; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 71ca347d94..49ab5f62e0 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -2,6 +2,7 @@ package WebGUI::Session::Plack; use strict; use warnings; +use Carp; =head1 DESCRIPTION @@ -58,7 +59,7 @@ sub pnotes { sub push_handlers { my $self = shift; my ($x, $sub) = @_; - warn "push_handlers on $x"; + carp "push_handlers on $x"; return $sub->(); } # @@ -78,6 +79,8 @@ sub new { bless { @_ }, $class; } +sub env { shift->{env} } + our $AUTOLOAD; sub AUTOLOAD { my $self = shift; @@ -88,6 +91,12 @@ sub AUTOLOAD { return; } +sub dir_config { + my $self = shift; + my $c = shift; + return $self->env->{"wg.DIR_CONFIG.$c"}; +} + # -- ## CGI request are _always_ main, and there is never a previous or a next diff --git a/lib/WebGUI/Session/Request.pm b/lib/WebGUI/Session/Request.pm index 88ae0835d3..3c1cc87a34 100644 --- a/lib/WebGUI/Session/Request.pm +++ b/lib/WebGUI/Session/Request.pm @@ -5,8 +5,8 @@ use warnings; =head1 DESCRIPTION -This class wraps calls to $session->request and logs them so that we know -what is left to do to finish Plack support +This class wraps calls to $session->request and logs them as a cute way of seeing +what Apache2::* methods webgui is calling =cut diff --git a/lib/WebGUI/URL/Content.pm b/lib/WebGUI/URL/Content.pm index 5102946b89..14a2d8fd42 100644 --- a/lib/WebGUI/URL/Content.pm +++ b/lib/WebGUI/URL/Content.pm @@ -62,7 +62,6 @@ to the user, instead of displaying the Page Not Found page. sub handler { my ($request, $server, $config) = @_; - $request->push_handlers(PerlResponseHandler => sub { my $session = $request->pnotes('wgSession'); unless (defined $session) { From 640982b53305d2f422dcbc91d02d2f06ee44a17b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 9 Oct 2009 22:37:18 +1100 Subject: [PATCH 05/15] more minor progress --- lib/WebGUI/Session.pm | 13 +++++++++---- lib/WebGUI/Session/Http.pm | 4 ++++ lib/WebGUI/Session/Plack.pm | 6 ++++++ 3 files changed, 19 insertions(+), 4 deletions(-) diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 4474a6a969..af340baa19 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -440,11 +440,16 @@ sub open { my $config = WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; - - # This does our Plack TODO logging + # $self->{_request} = $request if (defined $request); - use WebGUI::Session::Request; - $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ) if $request; + if ($request && $request->isa('WebGUI::Session::Plack')) { + # Use our WebGUI::Session::Plack object that is supposed to do everything Apache2::* can + $self->{_request} = $request; + } else { + # Use WebGUI::Session::Request to wrap Apache2::* calls + require WebGUI::Session::Request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ); + } my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; $sessionId = $self->id->generate unless $self->id->valid($sessionId); diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 67b65678d1..d38b083036 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -92,6 +92,10 @@ Retrieves the cookies from the HTTP header and returns a hash reference containi sub getCookies { my $self = shift; if ($self->session->request) { + if ($self->session->request->isa('WebGUI::Session::Plack')) { + return $self->session->request->request->cookies; + } + # Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows) require APR::Request::Apache2; my $jarHashRef = APR::Request::Apache2->handle($self->session->request)->jar(); diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 49ab5f62e0..cde6a74c97 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -48,6 +48,12 @@ sub AUTOLOAD { sub uri { shift->request->request_uri(@_) } sub headers_in { shift->request->headers(@_) } +sub param { shift->request->param(@_) } +sub params { shift->request->params(@_) } + +# TODO: I suppose this should do some sort of IO::Handle thing +my @body; +sub print { shift; push @body, @_ } sub pnotes { my ($self, $key) = (shift, shift); From 1c908649e352e6d0e3d030a814453dcbd5567679 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 11:44:10 +1100 Subject: [PATCH 06/15] 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 35d12e07bd..aef7e3ab6a 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}{/}; - -# # 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)}); -# } + my $plack = WebGUI::Session::Plack->new( env => $env ); + # 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 d38b083036..2fbb01af5e 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 cde6a74c97..2cd5906fc2 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 From 9440063a27d71ff664261fe2b2cbd30db3b1195b Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 12:11:22 +1100 Subject: [PATCH 07/15] Caching is breaking something --- etc/dev.localhost.localdomain.psgi | 35 +++++++++++++++++------------- lib/WebGUI.pm | 29 +++++++++++++++---------- lib/WebGUI/Session/Plack.pm | 15 +++++++++++-- 3 files changed, 51 insertions(+), 28 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 4591416dab..febb7bdbd5 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,8 +1,9 @@ BEGIN { + # This is just a temporary hack - our $WEBGUI_ROOT = '/data/WebGUI'; + our $WEBGUI_ROOT = '/data/WebGUI'; our $WEBGUI_DOMAINS = '/data/domains'; - our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; + our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; } use local::lib $WEBGUI_ROOT; use WebGUI; @@ -11,26 +12,30 @@ use Plack::Builder; my $app = sub { my $env = shift; - $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; - $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; - $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; + $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; + $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; + $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; $env->{'wg.DIR_CONFIG.WebguiConfig'} = $env->{'wg.WEBGUI_CONFIG'}; WebGUI::handle_psgi($env); }; # Apply some Middleware builder { + # /extras - enable Plack::Middleware::Static - path => qr{^/extras/}, root => "$WEBGUI_ROOT/www/"; - + enable Plack::Middleware::Static + path => qr{^/extras/}, + root => "$WEBGUI_ROOT/www/"; + # /uploads (ignore .wgaccess for now..) - enable Plack::Middleware::Static - path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; - + enable Plack::Middleware::Static + path => qr{^/uploads/}, + root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; + enable Plack::Middleware::XFramework framework => 'WebGUI'; - - enable Plack::Middleware::AccessLog format => "combined"; - + + # Already enabled by plackup script + # enable Plack::Middleware::AccessLog format => "combined"; + $app; -} \ No newline at end of file +} diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index aef7e3ab6a..217c5495de 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -78,8 +78,13 @@ A reference to a WebGUI::Config object. One will be created if it isn't specifie sub authen { my ($request, $username, $password, $config) = @_; - $request = Apache2::Request->new($request); - my $server = Apache2::ServerUtil->server; + 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 $status = Apache2::Const::OK; # set username and password if it's an auth handler @@ -173,15 +178,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 @@ -212,6 +217,8 @@ sub handler { return Apache2::Const::DECLINED; } + + sub handle_psgi { my $env = shift; require WebGUI::Session::Plack; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 2cd5906fc2..0ef9a90c58 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -19,7 +19,7 @@ sub new { require Plack::Response; my $request = Plack::Request->new( $p{env} ); - my $response = $request->new_response; + my $response = $request->new_response(200); my $self = bless { %p, @@ -59,10 +59,17 @@ sub protocol { shift->request->protocol(@_) } sub status { shift->response->status(@_) } sub status_line {} +sub auth_type { + # should we support this? +} + # TODO: I suppose this should do some sort of IO::Handle thing my @body; sub print { shift; push @body, @_ } +my $sendfile; +sub sendfile { shift; $sendfile = shift; } + sub dir_config { my $self = shift; my $c = shift; @@ -100,7 +107,11 @@ sub push_handlers { sub finalize { my $self = shift; - $self->response->body(\@body); + if ($sendfile && open my $fh, '<', $sendfile) { + $self->response->body( $fh ); + } else { + $self->response->body( $sendfile || \@body); + } return $self->response->finalize; } From c19e82c57af13c01b71ee530191998783073fdb7 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 18:54:54 +1100 Subject: [PATCH 08/15] she works! --- etc/dev.localhost.localdomain.psgi | 14 +- lib/WebGUI/Session.pm | 16 +- lib/WebGUI/Session/Http.pm | 4 +- lib/WebGUI/Session/Plack.pm | 552 +++-------------------------- 4 files changed, 60 insertions(+), 526 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index febb7bdbd5..df9d00c614 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -7,7 +7,7 @@ BEGIN { } use local::lib $WEBGUI_ROOT; use WebGUI; -use Plack::Middleware qw( Static XFramework AccessLog ); +use Plack::Middleware; use Plack::Builder; my $app = sub { @@ -23,19 +23,21 @@ my $app = sub { builder { # /extras - enable Plack::Middleware::Static + add 'Plack::Middleware::Static', path => qr{^/extras/}, root => "$WEBGUI_ROOT/www/"; # /uploads (ignore .wgaccess for now..) - enable Plack::Middleware::Static + add 'Plack::Middleware::Static', path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; - enable Plack::Middleware::XFramework framework => 'WebGUI'; + add 'Plack::Middleware::XFramework', + framework => 'WebGUI'; # Already enabled by plackup script - # enable Plack::Middleware::AccessLog format => "combined"; + # add 'Plack::Middleware::AccessLog', + # format => "combined"; $app; -} +} \ No newline at end of file diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index af340baa19..0ae9a53056 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -442,13 +442,15 @@ sub open { bless $self , $class; # $self->{_request} = $request if (defined $request); - if ($request && $request->isa('WebGUI::Session::Plack')) { - # Use our WebGUI::Session::Plack object that is supposed to do everything Apache2::* can - $self->{_request} = $request; - } else { - # Use WebGUI::Session::Request to wrap Apache2::* calls - require WebGUI::Session::Request; - $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ); + if ($request) { + if ($request->isa('WebGUI::Session::Plack')) { + # Use our WebGUI::Session::Plack object that is supposed to do everything Apache2::* can + $self->{_request} = $request; + } else { + # Use WebGUI::Session::Request to wrap Apache2::* calls + require WebGUI::Session::Request; + $self->{_request} = WebGUI::Session::Request->new( r => $request, session => $self ); + } } my $sessionId = shift || $self->http->getCookies->{$config->getCookieName} || $self->id->generate; diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 2fbb01af5e..473d558357 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -93,7 +93,7 @@ sub getCookies { my $self = shift; if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - return $self->session->request->request->cookies; + return $self->session->request->request_cookies; } # Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows) @@ -390,7 +390,7 @@ sub setCookie { if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - $self->session->request->response->cookies->{$name} = { + $self->session->request->response_cookies->{$name} = { value => $value, path => '/', expires => $ttl ne 'session' ? $ttl : undef, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 0ef9a90c58..2a123207e6 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -11,13 +11,10 @@ This class is used instead of WebGUI::Session::Request when wg is started via pl =cut sub new { - my $class = shift; - my %p = @_; + my ($class, %p) = @_; # 'require' rather than 'use' so that non-plebgui doesn't freak out require Plack::Request; - require Plack::Response; - my $request = Plack::Request->new( $p{env} ); my $response = $request->new_response(200); @@ -27,53 +24,48 @@ sub new { request => $request, response => $response, server => WebGUI::Session::Plack::Server->new( env => $p{env} ), + body => [], + sendfile => undef, }, $class; - $self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( plack => $self ); - + $self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ); return $self; } -sub session { $_[0]{session} } -sub env { $_[0]{env} } -sub request { $_[0]{request} } -sub response { $_[0]{response} } -sub server { $_[0]{server} } - our $AUTOLOAD; - sub AUTOLOAD { - my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!plack->$what(@_)"; } -sub uri { shift->request->request_uri(@_) } -sub param { shift->request->param(@_) } -sub params { shift->request->params(@_) } -sub headers_in { shift->request->headers(@_) } +# Emulate/delegate/fake Apache2::* subs +sub uri { shift->{request}->request_uri(@_) } +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 protocol { shift->{request}->protocol(@_) } +sub status { shift->{response}->status(@_) } +sub sendfile { $_[0]->{sendfile} = $_[1] } +sub content_type { shift->{response}->content_type(@_) } sub status_line {} +sub DESTROY {} +sub auth_type {} # should we support this? -sub auth_type { - # should we support this? -} +sub server { shift->{server} } +sub request_cookies { shift->{request}->cookies } +sub response_cookies { shift->{response}->cookies(@_) } # TODO: I suppose this should do some sort of IO::Handle thing -my @body; -sub print { shift; push @body, @_ } - -my $sendfile; -sub sendfile { shift; $sendfile = shift; } +sub print { + my $self = shift; + push @{$self->{body}}, @_; +} sub dir_config { - my $self = shift; - my $c = shift; - return $self->env->{"wg.DIR_CONFIG.$c"}; + my ($self, $c) = @_; + return $self->{env}->{"wg.DIR_CONFIG.$c"}; } sub pnotes { @@ -96,7 +88,7 @@ sub push_handlers { my ($x, $sub) = @_; # log it - carp "push_handlers($x)"; + # carp "push_handlers($x)"; # run it # returns something like Apache2::Const::OK, which we just ignore because we're not modperl @@ -107,16 +99,15 @@ sub push_handlers { sub finalize { my $self = shift; - if ($sendfile && open my $fh, '<', $sendfile) { - $self->response->body( $fh ); + my $response = $self->{response}; + if ($self->{sendfile} && open my $fh, '<', $self->{sendfile}) { + $response->body( $fh ); } else { - $self->response->body( $sendfile || \@body); + $response->body( $self->{body} ); } - return $self->response->finalize; + return $response->finalize; } -sub content_type { shift->response->content_type(@_) } - # #sub headers_in { # my $self = shift; @@ -124,6 +115,8 @@ sub content_type { shift->response->content_type(@_) } # return $self->plack->headers(@_); #} +################################################ + package WebGUI::Session::Plack::Server; use strict; @@ -135,24 +128,21 @@ sub new { bless { @_ }, $class; } -sub env { shift->{env} } - our $AUTOLOAD; sub AUTOLOAD { - my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!server->$what(@_)"; - return; } +sub DESTROY {} sub dir_config { - my $self = shift; - my $c = shift; - return $self->env->{"wg.DIR_CONFIG.$c"}; + my ($self, $c) = @_; + return $self->{env}->{"wg.DIR_CONFIG.$c"}; } +################################################ + package WebGUI::Session::Plack::HeadersOut; use strict; @@ -166,476 +156,16 @@ sub new { our $AUTOLOAD; sub AUTOLOAD { - my $self = shift; my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!headers_out->$what(@_)"; - return; } -sub set { shift->{plack}->response->headers->header(@_) } +sub DESTROY {} -# -- +# Called by wG as $session->response->headers_out->set('Content-Type' => 'text/html'); +sub set { shift->{response}->headers->header(@_) } -## CGI request are _always_ main, and there is never a previous or a next -## internal request. -#sub main {} -#sub prev {} -#sub next {} -#sub is_main {1} -#sub is_initial_req {1} -# -## What to do with this? -## sub allowed {} -# -#sub method { -# $_[0]->query->request_method; -#} -# -## There mut be a mapping for this. -## sub method_number {} -# -## Can CGI.pm tell us this? -## sub bytes_sent {0} -# -## The request line sent by the client." Poached from Apache::Emulator. -#sub the_request { -# my $self = shift; -# $self->{the_request} ||= join ' ', $self->method, -# ( $self->{query}->query_string -# ? $self->uri . '?' . $self->{query}->query_string -# : $self->uri ), -# $self->{query}->server_protocol; -#} -# -## Is CGI ever a proxy request? -## sub proxy_req {} -# -#sub header_only { $_[0]->method eq 'HEAD' } -# -#sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } -# -#sub hostname { $_[0]->{query}->server_name } -# -## CGI says "use this when using virtual hosts". It falls back to -## CGI->server_port. -#sub get_server_port { $_[0]->{query}->virtual_port } -# -## Fake it by just giving the current time. -#sub request_time { time } -# -#sub uri { -# my $self = shift; -# -# $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; -#} -# -## Is this available in CGI? -## sub filename {} -# -## "The $r->location method will return the path of the -## section from which the current "Perl*Handler" -## is being called." This is irrelevant, I think. -## sub location {} -# -#sub path_info { $_[0]->{query}->path_info } -# -#sub args { -# my $self = shift; -# if (@_) { -# # Assign args here. -# } -# return $self->{query}->Vars unless wantarray; -# # Do more here to return key => arg values. -#} -# -#sub headers_in { -# my $self = shift; -# -# # Create the headers table if necessary. Decided how to build it based on -# # information here: -# # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 -# # -# # Try to get as much info as possible from CGI.pm, which has -# # workarounds for things like the IIS PATH_INFO bug. -# # -# $self->{headers_in} ||= WebGUI::Session::Request::FakeTable->new -# ( 'Authorization' => $self->{query}->auth_type, # No credentials though. -# 'Content-Length' => $ENV{CONTENT_LENGTH}, -# 'Content-Type' => -# ( $self->{query}->can('content_type') ? -# $self->{query}->content_type : -# $ENV{CONTENT_TYPE} -# ), -# # Convert HTTP environment variables back into their header names. -# map { -# my $k = ucfirst lc; -# $k =~ s/_(.)/-\u$1/g; -# ( $k => $self->{query}->http($_) ) -# } grep { s/^HTTP_// } keys %ENV -# ); -# -# -# # Give 'em the hash list of the hash table. -# return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; -#} -# -#sub header_in { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_in; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -# -## The $r->content method will return the entity body -## read from the client, but only if the request content -## type is "application/x-www-form-urlencoded". When -## called in a scalar context, the entire string is -## returned. When called in a list context, a list of -## parsed key => value pairs are returned. *NOTE*: you -## can only ask for this once, as the entire body is read -## from the client. -## Not sure what to do with this one. -## sub content {} -# -## I think this may be irrelevant under CGI. -## sub read {} -# -## Use LWP? -#sub get_remote_host {} -#sub get_remote_logname {} -# -#sub http_header { -# my $self = shift; -# my $h = $self->headers_out; -# my $e = $self->err_headers_out; -# my $method = exists $h->{Location} || exists $e->{Location} ? -# 'redirect' : 'header'; -# return $self->query->$method(tied(%$h)->cgi_headers, -# tied(%$e)->cgi_headers); -#} -# -#sub send_http_header { -# my $self = shift; -# -# return if $self->http_header_sent; -# -# print STDOUT $self->http_header; -# -# $self->{http_header_sent} = 1; -#} -# -#sub http_header_sent { shift->{http_header_sent} } -# -## How do we know this under CGI? -## sub get_basic_auth_pw {} -## sub note_basic_auth_failure {} -# -## I think that this just has to be empty. -#sub handler {} -# -#sub notes { -# my ($self, $key) = (shift, shift); -# $self->{notes} ||= WebGUI::Session::Request::FakeTable->new; -# return wantarray ? %{$self->{notes}} : $self->{notes} -# unless defined $key; -# return $self->{notes}{$key} = "$_[0]" if @_; -# return $self->{notes}{$key}; -#} -# -#sub pnotes { -# my ($self, $key) = (shift, shift); -# return wantarray ? %{$self->{pnotes}} : $self->{pnotes} -# unless defined $key; -# return $self->{pnotes}{$key} = $_[0] if @_; -# return $self->{pnotes}{$key}; -#} -# -#sub subprocess_env { -# my ($self, $key) = (shift, shift); -# unless (defined $key) { -# $self->{subprocess_env} = WebGUI::Session::Request::FakeTable->new(%ENV); -# return wantarray ? %{$self->{subprocess_env}} : -# $self->{subprocess_env}; -# -# } -# $self->{subprocess_env} ||= WebGUI::Session::Request::FakeTable->new(%ENV); -# return $self->{subprocess_env}{$key} = "$_[0]" if @_; -# return $self->{subprocess_env}{$key}; -#} -# -#sub content_type { -# shift->header_out('Content-Type', @_); -#} -# -#sub content_encoding { -# shift->header_out('Content-Encoding', @_); -#} -# -#sub content_languages { -# my ($self, $langs) = @_; -# return unless $langs; -# my $h = shift->headers_out; -# for my $l (@$langs) { -# $h->add('Content-Language', $l); -# } -#} -# -#sub status { -# shift->header_out('Status', @_); -#} -# -#sub status_line { -# # What to do here? Should it be managed differently than status? -# my $self = shift; -# if (@_) { -# my $status = shift =~ /^(\d+)/; -# return $self->header_out('Status', $status); -# } -# return $self->header_out('Status'); -#} -# -#sub headers_out { -# my $self = shift; -# return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; -#} -# -#sub header_out { -# my ($self, $header) = (shift, shift); -# my $h = $self->headers_out; -# return @_ ? $h->set($header, shift) : $h->get($header); -#} -# -#sub err_headers_out { -# my $self = shift; -# return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; -#} -# -#sub err_header_out { -# my ($self, $err_header) = (shift, shift); -# my $h = $self->err_headers_out; -# return @_ ? $h->set($err_header, shift) : $h->get($err_header); -#} -# -#sub no_cache { -# my $self = shift; -# $self->header_out(Pragma => 'no-cache'); -# $self->header_out('Cache-Control' => 'no-cache'); -#} -# -#sub print { -# shift; -# print @_; -#} -# -#sub send_fd { -# my ($self, $fd) = @_; -# local $_; -# -# print STDOUT while defined ($_ = <$fd>); -#} -# -## Should this perhaps throw an exception? -## sub internal_redirect {} -## sub internal_redirect_handler {} -# -## Do something with ErrorDocument? -## sub custom_response {} -# -## I think we've made this essentially the same thing. -#BEGIN { -# local $^W; -# *send_cgi_header = \&send_http_header; -#} -# -## Does CGI support logging? -## sub log_reason {} -## sub log_error {} -#sub warn { -# shift; -# print STDERR @_, "\n"; -#} -# -#sub params { -# my $self = shift; -# return _cgi_request_args($self->query, $self->query->request_method); -#} -# -#sub _cgi_request_args{ -# my ($q, $method) = @_; -# -# my %args; -# -# # Checking that there really is no query string when the method is -# # not POST is important because otherwise ->url_param returns a -# # parameter named 'keywords' with a value of () (empty array). -# # This is apparently a feature related to queries or -# # something (see the CGI.pm) docs. It makes my head hurt. - dave -# my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); -# -# foreach my $key ( map { $q->$_() } @methods ) { -# next if exists $args{$key}; -# my @values = map { $q->$_($key) } @methods; -# $args{$key} = @values == 1 ? $values[0] : \@values; -# } -# -# return wantarray ? %args : \%args; -#} -# -# -############################################################ -#package WebGUI::Session::Request::FakeTable; -## Analogous to Apache::Table. -#use strict; -#use warnings; -# -#sub new { -# my $class = shift; -# my $self = {}; -# tie %{$self}, 'WebGUI::Session::Request::FakeTableHash'; -# %$self = @_ if @_; -# return bless $self, ref $class || $class; -#} -# -#sub set { -# my ($self, $header, $value) = @_; -# defined $value ? $self->{$header} = $value : delete $self->{$header}; -#} -# -#sub unset { -# my $self = shift; -# delete $self->{shift()}; -#} -# -#sub add { -# tied(%{shift()})->add(@_); -#} -# -#sub clear { -# %{shift()} = (); -#} -# -#sub get { -# tied(%{shift()})->get(@_); -#} -# -#sub merge { -# my ($self, $key, $value) = @_; -# if (defined $self->{$key}) { -# $self->{$key} .= ',' . $value; -# } else { -# $self->{$key} = "$value"; -# } -#} -# -#sub do { -# my ($self, $code) = @_; -# while (my ($k, $val) = each %$self) { -# for my $v (ref $val ? @$val : $val) { -# return unless $code->($k => $v); -# } -# } -#} -# -############################################################ -#package WebGUI::Session::Request::FakeTableHash; -## Used by WebGUI::Session::Request::FakeTable. -#use strict; -#use warnings; -# -#sub TIEHASH { -# my $class = shift; -# return bless {}, ref $class || $class; -#} -# -#sub _canonical_key { -# my $key = lc shift; -# # CGI really wants a - before each header -# return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; -#} -# -#sub STORE { -# my ($self, $key, $value) = @_; -# $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; -#} -# -#sub add { -# my ($self, $key) = (shift, shift); -# return unless defined $_[0]; -# my $value = ref $_[0] ? "$_[0]" : $_[0]; -# my $ckey = _canonical_key $key; -# if (exists $self->{$ckey}) { -# if (ref $self->{$ckey}[1]) { -# push @{$self->{$ckey}[1]}, $value; -# } else { -# $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; -# } -# } else { -# $self->{$ckey} = [ $key => $value ]; -# } -#} -# -#sub DELETE { -# my ($self, $key) = @_; -# my $ret = delete $self->{_canonical_key $key}; -# return $ret->[1]; -#} -# -#sub FETCH { -# my ($self, $key) = @_; -# # Grab the values first so that we don't autovivicate the key. -# my $val = $self->{_canonical_key $key} or return; -# if (my $ref = ref $val->[1]) { -# return unless $val->[1][0]; -# # Return the first value only. -# return $val->[1][0]; -# } -# return $val->[1]; -#} -# -#sub get { -# my ($self, $key) = @_; -# my $ckey = _canonical_key $key; -# return unless exists $self->{$ckey}; -# return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; -# return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; -#} -# -#sub CLEAR { -# %{shift()} = (); -#} -# -#sub EXISTS { -# my ($self, $key)= @_; -# return exists $self->{_canonical_key $key}; -#} -# -#sub FIRSTKEY { -# my $self = shift; -# # Reset perl's iterator. -# keys %$self; -# # Get the first key via perl's iterator. -# my $first_key = each %$self; -# return undef unless defined $first_key; -# return $self->{$first_key}[0]; -#} -# -#sub NEXTKEY { -# my ($self, $nextkey) = @_; -# # Get the next key via perl's iterator. -# my $next_key = each %$self; -# return undef unless defined $next_key; -# return $self->{$next_key}[0]; -#} -# -#sub cgi_headers { -# my $self = shift; -# map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; -#} -# -#sub _map_header_key_to_cgi_key { -# return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; -#} +################################################ 1; From c720710f8169afab35de057ad489926966fbe1fc Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 19:28:19 +1100 Subject: [PATCH 09/15] fixed cookie handling --- etc/dev.localhost.localdomain.psgi | 7 +- lib/WebGUI/Session/Http.pm | 20 ++-- lib/WebGUI/Session/Plack.pm | 146 +++++++++++++++++------------ 3 files changed, 99 insertions(+), 74 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index df9d00c614..31a4e55c9a 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -32,12 +32,11 @@ builder { path => qr{^/uploads/}, root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; - add 'Plack::Middleware::XFramework', - framework => 'WebGUI'; + add 'Plack::Middleware::XFramework', framework => 'WebGUI'; # Already enabled by plackup script - # add 'Plack::Middleware::AccessLog', + # add 'Plack::Middleware::AccessLog', # format => "combined"; $app; -} \ No newline at end of file +} diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 473d558357..0861d2d9f3 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -93,7 +93,7 @@ sub getCookies { my $self = shift; if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - return $self->session->request->request_cookies; + return $self->session->request->get_request_cookies; } # Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows) @@ -389,15 +389,17 @@ 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, - }; + if ( $self->session->request->isa('WebGUI::Session::Plack') ) { + $self->session->request->set_response_cookie( + $name => { + value => $value, + path => '/', + expires => $ttl ne 'session' ? $ttl : undef, + domain => $domain, + } + ); return; - } + } require Apache2::Cookie; my $cookie = Apache2::Cookie->new($self->session->request, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 2a123207e6..d0709c176e 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -11,73 +11,78 @@ This class is used instead of WebGUI::Session::Request when wg is started via pl =cut sub new { - my ($class, %p) = @_; + my ( $class, %p ) = @_; # 'require' rather than 'use' so that non-plebgui doesn't freak out require Plack::Request; - my $request = Plack::Request->new( $p{env} ); + my $request = Plack::Request->new( $p{env} ); my $response = $request->new_response(200); - - my $self = bless { + + bless { %p, - pnotes => {}, - request => $request, - response => $response, - server => WebGUI::Session::Plack::Server->new( env => $p{env} ), - body => [], - sendfile => undef, + pnotes => {}, + request => $request, + response => $response, + server => WebGUI::Session::Plack::Server->new( env => $p{env} ), + headers_out => WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ), + body => [], + sendfile => undef, }, $class; - - $self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ); - return $self; } our $AUTOLOAD; + sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!plack->$what(@_)"; + carp "!!plack->$what(@_)" unless $what eq 'DESTROY'; } # Emulate/delegate/fake Apache2::* subs -sub uri { shift->{request}->request_uri(@_) } -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 sendfile { $_[0]->{sendfile} = $_[1] } +sub uri { shift->{request}->request_uri(@_) } +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 sendfile { $_[0]->{sendfile} = $_[1] } sub content_type { shift->{response}->content_type(@_) } -sub status_line {} -sub DESTROY {} -sub auth_type {} # should we support this? +sub server { shift->{server} } +sub status_line { } +sub auth_type { } # should we support this? -sub server { shift->{server} } -sub request_cookies { shift->{request}->cookies } -sub response_cookies { shift->{response}->cookies(@_) } +# These two cookie subs are called from our wG Plack-specific code +sub get_request_cookies { shift->{request}->cookies } # returns hashref of all request cookies + +sub set_response_cookie { + my ( $self, $name, $val ) = @_; + + #warn "setting cookies $name => " . Data::Dumper::Dumper($val); + $self->{response}->cookies->{$name} = $val; +} # TODO: I suppose this should do some sort of IO::Handle thing -sub print { - my $self = shift; - push @{$self->{body}}, @_; +sub print { + my $self = shift; + push @{ $self->{body} }, @_; } sub dir_config { - my ($self, $c) = @_; + my ( $self, $c ) = @_; return $self->{env}->{"wg.DIR_CONFIG.$c"}; } sub pnotes { - my ($self, $key) = (shift, shift); - return wantarray ? %{$self->{pnotes}} : $self->{pnotes} unless defined $key; + my ( $self, $key ) = ( shift, shift ); + return wantarray ? %{ $self->{pnotes} } : $self->{pnotes} unless defined $key; return $self->{pnotes}{$key} = $_[0] if @_; return $self->{pnotes}{$key}; } sub user { - my ($self, $user) = @_; - if (defined $user) { + my ( $self, $user ) = @_; + if ( defined $user ) { $self->{user} = $user; } $self->{user}; @@ -85,35 +90,39 @@ sub user { sub push_handlers { my $self = shift; - my ($x, $sub) = @_; - + my ( $x, $sub ) = @_; + # log it # carp "push_handlers($x)"; - - # run it + + # 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; + my $self = shift; my $response = $self->{response}; - if ($self->{sendfile} && open my $fh, '<', $self->{sendfile}) { - $response->body( $fh ); - } else { + if ( $self->{sendfile} && open my $fh, '<', $self->{sendfile} ) { + $response->body($fh); + } + else { $response->body( $self->{body} ); } return $response->finalize; } -# -#sub headers_in { -# my $self = shift; -# return unless $self->plack; -# return $self->plack->headers(@_); -#} +sub no_cache { + my ( $self, $doit ) = @_; + if ($doit) { + $self->{response}->headers->push_header( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' ); + } + else { + $self->{response}->headers->remove_header( 'Pragma', 'Cache-control' ); + } +} ################################################ @@ -125,19 +134,19 @@ use Carp; sub new { my $class = shift; - bless { @_ }, $class; + bless {@_}, $class; } our $AUTOLOAD; + sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!server->$what(@_)"; + carp "!!server->$what(@_)" unless $what eq 'DESTROY'; } -sub DESTROY {} sub dir_config { - my ($self, $c) = @_; + my ( $self, $c ) = @_; return $self->{env}->{"wg.DIR_CONFIG.$c"}; } @@ -145,26 +154,41 @@ sub dir_config { package WebGUI::Session::Plack::HeadersOut; +=head1 DESCRIPTION + +This class is required so that wG can call: + + $session->response->headers_out->set('a' => 'b'); + +But for code under out control we just use: + + $response->headers->push_header('a' => 'b'); + $repsonse->headers->remove_header('a'); + +=cut + use strict; use warnings; use Carp; sub new { my $class = shift; - bless { @_ }, $class; + bless {@_}, $class; } our $AUTOLOAD; + sub AUTOLOAD { my $what = $AUTOLOAD; $what =~ s/.*:://; - carp "!!headers_out->$what(@_)"; + carp "!!headers_out->$what(@_)" unless $what eq 'DESTROY'; } -sub DESTROY {} - -# Called by wG as $session->response->headers_out->set('Content-Type' => 'text/html'); -sub set { shift->{response}->headers->header(@_) } +# This is the sub that wG calls +sub set { + my $self = shift; + $self->{response}->headers->push_header(@_); +} ################################################ From 6daa143d4c5271e50d5e4bee0cd92613ce340873 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 20:34:41 +1100 Subject: [PATCH 10/15] Headers via Plack::Util::headers Uploads work now too --- lib/WebGUI/Session/Plack.pm | 70 ++++++++++++------------------------- 1 file changed, 22 insertions(+), 48 deletions(-) diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index d0709c176e..a12dd30db1 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -20,11 +20,11 @@ sub new { bless { %p, - pnotes => {}, - request => $request, - response => $response, - server => WebGUI::Session::Plack::Server->new( env => $p{env} ), - headers_out => WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ), + pnotes => {}, + request => $request, + response => $response, + server => WebGUI::Session::Plack::Server->new( env => $p{env} ), + headers_out => Plack::Util::headers( [] ), # use Plack::Util to manage response headers body => [], sendfile => undef, }, $class; @@ -49,16 +49,25 @@ sub status { shift->{response}->status(@_) } sub sendfile { $_[0]->{sendfile} = $_[1] } sub content_type { shift->{response}->content_type(@_) } sub server { shift->{server} } +sub method { shift->{request}->method } +sub upload { shift->{request}->upload(@_) } sub status_line { } sub auth_type { } # should we support this? # These two cookie subs are called from our wG Plack-specific code -sub get_request_cookies { shift->{request}->cookies } # returns hashref of all request cookies +sub get_request_cookies { + + # Get the hash of { name => CGI::Simple::Cookie } + my $cookies = shift->{request}->cookies; + + # Convert into { name => value } as expected by wG + my %c = map { $_->name => $_->value } values %{$cookies}; + + return \%c; +} sub set_response_cookie { my ( $self, $name, $val ) = @_; - - #warn "setting cookies $name => " . Data::Dumper::Dumper($val); $self->{response}->cookies->{$name} = $val; } @@ -111,16 +120,17 @@ sub finalize { else { $response->body( $self->{body} ); } + $response->headers( $self->{headers_out}->headers ); return $response->finalize; } sub no_cache { my ( $self, $doit ) = @_; if ($doit) { - $self->{response}->headers->push_header( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' ); + $self->{headers_out}->set( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' ); } else { - $self->{response}->headers->remove_header( 'Pragma', 'Cache-control' ); + $self->{headers_out}->remove( 'Pragma', 'Cache-control' ); } } @@ -152,44 +162,8 @@ sub dir_config { ################################################ -package WebGUI::Session::Plack::HeadersOut; - -=head1 DESCRIPTION - -This class is required so that wG can call: - - $session->response->headers_out->set('a' => 'b'); - -But for code under out control we just use: - - $response->headers->push_header('a' => 'b'); - $repsonse->headers->remove_header('a'); - -=cut - -use strict; -use warnings; -use Carp; +package Plack::Request::Upload; -sub new { - my $class = shift; - bless {@_}, $class; -} - -our $AUTOLOAD; - -sub AUTOLOAD { - my $what = $AUTOLOAD; - $what =~ s/.*:://; - carp "!!headers_out->$what(@_)" unless $what eq 'DESTROY'; -} - -# This is the sub that wG calls -sub set { - my $self = shift; - $self->{response}->headers->push_header(@_); -} - -################################################ +sub link { shift->link_to(@_) } 1; From b1e304eb9d2383e190d486cc22b5047985d95cbe Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sat, 10 Oct 2009 22:46:06 +1100 Subject: [PATCH 11/15] Added WGAccess Middleware --- etc/dev.localhost.localdomain.psgi | 46 +++++++------ lib/Plack/Middleware/WGAccess.pm | 104 +++++++++++++++++++++++++++++ 2 files changed, 130 insertions(+), 20 deletions(-) create mode 100644 lib/Plack/Middleware/WGAccess.pm diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 31a4e55c9a..6ed510b334 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,42 +1,48 @@ BEGIN { - - # This is just a temporary hack - our $WEBGUI_ROOT = '/data/WebGUI'; - our $WEBGUI_DOMAINS = '/data/domains'; - our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; + # Define your site settings here + # These are the config values that normally appear in your wre's + # site.modperl.conf and site.modproxy.conf + our $WEBGUI_ROOT = '/data/WebGUI'; + our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; + our $DOCUMENT_ROOT = '/data/domains/dev.localhost.localdomain/public'; } use local::lib $WEBGUI_ROOT; use WebGUI; -use Plack::Middleware; use Plack::Builder; -my $app = sub { +my %SETTINGS = ( + 'wg.WEBGUI_ROOT' => $WEBGUI_ROOT, + 'wg.WEBGUI_CONFIG' => "$WEBGUI_CONFIG.conf", + 'wg.DOCUMENT_ROOT' => $DOCUMENT_ROOT, + 'wg.DIR_CONFIG.WebguiRoot' => $WEBGUI_ROOT, + 'wg.DIR_CONFIG.WebguiConfig' => "$WEBGUI_CONFIG.conf", +); + +my $wg = sub { my $env = shift; - $env->{'wg.WEBGUI_ROOT'} = $WEBGUI_ROOT; - $env->{'wg.WEBGUI_CONFIG'} = "$WEBGUI_CONFIG.conf"; - $env->{'wg.DIR_CONFIG.WebguiRoot'} = $env->{'wg.WEBGUI_ROOT'}; - $env->{'wg.DIR_CONFIG.WebguiConfig'} = $env->{'wg.WEBGUI_CONFIG'}; + @{$env}{ keys %SETTINGS } = values %SETTINGS; WebGUI::handle_psgi($env); }; -# Apply some Middleware builder { - # /extras + # /extras - deliver via Plack::Middleware::Static add 'Plack::Middleware::Static', path => qr{^/extras/}, - root => "$WEBGUI_ROOT/www/"; + root => "$SETTINGS{'wg.WEBGUI_ROOT'}/www/"; - # /uploads (ignore .wgaccess for now..) - add 'Plack::Middleware::Static', - path => qr{^/uploads/}, - root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; + # /uploads - deliver via Plack::Middleware::WGAccess + # This takes the place of WebGUI::URL::Uploads in handling .wgaccess and + # delivery of static files in /uploads + add 'Plack::Middleware::WGAccess', + path => qr{^/uploads/}, + settings => {%SETTINGS}; add 'Plack::Middleware::XFramework', framework => 'WebGUI'; - # Already enabled by plackup script + # AccessLog already enabled by default if you are using the plackup script # add 'Plack::Middleware::AccessLog', # format => "combined"; - $app; + $wg; } diff --git a/lib/Plack/Middleware/WGAccess.pm b/lib/Plack/Middleware/WGAccess.pm new file mode 100644 index 0000000000..ce7b71228b --- /dev/null +++ b/lib/Plack/Middleware/WGAccess.pm @@ -0,0 +1,104 @@ +package Plack::Middleware::WGAccess; +use strict; +use warnings; +use base qw/Plack::Middleware::Static/; +use Path::Class 'dir'; +__PACKAGE__->mk_accessors('settings'); + +=head1 NAME + +Plack::Middleware::WGAccess + +=head1 DESCRIPTION + +Plack Middleware that delivers static files with .wgaccess awareness + +=cut + +sub _handle_static { + my($self, $env) = @_; + + # Populate $env with $self->settings so that we get consistent wg API behaviour + my %settings = %{$self->settings}; + @{$env}{keys %settings} = values %settings; + + # Populate $self->root from $SETTINGS so that it doesn't need to be specified in psgi file + $self->root($settings{'wg.DOCUMENT_ROOT'}); + + ####################################### + # Copied from Plack::Middleware::Static::_handle_static + + my $path_match = $self->path or return; + + if ($env->{PATH_INFO} =~ m!\.\.[/\\]!) { + return $self->return_403; + } + + my $path = do { + my $matched; + local $_ = $env->{PATH_INFO}; + if (ref $path_match eq 'CODE') { + $matched = $path_match->($_); + } else { + $matched = $_ =~ $path_match; + } + return unless $matched; + $_; + } or return; + + my $docroot = dir($self->root || "."); + my $file = $docroot->file(File::Spec::Unix->splitpath($path)); + my $realpath = Cwd::realpath($file->absolute->stringify); + + # Is the requested path within the root? + if ($realpath && !$docroot->subsumes($realpath)) { + return $self->return_403; + } + + # Does the file actually exist? + if (!$realpath || !-f $file) { + return $self->return_404; + } + + # If the requested file present but lacking the permission to read it? + if (!-r $file) { + return $self->return_403; + } + + ############################### + # Copied from WebGUI::URL::Uploads + my $wgaccess = File::Spec::Unix->catfile($file->dir, '.wgaccess'); + if (-e $wgaccess) { + my $fileContents; + open(my $FILE, "<", $wgaccess); + while (my $line = <$FILE>) { + $fileContents .= $line; + } + close($FILE); + my @privs = split("\n", $fileContents); + unless ($privs[1] eq "7" || $privs[1] eq "1") { + + # Construct request,server,config in the usual way + require WebGUI::Session::Plack; + my $request = WebGUI::Session::Plack->new( env => $env ); + my $server = $request->server; + + my $session = $request->pnotes('wgSession'); + unless (defined $session) { + $session = WebGUI::Session->open($server->dir_config('WebguiRoot'), $request->dir_config('WebguiConfig'), $request, $server); + } + my $hasPrivs = ($session->var->get("userId") eq $privs[0] || $session->user->isInGroup($privs[1]) || $session->user->isInGroup($privs[2])); + $session->close(); + if ($hasPrivs) { + return $self->SUPER::_handle_static($env); # serve statically + } + else { + return $self->return_403; + } + } + } else { + return $self->SUPER::_handle_static($env); # serve statically + } +} + +1; \ No newline at end of file From d04a2422286b197b2162f56b542ab92a0858f99d Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sun, 11 Oct 2009 01:07:08 +1100 Subject: [PATCH 12/15] Added Apache CGI/FCGI/mod_perl examples --- apache.conf | 21 +++++++++++++++++++++ etc/dev.localhost.localdomain.cgi | 5 +++++ etc/dev.localhost.localdomain.fcgi | 5 +++++ etc/dev.localhost.localdomain.psgi | 3 ++- lib/WebGUI/Session/Plack.pm | 7 ++++++- 5 files changed, 39 insertions(+), 2 deletions(-) create mode 100644 apache.conf create mode 100755 etc/dev.localhost.localdomain.cgi create mode 100755 etc/dev.localhost.localdomain.fcgi diff --git a/apache.conf b/apache.conf new file mode 100644 index 0000000000..7be1edbfeb --- /dev/null +++ b/apache.conf @@ -0,0 +1,21 @@ + + PerlOptions +Parent + PerlSwitches -I/data/WebGUI/lib + + # CGI + #AddHandler cgi-script cgi + #ScriptAlias / /data/WebGUI/etc/dev.localhost.localdomain.cgi/ + # + # Options +ExecCGI + # + + # Apache2 + #SetHandler perl-script + #PerlHandler Plack::Server::Apache2 + #PerlSetVar psgi_app /data/WebGUI/etc/dev.localhost.localdomain.psgi + + # FastCGI + FastCgiServer /data/WebGUI/etc/dev.localhost.localdomain.fcgi + ScriptAlias / /data/WebGUI/etc/dev.localhost.localdomain.fcgi/ + + diff --git a/etc/dev.localhost.localdomain.cgi b/etc/dev.localhost.localdomain.cgi new file mode 100755 index 0000000000..71eee8fab1 --- /dev/null +++ b/etc/dev.localhost.localdomain.cgi @@ -0,0 +1,5 @@ +#!/usr/bin/perl +use Plack::Server::CGI; + +my $app = Plack::Util::load_psgi("/data/WebGUI/etc/dev.localhost.localdomain.psgi"); +Plack::Server::CGI->new->run($app); \ No newline at end of file diff --git a/etc/dev.localhost.localdomain.fcgi b/etc/dev.localhost.localdomain.fcgi new file mode 100755 index 0000000000..4312742927 --- /dev/null +++ b/etc/dev.localhost.localdomain.fcgi @@ -0,0 +1,5 @@ +#!/usr/bin/perl +use Plack::Server::FCGI; + +my $app = Plack::Util::load_psgi("/data/WebGUI/etc/dev.localhost.localdomain.psgi"); +Plack::Server::FCGI->new->run($app); diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index 6ed510b334..b40d87272e 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -6,7 +6,8 @@ BEGIN { our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; our $DOCUMENT_ROOT = '/data/domains/dev.localhost.localdomain/public'; } -use local::lib $WEBGUI_ROOT; +use lib "$WEBGUI_ROOT/lib"; +#use local::lib $WEBGUI_ROOT; use WebGUI; use Plack::Builder; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index a12dd30db1..bf46721933 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -47,12 +47,17 @@ sub headers_out { shift->{headers_out} } sub protocol { shift->{request}->protocol(@_) } sub status { shift->{response}->status(@_) } sub sendfile { $_[0]->{sendfile} = $_[1] } -sub content_type { shift->{response}->content_type(@_) } sub server { shift->{server} } sub method { shift->{request}->method } sub upload { shift->{request}->upload(@_) } sub status_line { } sub auth_type { } # should we support this? +sub handler { 'perl-script' } # or not..? + +sub content_type { + my ($self, $ct) = @_; + $self->{headers_out}->set( 'Content-Type' => $ct ); +} # These two cookie subs are called from our wG Plack-specific code sub get_request_cookies { From a613c64a96258296655144e42ed809ef015e81b2 Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Sun, 11 Oct 2009 19:03:31 +1100 Subject: [PATCH 13/15] Added perlbal and Plack::Middleware::WebGUI to simplify psgi file --- apache.conf | 6 +++ etc/dev.localhost.localdomain.perlbal | 7 ++++ etc/dev.localhost.localdomain.psgi | 54 ++++++++------------------- lib/Plack/Middleware/WGAccess.pm | 8 ---- lib/Plack/Middleware/WebGUI.pm | 30 +++++++++++++++ lib/WebGUI/Session/Plack.pm | 46 ++++++++++++----------- 6 files changed, 82 insertions(+), 69 deletions(-) create mode 100644 etc/dev.localhost.localdomain.perlbal create mode 100644 lib/Plack/Middleware/WebGUI.pm diff --git a/apache.conf b/apache.conf index 7be1edbfeb..71ea481657 100644 --- a/apache.conf +++ b/apache.conf @@ -18,4 +18,10 @@ FastCgiServer /data/WebGUI/etc/dev.localhost.localdomain.fcgi ScriptAlias / /data/WebGUI/etc/dev.localhost.localdomain.fcgi/ + # mod_psgi + # + # SetHandler psgi + # PSGIApp /data/WebGUI/etc/dev.localhost.localdomain.psgi + # + diff --git a/etc/dev.localhost.localdomain.perlbal b/etc/dev.localhost.localdomain.perlbal new file mode 100644 index 0000000000..98b85382e8 --- /dev/null +++ b/etc/dev.localhost.localdomain.perlbal @@ -0,0 +1,7 @@ + LOAD PSGI + CREATE SERVICE psgi + SET role = web_server + SET listen = 127.0.0.1:80 + SET plugins = psgi + PSGI_APP = dev.localhost.localdomain.psgi + ENABLE psgi \ No newline at end of file diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index b40d87272e..ae98f20df2 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,49 +1,25 @@ -BEGIN { - # Define your site settings here - # These are the config values that normally appear in your wre's - # site.modperl.conf and site.modproxy.conf - our $WEBGUI_ROOT = '/data/WebGUI'; - our $WEBGUI_CONFIG = 'dev.localhost.localdomain'; - our $DOCUMENT_ROOT = '/data/domains/dev.localhost.localdomain/public'; -} -use lib "$WEBGUI_ROOT/lib"; -#use local::lib $WEBGUI_ROOT; -use WebGUI; use Plack::Builder; - -my %SETTINGS = ( - 'wg.WEBGUI_ROOT' => $WEBGUI_ROOT, - 'wg.WEBGUI_CONFIG' => "$WEBGUI_CONFIG.conf", - 'wg.DOCUMENT_ROOT' => $DOCUMENT_ROOT, - 'wg.DIR_CONFIG.WebguiRoot' => $WEBGUI_ROOT, - 'wg.DIR_CONFIG.WebguiConfig' => "$WEBGUI_CONFIG.conf", -); - -my $wg = sub { - my $env = shift; - @{$env}{ keys %SETTINGS } = values %SETTINGS; - WebGUI::handle_psgi($env); -}; +use lib '/data/WebGUI/lib'; +use WebGUI; builder { - - # /extras - deliver via Plack::Middleware::Static + + # Populate $env from site.conf + add 'Plack::Middleware::WebGUI', + root => '/data/WebGUI', + config => 'dev.localhost.localdomain.conf'; + + # Handle /extras via Plack::Middleware::Static + # (or Plack::Middleware::WebGUI could do this for us by looking up extrasPath and extrasURL in site.conf) add 'Plack::Middleware::Static', path => qr{^/extras/}, - root => "$SETTINGS{'wg.WEBGUI_ROOT'}/www/"; + root => '/data/WebGUI/www'; - # /uploads - deliver via Plack::Middleware::WGAccess - # This takes the place of WebGUI::URL::Uploads in handling .wgaccess and - # delivery of static files in /uploads + # Handle /uploads via Plack::Middleware::WGAccess (including .wgaccess) + # (or Plack::Middleware::WebGUI could do this for us by looking up uploadsPath and uploadsURL in site.conf) add 'Plack::Middleware::WGAccess', path => qr{^/uploads/}, - settings => {%SETTINGS}; - - add 'Plack::Middleware::XFramework', framework => 'WebGUI'; - - # AccessLog already enabled by default if you are using the plackup script - # add 'Plack::Middleware::AccessLog', - # format => "combined"; + root => '/data/domains/dev.localhost.localdomain/public'; - $wg; + sub { WebGUI::handle_psgi(shift) }; } diff --git a/lib/Plack/Middleware/WGAccess.pm b/lib/Plack/Middleware/WGAccess.pm index ce7b71228b..8c289cfba0 100644 --- a/lib/Plack/Middleware/WGAccess.pm +++ b/lib/Plack/Middleware/WGAccess.pm @@ -3,7 +3,6 @@ use strict; use warnings; use base qw/Plack::Middleware::Static/; use Path::Class 'dir'; -__PACKAGE__->mk_accessors('settings'); =head1 NAME @@ -17,13 +16,6 @@ Plack Middleware that delivers static files with .wgaccess awareness sub _handle_static { my($self, $env) = @_; - - # Populate $env with $self->settings so that we get consistent wg API behaviour - my %settings = %{$self->settings}; - @{$env}{keys %settings} = values %settings; - - # Populate $self->root from $SETTINGS so that it doesn't need to be specified in psgi file - $self->root($settings{'wg.DOCUMENT_ROOT'}); ####################################### # Copied from Plack::Middleware::Static::_handle_static diff --git a/lib/Plack/Middleware/WebGUI.pm b/lib/Plack/Middleware/WebGUI.pm new file mode 100644 index 0000000000..defa4eda5e --- /dev/null +++ b/lib/Plack/Middleware/WebGUI.pm @@ -0,0 +1,30 @@ +package Plack::Middleware::WebGUI; +use strict; +use warnings; +use base qw/Plack::Middleware/; + +__PACKAGE__->mk_accessors('root', 'config'); + +=head1 NAME + +Plack::Middleware::WebGUI + +=head1 DESCRIPTION + +Plack Middleware that populates $env + +In the future we might want to read the site.conf here and then cache it + +=cut + +sub call { + my $self = shift; + my $env = shift; + + $env->{'wg.WEBGUI_ROOT'} = $self->root; + $env->{'wg.WEBGUI_CONFIG'} = $self->config; + + $self->app->($env); +} + +1; \ No newline at end of file diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index bf46721933..3446718cfc 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -39,23 +39,24 @@ sub AUTOLOAD { } # Emulate/delegate/fake Apache2::* subs -sub uri { shift->{request}->request_uri(@_) } -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 sendfile { $_[0]->{sendfile} = $_[1] } -sub server { shift->{server} } -sub method { shift->{request}->method } -sub upload { shift->{request}->upload(@_) } -sub status_line { } -sub auth_type { } # should we support this? -sub handler { 'perl-script' } # or not..? - -sub content_type { - my ($self, $ct) = @_; +sub uri { shift->{request}->request_uri(@_) } +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 sendfile { $_[0]->{sendfile} = $_[1] } +sub server { shift->{server} } +sub method { shift->{request}->method } +sub upload { shift->{request}->upload(@_) } +sub dir_config { shift->{server}->dir_config(@_) } +sub status_line { } +sub auth_type { } # should we support this? +sub handler {'perl-script'} # or not..? + +sub content_type { + my ( $self, $ct ) = @_; $self->{headers_out}->set( 'Content-Type' => $ct ); } @@ -82,11 +83,6 @@ sub print { push @{ $self->{body} }, @_; } -sub dir_config { - my ( $self, $c ) = @_; - return $self->{env}->{"wg.DIR_CONFIG.$c"}; -} - sub pnotes { my ( $self, $key ) = ( shift, shift ); return wantarray ? %{ $self->{pnotes} } : $self->{pnotes} unless defined $key; @@ -162,6 +158,12 @@ sub AUTOLOAD { sub dir_config { my ( $self, $c ) = @_; + + # Translate the legacy WebguiRoot and WebguiConfig PerlSetVar's into known values + return $self->{env}->{'wg.WEBGUI_ROOT'} if $c eq 'WebguiRoot'; + return $self->{env}->{'wg.WEBGUI_CONFIG'} if $c eq 'WebguiConfig'; + + # Otherwise, we might want to provide some sort of support (which Apache is still around) return $self->{env}->{"wg.DIR_CONFIG.$c"}; } From 88a060e33a9688ee450dea3c4aa9b54107e9099a Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Thu, 15 Oct 2009 09:48:40 +1100 Subject: [PATCH 14/15] experimental caching --- etc/dev.localhost.localdomain.psgi | 14 +++++++------- lib/Plack/Middleware/WebGUI.pm | 2 -- lib/WebGUI.pm | 22 +++++++++++++++++++--- lib/WebGUI/Session.pm | 2 +- lib/WebGUI/Session/Plack.pm | 4 ++-- 5 files changed, 29 insertions(+), 15 deletions(-) diff --git a/etc/dev.localhost.localdomain.psgi b/etc/dev.localhost.localdomain.psgi index ae98f20df2..b0f6b63b9e 100644 --- a/etc/dev.localhost.localdomain.psgi +++ b/etc/dev.localhost.localdomain.psgi @@ -1,23 +1,23 @@ use Plack::Builder; use lib '/data/WebGUI/lib'; use WebGUI; +WebGUI->init( root => '/data/WebGUI', config => 'dev.localhost.localdomain.conf' ); builder { - - # Populate $env from site.conf - add 'Plack::Middleware::WebGUI', - root => '/data/WebGUI', - config => 'dev.localhost.localdomain.conf'; # Handle /extras via Plack::Middleware::Static # (or Plack::Middleware::WebGUI could do this for us by looking up extrasPath and extrasURL in site.conf) - add 'Plack::Middleware::Static', + enable 'Plack::Middleware::Static', path => qr{^/extras/}, root => '/data/WebGUI/www'; # Handle /uploads via Plack::Middleware::WGAccess (including .wgaccess) # (or Plack::Middleware::WebGUI could do this for us by looking up uploadsPath and uploadsURL in site.conf) - add 'Plack::Middleware::WGAccess', + #enable 'Plack::Middleware::WGAccess', + # path => qr{^/uploads/}, + # root => '/data/domains/dev.localhost.localdomain/public'; + + enable 'Plack::Middleware::Static', path => qr{^/uploads/}, root => '/data/domains/dev.localhost.localdomain/public'; diff --git a/lib/Plack/Middleware/WebGUI.pm b/lib/Plack/Middleware/WebGUI.pm index defa4eda5e..748f531f00 100644 --- a/lib/Plack/Middleware/WebGUI.pm +++ b/lib/Plack/Middleware/WebGUI.pm @@ -13,8 +13,6 @@ Plack::Middleware::WebGUI Plack Middleware that populates $env -In the future we might want to read the site.conf here and then cache it - =cut sub call { diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index 217c5495de..ac40b5d41c 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -162,15 +162,17 @@ The Apache2::RequestRec object passed in by Apache's mod_perl. sub handler { my $request = shift; # either apache request object or PSGI env hash - my $server; + my ($server, $config); if ($request->isa('WebGUI::Session::Plack')) { $server = $request->server; + $config = WebGUI->config; } 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 + $config = WebGUI::Config->new($server->dir_config('WebguiRoot'), $configFile); #instantiate the config object } - 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 $config = WebGUI::Config->new($server->dir_config('WebguiRoot'), $configFile); #instantiate the config object + my $error = ""; my $matchUri = $request->uri; my $gateway = $config->get("gateway"); @@ -231,5 +233,19 @@ sub handle_psgi { return $plack->finalize; } +# Experimental speed boost +my ($root, $config_file, $config); +sub init { + my $class = shift; + my %opts = @_; + $root = $opts{root}; + $config_file = $opts{config}; + $config = WebGUI::Config->new($root, $config_file); + warn 'INIT'; +} +sub config { $config } +sub root { $root } +sub config_file { $config_file } + 1; diff --git a/lib/WebGUI/Session.pm b/lib/WebGUI/Session.pm index 0ae9a53056..9acc280fbe 100644 --- a/lib/WebGUI/Session.pm +++ b/lib/WebGUI/Session.pm @@ -437,7 +437,7 @@ sub open { my $configFile = shift; my $request = shift; my $server = shift; - my $config = WebGUI::Config->new($webguiRoot,$configFile); + my $config = WebGUI->config || WebGUI::Config->new($webguiRoot,$configFile); my $self = {_config=>$config, _server=>$server}; bless $self , $class; diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 3446718cfc..1b552ffa18 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -160,8 +160,8 @@ sub dir_config { my ( $self, $c ) = @_; # Translate the legacy WebguiRoot and WebguiConfig PerlSetVar's into known values - return $self->{env}->{'wg.WEBGUI_ROOT'} if $c eq 'WebguiRoot'; - return $self->{env}->{'wg.WEBGUI_CONFIG'} if $c eq 'WebguiConfig'; + return WebGUI->root if $c eq 'WebguiRoot'; + return WebGUI->config_file if $c eq 'WebguiConfig'; # Otherwise, we might want to provide some sort of support (which Apache is still around) return $self->{env}->{"wg.DIR_CONFIG.$c"}; From eb24698bb5653f44fa1e865effc71eca8fe3d87e Mon Sep 17 00:00:00 2001 From: Patrick Donelan Date: Fri, 5 Mar 2010 20:11:06 -0500 Subject: [PATCH 15/15] Updated to reflect changes in Plack::Request API --- lib/WebGUI.pm | 2 +- lib/WebGUI/Session/Http.pm | 22 ++++++++++------------ lib/WebGUI/Session/Plack.pm | 21 ++------------------- 3 files changed, 13 insertions(+), 32 deletions(-) diff --git a/lib/WebGUI.pm b/lib/WebGUI.pm index ac40b5d41c..a78386a929 100644 --- a/lib/WebGUI.pm +++ b/lib/WebGUI.pm @@ -165,7 +165,7 @@ sub handler { my ($server, $config); if ($request->isa('WebGUI::Session::Plack')) { $server = $request->server; - $config = WebGUI->config; + $config = WebGUI->config; # use our cached version } else { $request = Apache2::Request->new($request); $server = Apache2::ServerUtil->server; #instantiate the server api diff --git a/lib/WebGUI/Session/Http.pm b/lib/WebGUI/Session/Http.pm index 0861d2d9f3..0f2dcbae32 100644 --- a/lib/WebGUI/Session/Http.pm +++ b/lib/WebGUI/Session/Http.pm @@ -93,7 +93,7 @@ sub getCookies { my $self = shift; if ($self->session->request) { if ($self->session->request->isa('WebGUI::Session::Plack')) { - return $self->session->request->get_request_cookies; + return $self->session->request->{request}->cookies; } # Have to require this instead of using it otherwise it causes problems for command-line scripts on some platforms (namely Windows) @@ -389,17 +389,15 @@ sub setCookie { $ttl = (defined $ttl ? $ttl : '+10y'); if ($self->session->request) { - if ( $self->session->request->isa('WebGUI::Session::Plack') ) { - $self->session->request->set_response_cookie( - $name => { - value => $value, - path => '/', - expires => $ttl ne 'session' ? $ttl : undef, - domain => $domain, - } - ); - return; - } + 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, diff --git a/lib/WebGUI/Session/Plack.pm b/lib/WebGUI/Session/Plack.pm index 1b552ffa18..c60f04aa81 100644 --- a/lib/WebGUI/Session/Plack.pm +++ b/lib/WebGUI/Session/Plack.pm @@ -39,9 +39,9 @@ sub AUTOLOAD { } # Emulate/delegate/fake Apache2::* subs -sub uri { shift->{request}->request_uri(@_) } +sub uri { shift->{request}->path_info } sub param { shift->{request}->param(@_) } -sub params { shift->{request}->params(@_) } +sub params { shift->{request}->prameters->mixed(@_) } sub headers_in { shift->{request}->headers(@_) } sub headers_out { shift->{headers_out} } sub protocol { shift->{request}->protocol(@_) } @@ -60,23 +60,6 @@ sub content_type { $self->{headers_out}->set( 'Content-Type' => $ct ); } -# These two cookie subs are called from our wG Plack-specific code -sub get_request_cookies { - - # Get the hash of { name => CGI::Simple::Cookie } - my $cookies = shift->{request}->cookies; - - # Convert into { name => value } as expected by wG - my %c = map { $_->name => $_->value } values %{$cookies}; - - return \%c; -} - -sub set_response_cookie { - my ( $self, $name, $val ) = @_; - $self->{response}->cookies->{$name} = $val; -} - # TODO: I suppose this should do some sort of IO::Handle thing sub print { my $self = shift;