oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

fixed cookie handling

Browse source
This commit is contained in:
Patrick Donelan 2009-10-10 19:28:19 +11:00
parent 484760bef0
commit b4698f7725
3 changed files with 99 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

7
etc/dev.localhost.localdomain.psgi
View file

@ -32,12 +32,11 @@ builder {
path => qr{^/uploads/}, path => qr{^/uploads/},
root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/"; root => "$WEBGUI_DOMAINS/dev.localhost.localdomain/public/";
add 'Plack::Middleware::XFramework', add 'Plack::Middleware::XFramework', framework => 'WebGUI';
framework => 'WebGUI';
# Already enabled by plackup script # Already enabled by plackup script
# add 'Plack::Middleware::AccessLog', # add 'Plack::Middleware::AccessLog',
# format => "combined"; # format => "combined";
$app; $app;
} }

20
lib/WebGUI/Session/Http.pm
View file

@ -93,7 +93,7 @@ sub getCookies {
my $self = shift; my $self = shift;
if ($self->session->request) { if ($self->session->request) {
if ($self->session->request->isa('WebGUI::Session::Plack')) { 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) # 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'); $ttl = (defined $ttl ? $ttl : '+10y');
if ($self->session->request) { if ($self->session->request) {
if ($self->session->request->isa('WebGUI::Session::Plack')) { if ( $self->session->request->isa('WebGUI::Session::Plack') ) {
$self->session->request->response_cookies->{$name} = { $self->session->request->set_response_cookie(
value => $value, $name => {
path => '/', value => $value,
expires => $ttl ne 'session' ? $ttl : undef, path => '/',
domain => $domain, expires => $ttl ne 'session' ? $ttl : undef,
}; domain => $domain,
}
);
return; return;
} }
require Apache2::Cookie; require Apache2::Cookie;
my $cookie = Apache2::Cookie->new($self->session->request, my $cookie = Apache2::Cookie->new($self->session->request,

146
lib/WebGUI/Session/Plack.pm
View file

@ -11,73 +11,78 @@ This class is used instead of WebGUI::Session::Request when wg is started via pl
=cut =cut
sub new { sub new {
my ($class, %p) = @_; my ( $class, %p ) = @_;
# 'require' rather than 'use' so that non-plebgui doesn't freak out # 'require' rather than 'use' so that non-plebgui doesn't freak out
require Plack::Request; require Plack::Request;
my $request = Plack::Request->new( $p{env} ); my $request = Plack::Request->new( $p{env} );
my $response = $request->new_response(200); my $response = $request->new_response(200);
my $self = bless { bless {
%p, %p,
pnotes => {}, pnotes => {},
request => $request, request => $request,
response => $response, response => $response,
server => WebGUI::Session::Plack::Server->new( env => $p{env} ), server => WebGUI::Session::Plack::Server->new( env => $p{env} ),
body => [], headers_out => WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response ),
sendfile => undef, body => [],
sendfile => undef,
}, $class; }, $class;
$self->{headers_out} = WebGUI::Session::Plack::HeadersOut->new( request => $request, response => $response );
return $self;
} }
our $AUTOLOAD; our $AUTOLOAD;
sub AUTOLOAD { sub AUTOLOAD {
my $what = $AUTOLOAD; my $what = $AUTOLOAD;
$what =~ s/.*:://; $what =~ s/.*:://;
carp "!!plack->$what(@_)"; carp "!!plack->$what(@_)" unless $what eq 'DESTROY';
} }
# Emulate/delegate/fake Apache2::* subs # Emulate/delegate/fake Apache2::* subs
sub uri { shift->{request}->request_uri(@_) } sub uri { shift->{request}->request_uri(@_) }
sub param { shift->{request}->param(@_) } sub param { shift->{request}->param(@_) }
sub params { shift->{request}->params(@_) } sub params { shift->{request}->params(@_) }
sub headers_in { shift->{request}->headers(@_) } sub headers_in { shift->{request}->headers(@_) }
sub headers_out { shift->{headers_out} } sub headers_out { shift->{headers_out} }
sub protocol { shift->{request}->protocol(@_) } sub protocol { shift->{request}->protocol(@_) }
sub status { shift->{response}->status(@_) } sub status { shift->{response}->status(@_) }
sub sendfile { $_[0]->{sendfile} = $_[1] } sub sendfile { $_[0]->{sendfile} = $_[1] }
sub content_type { shift->{response}->content_type(@_) } sub content_type { shift->{response}->content_type(@_) }
sub status_line {} sub server { shift->{server} }
sub DESTROY {} sub status_line { }
sub auth_type {} # should we support this? sub auth_type { } # should we support this?
sub server { shift->{server} } # These two cookie subs are called from our wG Plack-specific code
sub request_cookies { shift->{request}->cookies } sub get_request_cookies { shift->{request}->cookies } # returns hashref of all request cookies
sub response_cookies { shift->{response}->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 # TODO: I suppose this should do some sort of IO::Handle thing
sub print { sub print {
my $self = shift; my $self = shift;
push @{$self->{body}}, @_; push @{ $self->{body} }, @_;
} }
sub dir_config { sub dir_config {
my ($self, $c) = @_; my ( $self, $c ) = @_;
return $self->{env}->{"wg.DIR_CONFIG.$c"}; return $self->{env}->{"wg.DIR_CONFIG.$c"};
} }
sub pnotes { sub pnotes {
my ($self, $key) = (shift, shift); my ( $self, $key ) = ( shift, shift );
return wantarray ? %{$self->{pnotes}} : $self->{pnotes} unless defined $key; return wantarray ? %{ $self->{pnotes} } : $self->{pnotes} unless defined $key;
return $self->{pnotes}{$key} = $_[0] if @_; return $self->{pnotes}{$key} = $_[0] if @_;
return $self->{pnotes}{$key}; return $self->{pnotes}{$key};
} }
sub user { sub user {
my ($self, $user) = @_; my ( $self, $user ) = @_;
if (defined $user) { if ( defined $user ) {
$self->{user} = $user; $self->{user} = $user;
} }
$self->{user}; $self->{user};
@ -85,35 +90,39 @@ sub user {
sub push_handlers { sub push_handlers {
my $self = shift; my $self = shift;
my ($x, $sub) = @_; my ( $x, $sub ) = @_;
# log it # log it
# carp "push_handlers($x)"; # carp "push_handlers($x)";
# run it # run it
# returns something like Apache2::Const::OK, which we just ignore because we're not modperl # returns something like Apache2::Const::OK, which we just ignore because we're not modperl
my $ret = $sub->($self); my $ret = $sub->($self);
return; return;
} }
sub finalize { sub finalize {
my $self = shift; my $self = shift;
my $response = $self->{response}; my $response = $self->{response};
if ($self->{sendfile} && open my $fh, '<', $self->{sendfile}) { if ( $self->{sendfile} && open my $fh, '<', $self->{sendfile} ) {
$response->body( $fh ); $response->body($fh);
} else { }
else {
$response->body( $self->{body} ); $response->body( $self->{body} );
} }
return $response->finalize; return $response->finalize;
} }
# sub no_cache {
#sub headers_in { my ( $self, $doit ) = @_;
# my $self = shift; if ($doit) {
# return unless $self->plack; $self->{response}->headers->push_header( 'Pragma' => 'no-cache', 'Cache-control' => 'no-cache' );
# return $self->plack->headers(@_); }
#} else {
$self->{response}->headers->remove_header( 'Pragma', 'Cache-control' );
}
}
################################################ ################################################
@ -125,19 +134,19 @@ use Carp;
sub new { sub new {
my $class = shift; my $class = shift;
bless { @_ }, $class; bless {@_}, $class;
} }
our $AUTOLOAD; our $AUTOLOAD;
sub AUTOLOAD { sub AUTOLOAD {
my $what = $AUTOLOAD; my $what = $AUTOLOAD;
$what =~ s/.*:://; $what =~ s/.*:://;
carp "!!server->$what(@_)"; carp "!!server->$what(@_)" unless $what eq 'DESTROY';
} }
sub DESTROY {}
sub dir_config { sub dir_config {
my ($self, $c) = @_; my ( $self, $c ) = @_;
return $self->{env}->{"wg.DIR_CONFIG.$c"}; return $self->{env}->{"wg.DIR_CONFIG.$c"};
} }
@ -145,26 +154,41 @@ sub dir_config {
package WebGUI::Session::Plack::HeadersOut; 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 strict;
use warnings; use warnings;
use Carp; use Carp;
sub new { sub new {
my $class = shift; my $class = shift;
bless { @_ }, $class; bless {@_}, $class;
} }
our $AUTOLOAD; our $AUTOLOAD;
sub AUTOLOAD { sub AUTOLOAD {
my $what = $AUTOLOAD; my $what = $AUTOLOAD;
$what =~ s/.*:://; $what =~ s/.*:://;
carp "!!headers_out->$what(@_)"; carp "!!headers_out->$what(@_)" unless $what eq 'DESTROY';
} }
sub DESTROY {} # This is the sub that wG calls
sub set {
# Called by wG as $session->response->headers_out->set('Content-Type' => 'text/html'); my $self = shift;
sub set { shift->{response}->headers->header(@_) } $self->{response}->headers->push_header(@_);
}
################################################ ################################################